home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / parassign.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  19.2 KB  |  485 lines
  1. (herald (back_end parassign)
  2.   (env t (orbit_top defs) (back_end closure) (back_end bookkeep)))
  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. (define-local-syntax (ass-comment string . rest)
  30.   `(if *assembly-comments?*
  31.        (emit-comment (format nil ,string ,@rest))))                      
  32.  
  33. ;;; ALLOCATE-CALL The "top".  Dispatch on the type of call.
  34.  
  35. (define (allocate-call node)
  36.   (if *call-break?* (breakpoint (pp-cps node)))
  37.   (cond ((call-hoisted-cont node)
  38.          => (lambda (cont) (make-stack-closure node cont))))
  39.   (let ((proc (call-proc node)))
  40.     (cond ((primop-node? proc)
  41.            (ass-comment "~s" (pp-cps node))
  42.            (allocate-primop-call node))
  43.           ((lambda-node? proc)
  44.            (generate-let node))
  45.           ((variable-known (leaf-value proc))
  46.            => (lambda (proc)                     
  47.                 (ass-comment "Call known procedure ~s" 
  48.                          (cons (lambda-name proc) (cdr (pp-cps node))))
  49.                 (xcond ((fx= (call-exits node) 0)
  50.                         (allocate-known-return node proc))
  51.                        ((fx= (call-exits node) 1)
  52.                         (allocate-known-call node proc)))))
  53.           ((fx= (call-exits node) 0)
  54.            (ass-comment "Return from procedure ~s" (pp-cps node))
  55.            (allocate-return node))
  56.           ((fx= (call-exits node) 1)
  57.            (ass-comment "Call unknown procedure ~s" (pp-cps node))
  58.            (allocate-general-call node))
  59.           (else
  60.            (bug "too many exits - ~s" node)))))
  61.   
  62. ;;; ALLOCATE-LABEL-CALL If this is the path that arrives first, go to
  63. ;;; determine where the free variables of the join are to be kept.
  64. ;;; Make the state of the registers the way the join point wants it.
  65. ;;; Parallel assign and jump to the label.
  66.                          
  67. (define (allocate-known-call node proc)
  68.   (xselect (lambda-strategy proc)
  69.     ((strategy/label) (allocate-label-call node proc))
  70.     ((strategy/heap) (allocate-known-heap-call node proc))
  71.     ((strategy/ezclose) (allocate-ezclose-call node proc))
  72.     ((strategy/vframe) (allocate-vframe-call node proc)))
  73.   (if (call-in-body? proc node)
  74.       (generate-jump proc)
  75.       (generate-avoid-jump proc)))
  76.       
  77.  
  78. (define (allocate-known-heap-call node proc)
  79.   (let ((cont ((call-arg 1) node)))
  80.     (parallel-assign-general node)
  81.     (if (leaf-node? cont) (restore-continuation node cont)))
  82.   (clear-slots)                            
  83.   (generate-move (reg-offset P -2) TP)
  84.   (if (n-ary? proc) 
  85.       (generate-move (machine-num (length (call-args node))) NARGS)))
  86.  
  87.  
  88. (define (allocate-label-call node proc)
  89.   (let ((join (get-or-set-join-state node proc))
  90.         (cont ((call-arg 1) node)))
  91.     (parallel-assign node
  92.                      (cdr (call-args node))
  93.                      (join-point-arg-specs join)
  94.                      nil
  95.                      (join-point-global-registers join))
  96.     (if (leaf-node? cont) (restore-continuation node cont))
  97.     (cond ((and (join-point-contour-needed? join)
  98.                 (join-point-contour join))
  99.            => (lambda (contour)
  100.                 (let ((b (variable-binder contour)))
  101.                   (if (and (closure-cit-offset (environment-closure (lambda-env b)))
  102.                            (neq? *lambda* b))
  103.                       (generate-move (reg-offset P -2) TP)))))))
  104.   (clear-slots))
  105.                        
  106.  
  107. (define (allocate-vframe-call node proc)
  108.   (cond ((lambda-node? ((call-arg 1) node))
  109.          (parallel-assign-vframe node proc))
  110.         (else                          
  111.          (parallel-assign-vframe node proc)          
  112.          (restore-vframe-continuation node proc)))
  113.   (clear-slots)                            
  114.   (if (n-ary? proc) (generate-move (length (call-args node)) NARGS)))
  115.                     
  116.                                                           
  117. (define (allocate-ezclose-call node proc)
  118.   (parallel-assign-known node)          
  119.   (restore-ezclose-continuation node proc)
  120.   (clear-slots)                            
  121.   (if (n-ary? proc) (generate-move (length (call-args node)) NARGS)))
  122.  
  123.  
  124.                          
  125. (define (allocate-known-return node proc)
  126.   (select (lambda-strategy proc)
  127.     ((strategy/label) (allocate-label-return node proc))
  128.     (else 
  129.      (parallel-assign-return node)      
  130.      (restore-continuation node (call-proc node))
  131.      (clear-slots)
  132.      (generate-jump proc))))
  133.       
  134.  
  135.  
  136.  
  137. (define (allocate-label-return node proc)
  138.   (let ((join (get-or-set-join-state node proc)))
  139.     (cond ((n-ary? proc)
  140.            (really-parallel-assign node '() '() (join-point-global-registers join)))
  141.           (else
  142.            (parallel-assign node
  143.                             (call-args node)
  144.                             (join-point-arg-specs join)
  145.                             nil
  146.                             (join-point-global-registers join)))))
  147.   (restore-continuation node (call-proc node))
  148.   (clear-slots)
  149.   (generate-jump proc))
  150.  
  151. (define (allocate-conditional-continuation node proc-leaf)
  152.   (let ((proc (variable-known (leaf-value proc-leaf))))
  153.     (select (lambda-strategy proc)
  154.       ((strategy/stack))
  155.       (else
  156.        (let ((join (get-or-set-join-state node proc)))
  157.          (parallel-assign node
  158.                           '()
  159.                           (join-point-arg-specs join)
  160.                           nil
  161.                         (join-point-global-registers join)))))
  162.    (restore-continuation node proc-leaf)
  163.    (clear-slots)
  164.    (generate-jump proc)))
  165.  
  166.  
  167.   
  168.  
  169. (define (allocate-general-call node)
  170.   (let ((cont ((call-arg 1) node)))
  171.     (cond ((lambda-node? cont)     
  172.            (parallel-assign-general node))
  173.           (else                          
  174.            (parallel-assign-general node)          
  175.            (restore-continuation node cont))))
  176.   (clear-slots)
  177.   (generate-general-call (reference-variable (call-proc node))
  178.              (fx- (length (call-args node)) 1)))
  179.  
  180.                                    
  181. (define (allocate-return node)
  182.   (parallel-assign-return node)      
  183.   (restore-continuation node (call-proc node))
  184.   (clear-slots)
  185.   (generate-return (length (call-args node))))
  186.                          
  187.  
  188.  
  189.  
  190. (define (parallel-assign-general node)
  191.   (parallel-assign node (cons (call-proc node) (cdr (call-args node)))
  192.                         nil t '()))
  193.                                  
  194. (define (parallel-assign-known node)
  195.   (parallel-assign node (cdr (call-args node)) nil nil '()))
  196.                                             
  197.  
  198. (define (parallel-assign-vframe node proc)
  199.   (if (not (lambda-env (node-parent (node-parent proc))))
  200.       (parallel-assign node (cdr (call-args node)) nil nil '())   
  201.       (parallel-assign node (cdr (call-args node)) nil nil 
  202.                (list (cons P (lambda-self-var (node-parent (node-parent proc))))))))
  203.  
  204. (define (parallel-assign-return node)
  205.   (parallel-assign node (call-args node) nil nil '()))
  206.  
  207.  
  208. ;;; PARALLEL-ASSIGN Cons a closure if necessary.  It is known that there
  209. ;;; will only be one that needs to be consed.
  210.  
  211. (define (parallel-assign node args p-list proc? solve-list)
  212.   (let* ((pos-list (if p-list p-list (reg-positions (length args) proc?)))
  213.          (closure (get-closure args)))
  214.     (cond (closure
  215.            (make-heap-closure node closure)
  216.            (really-parallel-assign node args pos-list solve-list))
  217.           (else
  218.            (really-parallel-assign node args pos-list solve-list)))))
  219.  
  220. (define (get-closure args)
  221.   (any (lambda (arg)               
  222.          (and (lambda-node? arg)
  223.               (eq? (lambda-strategy arg) strategy/heap)
  224.               (neq? (environment-closure (lambda-env arg)) *unit*)
  225.               (environment-closure (lambda-env arg))))
  226.        args))
  227.  
  228.  
  229. ;;; do-now - register or temp pairs (source . target)
  230. ;;; trivial - immediate or lambda
  231. ;;; do-later - environment
  232. ;;; See implementor for this stuff. Hairy!!
  233.                        
  234. (define-structure-type arg-mover
  235.   from
  236.   from-rep
  237.   to
  238.   to-rep)                                  
  239.  
  240. (define (mover from from-rep to to-rep)
  241.   (let ((a (make-arg-mover)))
  242.     (set (arg-mover-from a) from)
  243.     (set (arg-mover-from-rep a) from-rep)
  244.     (set (arg-mover-to a) to)
  245.     (set (arg-mover-to-rep a) to-rep)
  246.     a))
  247.  
  248. (define (really-parallel-assign node args pos-list solve-list)
  249.   (receive (do-now trivial do-later) (sort-by-difficulty args pos-list)
  250.     (receive (do-now do-later) (add-on-free-list do-now do-later solve-list)
  251.       (solve node do-now do-later)                                    
  252.       (lock AN)                     ; contains closures
  253.       (walk (lambda (pair)
  254.               (if (lambda-node? (car pair))
  255.                   (do-trivial-lambda node (car pair) (cdr pair))))
  256.             trivial)
  257.       (unlock AN)
  258.       (do-indirects node do-later)
  259.       (walk (lambda (pair)
  260.               (if (not (lambda-node? (car pair)))
  261.                   (do-immediate (car pair) (cdr pair))))
  262.             trivial))))
  263.                                                       
  264.  
  265. (define (add-on-free-list do-now do-later solve-list)
  266.   (iterate loop ((pairs solve-list) (do-now do-now) (do-later do-later))
  267.     (cond ((null? pairs)
  268.            (return do-now do-later))
  269.           ((or (register-loc (cdar pairs))
  270.                (temp-loc (cdar pairs)))
  271.            => (lambda (reg)
  272.                 (loop (cdr pairs)
  273.                       (cons (mover reg (variable-rep (cdar pairs)) 
  274.                                    (caar pairs) (variable-rep (cdar pairs)))
  275.                             do-now)
  276.                       do-later)))
  277.           (else
  278.            (loop (cdr pairs)
  279.                  do-now
  280.                  (if (fx= (caar pairs) P)
  281.                      (append! do-later (list (cons (cdar pairs) P)))
  282.                      (cons (cons (cdar pairs) (caar pairs))
  283.                            do-later)))))))
  284.  
  285.  
  286. (define (sort-by-difficulty args pos-list)
  287.   (iterate loop ((args args) (do-now '()) (trivial '()) (do-later '())
  288.                  (pos-list pos-list))
  289.     (cond ((null? args)
  290.            (return do-now trivial do-later))
  291.           ((lambda-node? (car args)) 
  292.            (let ((l (car args)))
  293.              (cond ((eq? (environment-closure (lambda-env l)) *unit*)
  294.                     (loop (cdr args)
  295.                           do-now
  296.                           trivial
  297.                           (cons (cons l (car pos-list)) do-later)
  298.                           (cdr pos-list)))
  299.                    (else
  300.                     (loop (cdr args)
  301.                           do-now
  302.                           (cons (cons l (car pos-list)) trivial)
  303.                           do-later
  304.                           (cdr pos-list))))))
  305.           ((addressable? (leaf-value (car args)))
  306.            (loop (cdr args)
  307.                  do-now
  308.                  (cons (cons (car args) (car pos-list)) trivial)
  309.                  do-later
  310.                  (cdr pos-list)))
  311.           (else
  312.            (let* ((val (leaf-value (car args)))
  313.                   (value (cond ((and (variable? val) (variable-known val))
  314.                                => lambda-self-var)
  315.                               (else val))))
  316.              (cond ((or (register-loc value) (temp-loc value))
  317.                     => (lambda (reg)
  318.                          (loop (cdr args)
  319.                                (cons (mover reg (variable-rep value)
  320.                                             (caar pos-list) (cdar pos-list))
  321.                                      do-now)
  322.                                trivial
  323.                                do-later
  324.                                (cdr pos-list))))
  325.                    (else
  326.                     (loop (cdr args)
  327.                           do-now
  328.                           trivial
  329.                           (if (fx= (caar pos-list) P)
  330.                               (append! do-later (list (cons value (car pos-list))))
  331.                               (cons (cons value (car pos-list)) do-later))
  332.                           (cdr pos-list)))))))))
  333.  
  334.  
  335. (define (do-immediate node reg-rep)
  336.   (generate-move (value-with-rep (leaf-value node) (cdr reg-rep)) 
  337.                  (car reg-rep)))
  338.  
  339. (define (do-indirects node do-later) 
  340.   (iterate loop ((items do-later))
  341.     (if items
  342.         (let ((item (car items))
  343.               (contour (lambda-self-var *lambda*)))
  344.           (receive (mover target) (cond ((and (node? (car item)) 
  345.                                               (lambda-node? (car item)))
  346.                                          (return indirect-lambda (cadr item)))
  347.                                         ((atom? (cdr item))
  348.                                          (return indirect-free-var (cdr item)))
  349.                                         (else
  350.                                          (return indirect-arg (cadr item))))
  351.             (cond ((or (eq? (register-loc contour) target)
  352.                        (eq? (temp-loc contour) target))        
  353.                    (if (cdr items)
  354.                        (loop (append (cdr items) (cons item '())))
  355.                        (mover node item target)))
  356.                   (else
  357.                    (mover node item target)
  358.                    (loop (cdr items)))))))))
  359.         
  360.  
  361. (define (indirect-lambda node pair target) 
  362.   (lambda-queue (car pair))
  363.   (generate-move (lookup node (car pair) nil) target)
  364.   (unmark-reg target)
  365.   (lock target))
  366.  
  367. (define (indirect-free-var node pair target)
  368.   (really-rep-convert node
  369.                       (access-value node (car pair)) 
  370.                       (variable-rep (car pair))
  371.                       target
  372.                       (variable-rep (car pair)))
  373.   (unmark-reg target)
  374.   (mark (car pair) target)
  375.   (lock target))
  376.  
  377. (define (indirect-arg node pair target)
  378.   (let ((to-rep (cddr pair)))
  379.     (really-rep-convert node 
  380.                         (access-value node (car pair))
  381.                         (if (variable? (car pair))
  382.                             (variable-rep (car pair)) 
  383.                             'rep/pointer) 
  384.                         target
  385.                         to-rep)
  386.     (unmark-reg target)
  387.     (kill (car pair))
  388.     (mark (car pair) target)
  389.     (lock target)))
  390.                    
  391. (define (unmark-reg reg)
  392.   (cond ((reg-node reg)
  393.          => (lambda (var)
  394.               (set (reg-node reg) nil)
  395.               (if (register? reg)
  396.                   (set (register-loc var) nil)
  397.                   (set (temp-loc var) nil))))))
  398.  
  399.                
  400. (define (solve node movers do-later)
  401.   (let ((contour (lambda-self-var *lambda*))
  402.         (vals (map (lambda (mover)
  403.                        (reg-node (arg-mover-to mover)))
  404.                      movers)))
  405.     (cond ((and do-later
  406.                 (any (lambda (mover)
  407.                         (if (eq? (reg-node (arg-mover-to mover)) contour)
  408.                             mover
  409.                             nil))
  410.                       movers))
  411.            => (lambda (mover)
  412.                 (if (neq? (arg-mover-from mover) (arg-mover-to mover))
  413.                     (free-register node (register-loc contour)))
  414.                 (walk (lambda (val)
  415.                         (if (neq? val contour) (kill val)))
  416.                       vals)))
  417.           (else
  418.            (walk kill vals)))
  419.     (walk (lambda (mover)
  420.             (lock (arg-mover-to mover)))
  421.           movers)
  422.     (receive (movers self-movers) (separate-self-movers movers)
  423.       (if (not (exchange-hack movers))
  424.           (do-assignment movers node))
  425.       (walk (lambda (mover)
  426.               (really-rep-convert node (arg-mover-from mover)
  427.                                        (arg-mover-from-rep mover)
  428.                                        (arg-mover-to mover)
  429.                                        (arg-mover-to-rep mover)))
  430.             self-movers))))
  431.                            
  432. (define (do-assignment movers node)
  433.   (iterate loop1 ((movers movers)
  434.                   (targets (map arg-mover-to movers))
  435.                   (temp nil))
  436.     (cond ((null? movers))
  437.         (else
  438.          (iterate loop2 ((candidates targets))
  439.            (cond ((null? candidates)
  440.                   (let ((mover (car movers)))
  441.                     (generate-move (arg-mover-to mover)
  442.                                    (reg-offset TASK
  443.                                      (if (eq? (arg-mover-to-rep mover) 'rep/pointer)
  444.                                           task/extra-pointer
  445.                                           task/extra-scratch)))
  446.                     (really-rep-convert node
  447.                                         (arg-mover-from mover)
  448.                                         (arg-mover-from-rep mover)
  449.                                         (arg-mover-to mover)
  450.                                         (arg-mover-to-rep mover))
  451.                     (loop1 (cdr movers)
  452.                            (delq (arg-mover-to mover) targets)
  453.                            (arg-mover-to mover))))
  454.                  ((not (mem? from-reg-eq? (car candidates) movers))
  455.                   (let ((mover (car (mem to-reg-eq? (car candidates) movers))))
  456.                     (really-rep-convert node
  457.                          (cond ((eq? (arg-mover-from mover) temp)
  458.                                 (if (eq? (arg-mover-to-rep mover) 'rep/pointer)
  459.                                     (reg-offset TASK task/extra-pointer)
  460.                                     (reg-offset TASK task/extra-scratch)))
  461.                                (else
  462.                                 (arg-mover-from mover)))
  463.                          (arg-mover-from-rep mover)
  464.                          (arg-mover-to mover)
  465.                          (arg-mover-to-rep mover))
  466.                     (loop1 (delq mover movers)
  467.                            (delq (arg-mover-to mover) targets)
  468.                            temp)))
  469.                  (else
  470.                   (loop2 (cdr candidates)))))))))
  471.  
  472.  
  473. (define (separate-self-movers movers)
  474.   (iterate loop ((movers movers) (m '()) (s '()))
  475.     (cond ((null? movers) (return m s))
  476.           ((eq? (arg-mover-from (car movers)) (arg-mover-to (car movers)))
  477.            (loop (cdr movers) m (cons (car movers) s)))
  478.           (else
  479.            (loop (cdr movers) (cons (car movers) m) s)))))
  480.  
  481. (define (to-reg-eq? reg mover) (fx= (arg-mover-to mover) reg))
  482. (define (from-reg-eq? reg mover) (fx= (arg-mover-from mover) reg))
  483.  
  484.  
  485.