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