home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / fixup.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  10.6 KB  |  270 lines
  1. (herald (front_end fixup)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; (lambda (k) <body>) => (lambda (v) ((lambda (k) <body>) v))
  5.  
  6. (define (fixup-node-tree top-node)
  7.   (fixup-call-node (lambda-body top-node))
  8.   (set (node-parent top-node) nil)
  9.   top-node)
  10.  
  11. (define (fixup-value-node node)
  12. ;  (if (not (node-simplified? node))
  13. ;      (bug "~S has not been simplified" node))
  14.   (cond ((lambda-node? node)
  15.          (fixup-call-node (lambda-body node)))
  16.         ((object-node? node)
  17.          (fixup-value-node (object-proc node))
  18.          (walk fixup-value-node (object-operations node))
  19.          (walk fixup-value-node (object-methods node))
  20.          (fix-object-node node))))
  21.  
  22. (define (fixup-call-node node)
  23.   (walk fixup-value-node (call-proc+args node))
  24.   (let ((proc (call-proc node)))
  25.     (cond ((lambda-node? proc)
  26.            (walk (lambda (var val)
  27.                    (if (lambda-node? val)
  28.                        (check-continuation-var var val)))
  29.                  (lambda-variables proc)
  30.                  (call-args node)))
  31.           ((primop-node? proc)
  32.            (select (primop-value proc)
  33.              ((primop/conditional)
  34.               (if (reference-node? ((call-arg 1) node))
  35.                   (replace-with-lambda ((call-arg 1) node) 0))
  36.               (if (reference-node? ((call-arg 2) node))
  37.                   (replace-with-lambda ((call-arg 2) node) 0)))
  38.              ((primop/undefined-effect)
  39.               (simplify-undefined-effect node))
  40.              ((primop/y)
  41.               (fixup-y node)))))))
  42.  
  43. (define (check-continuation-var var val)
  44.   (cond ((any? (lambda (ref)
  45.                  (eq? (node-role ref) call-proc))
  46.                (variable-refs var))
  47.          (walk-refs-safely (lambda (ref)
  48.                              (if (call-exit? ref)
  49.                                  (fix-exit-reference var ref val)))
  50.                            var))
  51.         ((fxn= 2 (variable-number var))
  52.          (walk-refs-safely (lambda (ref)
  53.                              (if (and (call-exit? ref)
  54.                                       (not (primop-node?
  55.                                             (call-proc (node-parent ref)))))
  56.                                  (fix-exit-reference var ref val)))
  57.                            var))))
  58.  
  59. (define (fix-exit-reference var node value)
  60.   (let ((proc (call-proc (node-parent node))))
  61.     (cond ((eq? node proc)
  62.            (return))
  63.           ((not (primop-node? proc))
  64.            (introduce-exit-lambda var node value '#t))
  65.           ((eq? primop/y (primop-value proc))
  66.            (introduce-exit-lambda var node value '#f))
  67.           (else
  68.            (replace-with-lambda
  69.             node
  70.             (primop.values-returned
  71.              (primop-value (call-proc (node-parent node)))))))))
  72.  
  73. (define (introduce-exit-lambda var node value args?)
  74.   (if (and args? (used? (lambda-rest-var value)))
  75.       (bug '"don't know how to fixup n-ary exit ~S" value))
  76.   (let* ((new-vars (free-map (lambda (var)
  77.                                (if var
  78.                                    (create-variable (variable-name var))
  79.                                    nil))
  80.                              (lambda-rest+variables value)))
  81.          (cont (create-lambda-node 'c new-vars))
  82.          (args (if (not args?)
  83.                    '()
  84.                    (map (lambda (v) (if v
  85.                                         (create-reference-node v)
  86.                                         (create-literal-node '#f)))
  87.                         (cdr new-vars))))
  88.          (call (create-call-node (fx+ '1 (length args)) '0)))
  89.     (relate call-proc call (create-reference-node var))
  90.     (relate-call-args call args)
  91.     (relate lambda-body cont call)
  92.     (replace node cont)))
  93.  
  94. (define (real-fix-exit-reference var node value)
  95.   (let* ((new-vars (free-map (lambda (var)
  96.                                (if var
  97.                                    (create-variable (variable-name var))
  98.                                    nil))
  99.                              (lambda-rest+variables value)))
  100.          (cont (create-lambda-node 'c new-vars))
  101.          (call (create-call-node (length new-vars) 0)))
  102.     (relate call-proc call (create-reference-node var))
  103.     (relate-call-args call (map (lambda (var)
  104.                                   (if var
  105.                                       (create-reference-node var)
  106.                                       (create-literal-node '#f)))
  107.                                 (cdr new-vars)))
  108.     (relate lambda-body cont call)
  109.     (replace node cont)))
  110.  
  111. (define (replace-with-lambda node count)
  112.   (let* ((vars (do ((i 0 (fx+ i 1))
  113.                     (v '() (cons (create-variable 'v) v)))
  114.                    ((fx>= i count) v)))
  115.          (l-node (create-lambda-node 'x `(#f . ,vars)))
  116.          (c-node (create-call-node (fx+ 1 count) 0)))
  117.     (move node
  118.           (lambda (node)
  119.             (relate lambda-body l-node c-node)
  120.             (relate call-proc c-node node)
  121.             (relate-call-args c-node (map create-reference-node vars))
  122.             l-node))))                         
  123.  
  124. (define (replace-with-one-arg-lambda node)
  125.   (let* ((v (create-variable 'v))
  126.          (l-node (create-lambda-node 'x `(#f ,v)))
  127.          (c-node (create-call-node 2 0)))
  128.     (move node
  129.           (lambda (node)
  130.             (relate lambda-body l-node c-node)
  131.             (relate call-proc c-node node)
  132.             (relate (call-arg 1) c-node (create-reference-node v))
  133.             l-node))))
  134.  
  135. ;;; Remove any continuation of UNDEFINED-EFFECT (now done by simplifier)
  136. ;
  137. ;(define (fixup-undefined-effect node)
  138. ;  (cond ((fx= (call-exits node) 1)
  139. ;         (set (call-exits node) 0)
  140. ;         (erase-all (detach ((call-arg 1) node)))
  141. ;         (relate-new-call-args node (map detach (cdr (call-args node))))
  142. ;         t)
  143. ;        ((and (fx= 1 (length (call-args node)))
  144. ;              (literal-node? ((call-arg 1) node))
  145. ;              (pair? (literal-value ((call-arg 1) node))))
  146. ;         (modify (literal-value ((call-arg 1) node)) cdr))
  147. ;        (else 
  148. ;         nil))) 
  149.  
  150. ;;; Fixing up a call to PRIMOP/Y so that all values are dethunked lambdas.
  151.  
  152. (define (fixup-y node)
  153.   (let* ((y-lambda ((call-arg 2) node))
  154.          (value-call (lambda-body y-lambda))
  155.          (body-lambda ((call-arg 1) value-call))
  156.          (removed (remove-loop-values y-lambda value-call simple-thunk?)))
  157.     (if removed
  158.         (introduce-labels-cells node value-call removed))
  159.     (cond ((not (null? (cdr (lambda-variables y-lambda))))
  160.            (walk (lambda (thunk)
  161.                    (replace thunk (detach (thunk-value thunk))))
  162.                  (cdr (call-args value-call))))
  163.           (else
  164.            (substitute-y-continuation body-lambda ((call-arg 1) node))
  165.            (replace node (detach (lambda-body body-lambda)))))))
  166.  
  167. (define (substitute-y-continuation b-lambda cont)
  168.   (let ((c-var (car (lambda-variables b-lambda))))
  169.     (cond ((null? (variable-refs c-var)))
  170.           ((or (null? (cdr (variable-refs c-var)))
  171.                (reference-node? cont))
  172.            (substitute c-var cont t))
  173.           (else
  174.            (move b-lambda
  175.                  (lambda (old)
  176.                    (let-nodes ((new (#f) ((! old) 0 (! (detach cont)))))
  177.                      new)))))))
  178.  
  179. (define (introduce-labels-cells node value-call removed)
  180.   (let ((body-lambda ((call-arg 1) value-call))
  181.         (parent (node-parent node)))
  182.     (walk (lambda (r)
  183.             (let* ((var (car r))
  184.                    (new-var (create-variable (variable-name var))))
  185.               (walk-refs-safely (lambda (ref)
  186.                                   (hack-reference ref new-var))
  187.                                 var)
  188.               (add-label-cell new-var parent)
  189.               (add-label-assigner new-var (cdr r) body-lambda)))
  190.           removed)))
  191.  
  192. (define (add-label-assigner var thunk parent)
  193.   (cond ((thunk-value thunk)
  194.          => (lambda (value)
  195.               (add-simple-label-assigner var (detach value) parent)
  196.               (splice-thunk thunk parent)))
  197.         (else
  198.          (let* ((c-var (create-variable 'k))
  199.                 (value (create-reference-node c-var)))
  200.            (add-simple-label-assigner var value parent)
  201.            (var-gets-thunk-value c-var thunk parent)))))
  202.  
  203. (define (add-simple-label-assigner var value parent)
  204.   (let ((call (create-call-node 5 1))
  205.         (cont (create-lambda-node 'c (flist1 (create-variable 'ignore) '()))))
  206.     (relate call-proc call (create-primop-node primop/set-location))
  207.     (relate-four-call-args call
  208.                            cont
  209.                            (create-primop-node primop/cell-value)
  210.                            value
  211.                            (create-reference-node var))
  212.     (insert-call call cont parent)))
  213.  
  214. (define (add-label-cell var parent)
  215.   (let ((call (create-call-node 3 1))
  216.         (cont (create-lambda-node 'c (flist2 nil var '()))))
  217.     (relate call-proc call (create-primop-node primop/make-cell))
  218.     (relate-two-call-args call cont (create-literal-node 'uninitialized-labels))
  219.     (insert-call call cont parent)))
  220.  
  221. ;;; (object <proc> (<op1> ... <opN>) (<meth1> ... <methN>))
  222. ;;; =>
  223. ;;; (lambda (V1)
  224. ;;;   (primop/proc+handler V1
  225. ;;;                        <proc>
  226. ;;;                        (lambda (V2)
  227. ;;;                          (V2 <op1> ... <opN>))
  228. ;;;                        <meth1>
  229. ;;;                        ...
  230. ;;;                        <methN>)))
  231.  
  232. (define (fix-object-node node)
  233.   (let* ((ops (object-operations node))
  234.          (meths (object-methods node))
  235.          (obj-lambda-cont (create-variable 'v))
  236.          (obj-lambda (create-lambda-node 'c (flist2 nil obj-lambda-cont '())))
  237.          (obj-call (create-call-node (fx+ 4 (length meths)) 1))
  238.          (ops-lambda-cont (create-variable 'v))
  239.          (ops-lambda (create-lambda-node 'c (flist2 nil ops-lambda-cont '())))
  240.          (ops-call (create-call-node (fx+ 1 (length ops)) 0)))
  241.     (relate lambda-body obj-lambda obj-call)
  242.     (relate call-proc obj-call (create-primop-node primop/proc+handler))
  243.     (relate-call-args obj-call
  244.                       `(,(create-reference-node obj-lambda-cont)
  245.                         ,(fix-object-proc (object-proc node))
  246.                         ,ops-lambda
  247.                         . ,(map detach meths)))
  248.     (relate lambda-body ops-lambda ops-call)
  249.     (relate call-proc ops-call (create-reference-node ops-lambda-cont))
  250.     (relate-call-args ops-call (map detach ops))
  251.     (replace node obj-lambda)))
  252.  
  253. ;;;  FOO => (LAMBDA (K) (APPLY FOO K))
  254.  
  255. (define (fix-object-proc node)
  256.   (cond ((lambda-node? node)
  257.           (detach node))
  258.         ((leaf-node? node)
  259.          (let ((apply-var (get-system-variable 'apply)))
  260.            (let-nodes ((l (k v)
  261.                          ((* apply-var) 1 (* v) (! (detach node)) (* k))))
  262.              l)))             
  263.         (else
  264.          (bug '"object-proc of ~S is not a leaf or lambda node"
  265.               (node-parent node)))))
  266.  
  267.  
  268.  
  269.  
  270.