home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / closure.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  22.2 KB  |  530 lines
  1. (herald (back_end closure)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29.  
  30.  
  31. ;;; Closure analysis.
  32. ;;;=========================================================================
  33. (lset *top-level-lambda* nil)
  34.  
  35. (define (close-analyze-top node variables)
  36.     (set *unit-closures* nil)
  37.     (set *unit-templates* nil)
  38.     (let* ((l ((call-arg 1) (lambda-body node)))
  39.            (env (list (lambda-self-var node)))
  40.            (via (lambda-self-var l)))
  41.       (bind ((*top-level-lambda* via)) 
  42.         (close-analyze-body (lambda-body l) env via env via))
  43.       (set *unit* (create-unit l)) 
  44.       (create-environment l *unit* 16)
  45.       (return (cddr (closure-env *unit*)) *unit-templates* l))) ; skip the 
  46.                                                                 ; *environment*
  47.                                                                 ; and top-level
  48. (define (close-analyze-body node  senv svia henv hvia)
  49.   (cond ((and (primop-node? (call-proc node))
  50.               (eq? (primop-value (call-proc node)) primop/Y))
  51.          (really-close-analyze-body
  52.                        (cons ((call-arg 1) node) 
  53.                              (call-args (lambda-body ((call-arg 2) node))))
  54.                        senv svia henv hvia))
  55.         (else
  56.          (really-close-analyze-body (call-proc+args node)
  57.                                     senv svia henv hvia))))
  58.  
  59.  
  60. (define (really-close-analyze-body nodes senv svia henv hvia)
  61.   (receive (live cics vframe stack)
  62.            (accumulate-environment nodes senv svia henv hvia)
  63.     (if cics (close-analyze-heap cics live henv hvia))
  64.     (if stack (close-analyze-stack stack senv svia henv hvia))
  65.     (if vframe (close-analyze-vframe vframe hvia svia henv senv))))
  66.  
  67. (define (close-analyze-heap cics live henv hvia)
  68.   (let* ((cic-vars (map lambda-self-var cics))
  69.          (live (set-difference live cic-vars))
  70.          (global? (or (memq? hvia live)
  71.                       (any? (lambda (node)
  72.                               (eq? (lambda-env node) 'unit-internal-closure))
  73.                             cics)))
  74.          (inter (intersection live henv))               
  75.          (link (if (or global? inter)
  76.                     hvia 
  77.                     nil))
  78.          (delta (set-difference (delq! hvia live) henv)))  
  79.     (xselect (lambda-strategy (variable-binder hvia))
  80.       ((strategy/heap)                            
  81.        (if (or global? (cdr inter))
  82.            (create-closure link cic-vars delta nil 'heap)
  83.            (create-closure nil cic-vars live nil 'heap)))
  84.       ((strategy/vframe strategy/hack)
  85.        (create-closure nil cic-vars (delq! hvia live) nil 'heap)))
  86.     (walk (lambda (cic)
  87.             (cond ((object-lambda? cic)
  88.                    (destructure (((#f proc #f . methods) 
  89.                                   (call-args (lambda-body cic))))
  90.                      (walk (lambda (method)                     
  91.                               (set (lambda-env method) (lambda-env cic))
  92.                               (close-analyze-body (lambda-body method)
  93.                                                   live
  94.                                                   (lambda-self-var cic)
  95.                                                   live
  96.                                                   (lambda-self-var cic)))
  97.                            (cons proc methods))))
  98.                   (else
  99.                    (close-analyze-body (lambda-body cic)
  100.                                        live
  101.                                        (lambda-self-var cic)
  102.                                        live
  103.                                        (lambda-self-var cic)))))
  104.           cics)))
  105.  
  106.  
  107.  
  108. (define (close-analyze-vframe vframe hvia svia henv senv) 
  109.   (let* ((live-1 (do ((vframe vframe (cdr vframe))
  110.                     (live '() (union live (lambda-live (car vframe)))))
  111.                    ((null? vframe) live)))
  112.          (link (if (or (intersection? live-1 senv)
  113.                (memq? hvia live-1)
  114.                        (any? (lambda (node)
  115.                                (eq? (lambda-env node) 'needs-link))
  116.                              vframe))
  117.                    svia
  118.                    nil))             
  119.          (via (if (and link (eq? svia hvia)) hvia nil))
  120.      (live (delq! hvia live-1)))
  121.     (xselect (lambda-strategy (car vframe)) 
  122.       ((strategy/ezclose)
  123.        (create-closure via nil (set-difference live senv) vframe 'ezclose)
  124.        (walk (lambda (cic)
  125.                (close-analyze-body (lambda-body cic)
  126.                                    live
  127.                                    (lambda-self-var cic)
  128.                                    henv
  129.                                    hvia))
  130.              vframe))
  131.       ((strategy/vframe)      
  132.        (let* ((contour (lambda-self-var (node-parent 
  133.                           (node-parent (car vframe)))))
  134.               (xlive (delq! contour live)))
  135.          (if (or link xlive)
  136.              (create-closure via nil (set-difference xlive senv) vframe 'vframe)
  137.              (walk (lambda (cic) (set (lambda-env cic) nil)) vframe))
  138.          (walk (lambda (cic)
  139.                  (close-analyze-body (lambda-body cic)
  140.                                      xlive
  141.                                      contour
  142.                                      xlive
  143.                                      contour))
  144.                vframe))))))
  145.   
  146. ;;; (proc+handler k object-proc method-names . methods)
  147. ;;; Must hack this by not returning the proc as a cic.  The parent lambda will
  148. ;;; masquerade as the proc until code generation
  149.  
  150. (define (accumulate-environment nodes senv svia henv hvia)
  151.   (iterate loop ((nodes nodes) (live '()) (cics '()) (vframe '()) (stack '()))
  152.     (cond ((null? nodes)
  153.            (return live cics vframe (reverse! stack)))
  154.           ((not (lambda-node? (car nodes)))
  155.            (loop (cdr nodes) live cics vframe stack))
  156.           (else
  157.            (xselect (lambda-strategy (car nodes))
  158.              ((strategy/heap)
  159.               (cond ((object-lambda? (car nodes))
  160.                      (let* ((args (cdddr (call-args (lambda-body (car nodes)))))
  161.                             (new-cics (close-analyze-object (car nodes) args)))
  162.                        (loop (cdr nodes)
  163.                              (union (lambda-live (car nodes)) live)
  164.                              (append new-cics cics)
  165.                              vframe
  166.                              stack)))
  167.                     ((eq? (lambda-env (car nodes)) 'unit-internal-closure)
  168.                      (push *unit-closures* (car nodes))
  169.                      (let ((env (lambda-live (car nodes)))
  170.                            (via (lambda-self-var (car nodes))))
  171.                        (close-analyze-body (lambda-body (car nodes))
  172.                                            env via env via)
  173.                        (loop (cdr nodes) (union env live) cics vframe stack)))
  174.                     (else
  175.                      (loop (cdr nodes)
  176.                            (union (lambda-live (car nodes)) live)
  177.                            (cons (car nodes) cics)
  178.                            vframe
  179.                            stack))))
  180.              ((strategy/open)
  181.               (close-analyze-body (lambda-body (car nodes)) senv svia henv hvia)
  182.               (loop (cdr nodes) live cics vframe stack))
  183.              ((strategy/label)
  184.               (close-analyze-label (car nodes) henv hvia)
  185.               (loop (cdr nodes) live cics vframe stack))                
  186.              ((strategy/stack)
  187.               (loop (cdr nodes) live cics vframe (append! stack (list (car nodes)))))
  188.              ((strategy/hack)
  189.               (loop (cdr nodes) live cics vframe (cons (car nodes) stack)))
  190.              ((strategy/ezclose)
  191.               (loop (cdr nodes) live cics (cons (car nodes) vframe) stack))
  192.              ((strategy/vframe)
  193.               (loop (cdr nodes) live cics (cons (car nodes) vframe) stack)))))))
  194.  
  195. (define (close-analyze-object obj methods)
  196.   (cond ((null? (lambda-live obj))
  197.          (let ((proc (cadr (call-args (lambda-body obj)))))
  198.            (push *unit-closures* obj)
  199.            (let ((env (lambda-live obj))
  200.                  (via (lambda-self-var obj)))
  201.              (close-analyze-body (lambda-body proc) env via env via)
  202.              (walk (lambda (node)
  203.                      (let ((env (lambda-live node))
  204.                            (via (lambda-self-var (node-parent (node-parent node)))))
  205.                        (close-analyze-body (lambda-body node) env via env via)))
  206.                     methods)))
  207.            '())
  208.         (else  
  209.          (list obj))))
  210.                                     
  211.  
  212.  
  213. (define (close-analyze-stack nodes stackenv stackvia heapenv heapvia)
  214.   (let* ((h (variable-binder heapvia))
  215.          (live (do ((nodes nodes (cdr nodes))
  216.                     (live '() (union live (lambda-live (car nodes)))))
  217.                    ((null? nodes) live)))
  218.          (link-set (if (or (intersection? live stackenv)
  219.                            (and (memq? heapvia live)        
  220.                                 (or (neq? (lambda-strategy h) strategy/vframe)
  221.                                     (lambda-env h)))    ; hack
  222.                            (any? (lambda (node)
  223.                                    (eq? (lambda-env node) 'needs-link))
  224.                                  nodes))
  225.                        `(,stackvia) 
  226.                        '()))
  227.          (closure-env (delq! heapvia (set-difference live stackenv))))
  228.     (create-closure (if (and link-set (eq? stackvia heapvia)) heapvia nil)
  229.                     (map lambda-self-var nodes)
  230.                     closure-env
  231.                     nil
  232.                     'stack)
  233.     (close-analyze-body (lambda-body (car nodes))
  234.                         live
  235.                         (lambda-self-var (car nodes))
  236.                         heapenv heapvia)
  237.     (walk (lambda (node)
  238.             (close-analyze-body (lambda-body node)
  239.                                 live
  240.                                 (lambda-self-var node)
  241.                                 live
  242.                                 (lambda-self-var node)))
  243.           (cdr nodes))))
  244.  
  245.  
  246.  
  247.                        
  248.  
  249.  
  250.                                                              
  251.  
  252.  
  253.  
  254. (define (close-analyze-label node heapenv heapvia)
  255.   (let* ((live (lambda-live node))
  256.          (need-contour? (eq? (lambda-env node) 'needs-link))
  257.          (b (variable-binder heapvia))
  258.          (via (if (or (lambda-live b) (known-lambda? b)) 
  259.                   *top-level-lambda* 
  260.                   heapvia)))
  261.     (set (lambda-env node) (create-join-point live via need-contour?))
  262.     (walk (lambda (var) (set (variable-definition var) 'many)) live)
  263.     (close-analyze-body (lambda-body node) '() via '() via)))
  264.  
  265.  
  266. (define (set-eq? s1 s2)
  267.   (if (fx= (length s1) (length s2))
  268.       (every? (lambda (x) (memq? x s2)) s1)
  269.       nil))      
  270.         
  271. ;;; Environment structure is the lambda-env slot of each lambda which is
  272. ;;; strategy/stack or strategy/heap. The variables are sorted by size.
  273. ;;; (For stack closures) a continuation is represented as offset -1 in the
  274. ;;;  a-list.
  275.  
  276. (lset *unit* nil)
  277. (lset *unit-closures* nil)
  278. (lset *unit-templates* nil)
  279. (lset *unit-literals* nil)                              
  280. (lset *unit-variables* nil)
  281.  
  282. (define-structure-type environment
  283.   closure    ; the closure this environment is a member of
  284.   cic-offset ; offset of this environment's descriptor in the closure
  285.   (((print self stream)
  286.      (format stream "#{Environment_~S in Closure_~S}"
  287.              (object-hash self)    
  288.              (object-hash (environment-closure self))))))
  289.  
  290. (define-structure-type closure             
  291.   members     ; list of closure-internal-closures (variables)
  292.   vframe-lambdas 
  293.   env         ; a-list of variables and offsets in the closure (in bytes)
  294.   pointer     ; number of pointer slots
  295.   scratch     ; number of scratch slots
  296.   size        ; total size of closure (in bytes)
  297.   cit-offset  ; offset of first
  298.   link        ; superior closure
  299.   (((print self stream)
  300.      (format stream "#{Closure_~S with ~D vars, cics ~S}"
  301.              (object-hash self)    
  302.              (length (closure-env self))
  303.              (map variable-unique-name
  304.                   (closure-members self))))))
  305.  
  306. (define-structure-type join-point
  307.   env                  ;;; free variables
  308.   arg-specs            ;;; list of numbers for argument-positions
  309.   global-registers     ;;; list of (register . variable)
  310.   contour              ;;; nearest superior template
  311.   contour-needed?
  312.   )
  313.  
  314. (define (create-join-point env contour needed?)
  315.   (let ((j (make-join-point)))
  316.     (set (join-point-env j) env)
  317.     (set (join-point-arg-specs j) nil)
  318.     (set (join-point-global-registers j) 'not-yet-determined)
  319.     (set (join-point-contour-needed? j) needed?)
  320.     (set (join-point-contour j) contour)
  321.     j))
  322.  
  323.                                               
  324. (define-structure-type loc-list        ;;; appears in the unit
  325.   var
  326.   )
  327.  
  328.  
  329. (define (create-loc-list var)
  330.   (let ((l (make-loc-list)))
  331.     (set (loc-list-var l) var)
  332.     l))
  333.  
  334.  
  335. (define (create-unit thing)
  336.  (let ((unit (make-closure))) 
  337.    (receive (a-list count) (do-unit-variables thing)   
  338.      (do ((lits *unit-literals* (cdr lits))
  339.           (count count (fx+ count CELL))
  340.           (a-list a-list `((,(car lits) . ,count) ,@a-list)))
  341.        ((null? lits)
  342.         (do ((closures (reverse! *unit-closures*) (cdr closures))
  343.              (count count (fx+ count CELL))
  344.              (a-list a-list `((,(car closures) . ,count) ,@a-list)))
  345.             ((null? closures)
  346.              (do ((templates *unit-templates* (cdr templates))
  347.                   (count count (fx+ count (fx* CELL 3)))
  348.                   (a-list a-list `((,(car templates) . ,(fx+ count CELL)) ,@a-list)))
  349.                  ((null? templates)
  350.                   (set (closure-pointer unit) (fx- (fx/ count CELL) 1))
  351.                   (set (closure-scratch unit) 0)
  352.                   (set (closure-env unit)  (reverse! a-list))
  353.                   (set (closure-cit-offset unit) nil)
  354.                   unit) 
  355.                (set (closure-cit-offset (car templates)) (fx+ count CELL))))
  356.           (create-environment (car closures) unit count)))))))
  357.  
  358. (define *the-environment* (create-variable '*the-environment*))
  359.                            
  360.                                    
  361. (define (do-unit-variables thing)
  362.   (iterate loop ((a-list `((,*the-environment* . 12) (,thing . 16)))
  363.                  (vars (delq! *the-environment* *unit-variables*)); header 0
  364.                  (count 20))                                      ; id 4
  365.     (cond ((null? vars) (return a-list count))                    ; filename 8
  366.           (else                                                   ; env 12
  367.            (let ((var (car vars)))                                ; thing 16
  368.          (receive (value? vcell?)
  369.               (cond ((defined-variable? var)
  370.                  (if (null? (cdr (variable-refs var)))
  371.                  (return nil t)
  372.                  (return (all-important-refs-are-calls? var) t)))
  373.                 ((all-important-refs-are-calls? var)
  374.                  (return t nil))
  375.                 (else
  376.                  (return nil t)))
  377.            (if (and value? vcell?)
  378.            (loop `(,(cons var (fx+ count cell)) 
  379.                ,(cons (create-loc-list var) count)
  380.                ,@a-list)
  381.              (cdr vars)
  382.              (fx+ count (fx* CELL 2)))
  383.            (if value? 
  384.                (loop `(,(cons var count) ,@a-list)
  385.                  (cdr vars)
  386.                  (fx+ count CELL))
  387.                (loop `(,(cons (create-loc-list var) count) ,@a-list)
  388.                  (cdr vars)
  389.                  (fx+ count CELL))))))))))
  390.  
  391.  
  392. (define (create-env-a-list pointer scratch)
  393.   (do ((vars `(,@pointer . ,(sort-list! scratch scratch-compare)) (cdr vars))
  394.        (count 0 (fx+ count (rep-size (variable-rep (car vars)))))
  395.        (a-list '() `((,(car vars) . ,count) . ,a-list)))
  396.       ((null? vars)
  397.        (reverse! a-list))))
  398.  
  399. (define *dummy-var* (create-variable '*dummy-var*))
  400.  
  401. (define (create-closure link cics vars vframe-lambdas strategy)
  402.   (let ((closure (make-closure)))
  403.     (if (eq? strategy 'heap) 
  404.         (walk cell-collapse vars)
  405.         (walk (lambda (var) (set (variable-definition var) 'many)) vars))
  406.     (receive (pointer scratch) (sort-vars vars)
  407.       (let* ((scratch-slots (compute-scratch-slots scratch))
  408.              (pvars (if (null? (cdr cics))
  409.                         (if link (cons link pointer) pointer) 
  410.                         (case (length pointer)
  411.                             ((0)
  412.                              (if link 
  413.                                  (list link *dummy-var*)
  414.                                  (list *dummy-var* *dummy-var*))) 
  415.                             ((1)
  416.                              (if link
  417.                                  (list link (car pointer))
  418.                                  (list *dummy-var* (car pointer))))
  419.                             (else
  420.                              (if link (cons link pointer) pointer)))))
  421.              (pointer-slots (fx+ (length pvars) 
  422.                                  (if cics (length cics) 1)))
  423.              (var-a-list (create-env-a-list
  424.                            (if cics 
  425.                                `(,(car cics) ,@pvars ,@(cdr cics)) 
  426.                                `(,*dummy-var* ,@pvars))
  427.                            scratch)))            
  428.           (set (closure-link closure) link)
  429.           (set (closure-members closure) cics)   
  430.           (set (closure-vframe-lambdas closure) vframe-lambdas)
  431.           (set (closure-cit-offset closure) nil)
  432.           (set (closure-env        closure) var-a-list)
  433.           (set (closure-scratch    closure) scratch-slots)
  434.           (set (closure-pointer    closure) (fx- pointer-slots 1))
  435.           (set (closure-size       closure)
  436.                (fx* (fx+ scratch-slots pointer-slots) CELL))
  437.           (if (null? vframe-lambdas)
  438.               (create-environments var-a-list closure cics)
  439.               (create-vframe-environments closure vframe-lambdas))
  440.           closure))))
  441.                                                   
  442. (define (cell-collapse var)
  443.   (cond ((null? (variable-definition var))
  444.          (set (variable-definition var) 
  445.               (if (cell-collapsable? var) 'one 'many)))
  446.         ((eq? (variable-definition var) 'one)
  447.          (set (variable-definition var) 'many))))
  448.        
  449. (define (cell-collapsable? var)
  450.   (every? (lambda (ref)
  451.             (or (and (eq? (node-role ref) (call-arg 3))
  452.                      (primop-ref? (call-proc (node-parent ref))
  453.                                   primop/contents-location))
  454.                 (and (eq? (node-role ref) (call-arg 4))
  455.                      (primop-ref? (call-proc (node-parent ref))
  456.                                   primop/set-location))))
  457.           (variable-refs var)))
  458.  
  459. (define (compute-scratch-slots scratch)
  460.   (do ((vars scratch (cdr vars))
  461.        (count 0 (fx+ count (rep-size (variable-rep (car vars))))))
  462.       ((null? vars)
  463.        (fixnum-ashr (fx+ count 3) 2))))           ; bytes->longwords
  464.  
  465. (define (create-environments var-a-list closure cics)
  466.   (create-environment (variable-binder (car cics)) closure 0)
  467.   (orbit-debug "~a (~d) ~s env = ~a~%" (lambda-strategy (variable-binder (car cics)))
  468.           (object-hash (variable-binder (car cics)))
  469.           (variable-name (car cics))
  470.           (map (lambda (var) (variable-name (car var)))
  471.                (closure-env closure)))
  472.   (walk (lambda (cic)
  473.           (create-environment (variable-binder cic)
  474.                               closure
  475.                               (cdr (assq cic var-a-list))))
  476.         (cdr cics)))
  477.  
  478. (define (create-vframe-environments closure vframe-lambdas)
  479.   (walk (lambda (cic)
  480.           (set (lambda-env cic) nil))
  481.          vframe-lambdas)
  482.   (orbit-debug "~a (~d) ~s env = ~a~%" (lambda-strategy (car vframe-lambdas))
  483.           (object-hash (car vframe-lambdas))
  484.           (variable-name (lambda-self-var (car vframe-lambdas)))
  485.           (map (lambda (var) (variable-name (car var)))
  486.                (closure-env closure))) 
  487.   (create-environment (node-parent (node-parent (car vframe-lambdas))) 
  488.                       closure 0))
  489.  
  490.  
  491.  
  492. (define (create-environment node closure offset)
  493.   (let ((env (make-environment)))
  494.     (set (environment-closure    env) closure)
  495.     (set (environment-cic-offset env) offset)
  496.     (if (and (eq? 'unit-internal-template (lambda-env node))
  497.              (neq? closure (car *unit-templates*)))
  498.         (push *unit-templates* closure))
  499.     (set (lambda-env node) env)))
  500.  
  501. (define (sort-vars vars)
  502.   (iterate loop ((vars vars) (pointer '()) (scratch '()))
  503.     (cond ((null? vars)
  504.            (return pointer scratch))
  505.            ((eq? (variable-rep (car vars)) 'rep/pointer)
  506.             (loop (cdr vars) (cons (car vars) pointer) scratch))
  507.            (else
  508.             (loop (cdr vars) pointer (cons (car vars) scratch))))))
  509.  
  510. (define (bound-to-continuation? var)
  511.   (and (variable-binder var)
  512.        (any? (lambda (ref)
  513.                  (let ((exits (call-exits (node-parent ref))))
  514.                    (and (fx< exits 2)
  515.                         (fx= (call-arg-number (node-role ref)) exits))))
  516.                (variable-refs var))))
  517.  
  518.  
  519. (define (continuation? node)
  520.   (or (null? (lambda-variables node))
  521.       (cond ((car (lambda-variables node))
  522.              => (lambda (k) (not (bound-to-continuation? k))))
  523.             (else t))))
  524.  
  525.  
  526.  
  527.  
  528. (define (scratch-compare var1 var2)
  529.   (fx> (rep-size (variable-rep var1)) (rep-size (variable-rep var2))))
  530.