home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / mipscofix.t < prev    next >
Encoding:
Text File  |  1990-10-15  |  3.5 KB  |  101 lines
  1. (herald fix)
  2.  
  3. (define (orbit-mips-setup directory)
  4.   (set *object-file-extension* 'mbo)
  5.   (set *information-file-extension* 'mbi)
  6.   (set *noise-file-extension* 'mbn)
  7.   (set *debug-file-extension* 'mbd)
  8.   (orbit-setup directory)
  9.   (set (table-entry *modules* 'constants) `(,directory mipsconstants))
  10.   (set (table-entry *modules* 'primops)   `(,directory mipsprimops))
  11.   (set (table-entry *modules* 'arith)     `(,directory mipsarith))
  12.   (set (table-entry *modules* 'low)       `(,directory mipslow))
  13.   (set (table-entry *modules* 'genarith)     `(,directory mipsgenarith))
  14.   nil)
  15.  
  16. (define (orbit-mips-init . directory)
  17.   (orbit-mips-setup (if directory (car directory) '#f))
  18.   (orbit-init 'base
  19.               'constants
  20.               'primops
  21.           'arith
  22.               'locations
  23.               'low
  24.           'predicates
  25.               'open
  26.               'aliases
  27.               'carcdr
  28.               'genarith))
  29.  
  30. (define (add-label-assigner var thunk parent)
  31.   (cond ((thunk-value thunk)
  32.          => (lambda (value)
  33.               (add-simple-label-assigner var (detach value) parent)
  34.               (splice-thunk thunk parent)))
  35.         (else
  36.          (let* ((c-var (create-variable 'k))
  37.                 (value (create-reference-node c-var)))
  38.            (add-simple-label-assigner var value parent)
  39.            (var-gets-thunk-value c-var thunk parent)
  40.        (let ((node (node-parent thunk)))
  41.          (walk (lambda (var val)
  42.              (if (lambda-node? val)
  43.              (check-continuation-var var val)))
  44.            (lambda-variables (call-proc node))
  45.            (call-args node)))))))
  46.  
  47.  
  48. (define (check-continuation-var var val)
  49.   (walk-refs-safely (lambda (ref)
  50.               (if (call-exit? ref)
  51.               (fix-exit-reference var ref val)))
  52.             var))
  53.  
  54. (define (introduce-exit-lambda var node value args?)
  55.   (let* ((new-vars (free-map (lambda (var)
  56.                                (if var
  57.                                    (create-variable (variable-name var))
  58.                                    nil))
  59.                              (lambda-rest+variables value)))
  60.          (cont (create-lambda-node 'c new-vars))
  61.          (args (if (not args?)
  62.                    '()
  63.                    (map (lambda (v) (if v
  64.                                         (create-reference-node v)
  65.                                         (create-literal-node '#f)))
  66.                         (cdr new-vars))))
  67.          (call (create-call-node (fx+ '1 (length args)) '0)))
  68.     (relate call-proc call (create-reference-node var))
  69.     (relate-call-args call args)
  70.     (relate lambda-body cont call)
  71.     (replace node cont)))
  72.  
  73. (define (complexity-analyze node)
  74.   (cond ((empty? node)
  75.          '0)
  76.         ((reference-node? node)
  77.          (cond ((get-variable-definition (reference-variable node)) 0)
  78.                ((call-arg-mismatches? node) 1)
  79.                (else 2)))
  80.         ((leaf-node? node) '0)
  81.         ((lambda-node? node)
  82.          (complexity-analyze (lambda-body node)))
  83.         ((call-node? node)
  84.          (let ((q (complexity-analyze-list (call-proc+args node))))
  85.            (set (call-complexity node) q)
  86.            q))
  87.         ((object-node? node)
  88.          (let ((q1 (complexity-analyze (object-proc node)))
  89.                (q2 (complexity-analyze-list (object-operations node)))
  90.                (q3 (complexity-analyze-list (object-methods node))))
  91.            (fx+ q1 (fx+ q2 q3))))
  92.         (else
  93.          (bug '"funny node ~S" node))))
  94.                     
  95. (define (call-arg-mismatches? node)
  96.   (let ((var (reference-variable node)))
  97.     (and (variable-binder var)
  98.          (fxn= (call-arg-number (node-role node))
  99.                (fx- (variable-number var) 1)))))
  100.  
  101.