home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / reg.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  17.0 KB  |  412 lines
  1. (herald (back_end reg)
  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 (generate-init continuation)
  30.   (bind ((*unit-literals* '())
  31.          (*unit-variables* '())
  32.          (*unit-closures* '())
  33.          (*unit-templates* '())
  34.          (*unit* nil) 
  35.          (*registers* (vector-fill (make-vector *no-of-registers*) nil))
  36.          (*lambda* nil)
  37.          (*stack-pos* 0)
  38.          (*locations* (make-table 'locations))
  39.          (*lambda-queue* '()))
  40.     (continuation)))
  41.  
  42.  
  43. (define (generate top-node)
  44.   (generate-code (car (call-args (lambda-body top-node)))))
  45.  
  46.  
  47. (lset *assembly-comments?* nil)
  48. (lset *lambda-queue* '())         ;; queue of lambda bodies to process
  49. (lset *stack-pos* 0)              ;; distance of stack-pointer from "frame"
  50. (lset *max-temp* 0)               ;; maximum number of temporaries used
  51. (lset *lambda* nil)               ;; the procedure being compiled
  52. (lset *call-break?* nil)           
  53. (lset *registers* nil)
  54.  
  55. (define-local-syntax (ass-comment string . rest)
  56.   `(if *assembly-comments?*
  57.        (emit-comment (format nil ,string ,@rest))))                      
  58.  
  59. ;;; GENERATE-CODE Initialize lambda queue. Go.
  60.  
  61. (define (generate-code node)
  62.   (set *stack-pos* 0)
  63.   (allocate-registers node)                                          
  64.   (process-lambda-queue))
  65.  
  66. (define (generate-code-for-object node)
  67.   (set *stack-pos* 0)            
  68.   (set *lambda* node)
  69.   (let ((object-proc ((call-arg 2) (lambda-body node))))
  70.     (mark-first-continuation (lambda-body object-proc))
  71.     (emit-template node object-proc)
  72.     (if (closure-env (environment-closure (lambda-env node)))
  73.         (mark (lambda-self-var node) P))
  74.     (mark-vars-in-regs (cdr (lambda-variables object-proc)))
  75.     (if (n-ary? object-proc)
  76.         (n-ary-setup object-proc))
  77.     (allocate-call (lambda-body object-proc))
  78.     (emit-tag object-proc))
  79.   (generate-handler node)
  80.   (process-lambda-queue))
  81.  
  82.  
  83. (define (lambda-queue node)
  84.   (push *lambda-queue* node))
  85.  
  86. (define (process-lambda-queue)
  87.   (if *lambda-queue*
  88.       (let ((thing (pop *lambda-queue*)))
  89.         (xcond ((object-lambda? thing)
  90.                 (generate-code-for-object thing))
  91.                ((lambda-node? thing)     
  92.                 (if (neq? (lambda-strategy thing) strategy/stack) 
  93.                     (mark-first-continuation (lambda-body thing)))
  94.                 (generate-code thing))
  95.                ((lap-template-struct? thing)
  96.                 (process-lap-template thing))))))
  97.  
  98. (define (mark-first-continuation node)
  99.   (walk mark-first-continuation-1 (call-proc+args node)))
  100.  
  101.  
  102. (define (mark-first-continuation-1 node)
  103.   (cond ((lambda-node? node)
  104.          (select (lambda-strategy node)
  105.            ((strategy/stack)
  106.             (set (closure-vframe-lambdas 
  107.                        (environment-closure (lambda-env node))) t))
  108.            ((strategy/open)                                        
  109.             (mark-first-continuation (lambda-body node)))))))
  110.  
  111. ;;; ALLOCATE-REGISTERS Sets *lambda* to be the lambda-node representing the
  112. ;;; environment the node argument is compiled in.  Generate code for the body.
  113.  
  114. (define (allocate-registers node)
  115.     (select (lambda-strategy node)
  116.       ((strategy/stack strategy/heap strategy/hack)
  117.        (set *lambda* node)
  118.        (emit-template node node))
  119.       ((strategy/vframe strategy/ezclose)
  120.        (set *lambda* (node-parent (node-parent node)))
  121.        (emit-tag node))
  122.       (else
  123.        (set *lambda* (variable-binder (join-point-contour (lambda-env node))))
  124.        (emit-tag node)))
  125.     (initialize-registers node)
  126.     (if (n-ary? node)
  127.         (n-ary-setup node))
  128.     (allocate-call (lambda-body node)))
  129.     
  130. ;;; INITIALIZE-REGISTERS Here we mark the arguments of a closure as being in
  131. ;;; the argument registers.  For a heaped lambda there is also the environment
  132. ;;; in the P register.  For a join point the state is initialized.
  133.  
  134. (define-integrable (method-lambda node)
  135.   (let ((p (node-parent node)))
  136.     (if (primop-ref? (call-proc p) primop/proc+handler)
  137.         (node-parent p)
  138.         nil)))
  139.    
  140. (define (initialize-registers node)
  141.   (xselect (lambda-strategy node)
  142.     ((strategy/heap strategy/hack)                                       
  143.      (ass-comment "Procedure ~s (lambda ~s ...)" 
  144.              (lambda-name node)
  145.              (append! (map variable-unique-name (lambda-variables node))
  146.                       (cond ((lambda-rest-var node) => variable-unique-name)
  147.                             (else '()))))
  148.      (cond ((method-lambda node)
  149.             => (lambda (obj)
  150.                  (mark (lambda-self-var obj) P)
  151.                  (set *lambda* obj)))
  152.            (else
  153.             (mark (lambda-self-var node) P)))
  154.      (mark-vars-in-regs (cdr (lambda-variables node))))
  155.     ((strategy/stack)
  156.      (ass-comment "Continuation ~s (lambda ~s ...)"
  157.              (lambda-name node)
  158.              (append! (map variable-unique-name (lambda-variables node))
  159.                       (cond ((lambda-rest-var node) => variable-unique-name)
  160.                             (else '()))))
  161.      (mark-vars-in-regs (lambda-variables node)))
  162.     ((strategy/vframe)
  163.      (ass-comment "Procedure ~s (lambda ~s ...)" 
  164.              (lambda-name node)
  165.              (map variable-unique-name (lambda-variables node)))
  166.      (mark (lambda-self-var *lambda*) P)
  167.      (mark-vars-in-regs (cdr (lambda-variables node))))
  168.     ((strategy/ezclose)
  169.      (ass-comment "Procedure ~s (lambda ~s ...)" 
  170.              (lambda-name node)
  171.              (map variable-unique-name (lambda-variables node)))
  172.      (mark-vars-in-regs (cdr (lambda-variables node))))
  173.     ((strategy/label)
  174.      (ass-comment "Label procedure ~s (lambda ~s ...)" 
  175.              (lambda-name node)
  176.              (map variable-unique-name (lambda-variables node)))
  177.      (cond ((join-point-contour-needed? (lambda-env node))
  178.             (let ((contour (join-point-contour (lambda-env node))))
  179.               (mark contour P)
  180.               (if (closure-cit-offset (environment-closure 
  181.                         (lambda-env (variable-binder contour))))
  182.                   (generate-move (reg-offset P -2) TP)))))
  183.      (walk (lambda (var arg-spec)
  184.              (mark var (car arg-spec)))
  185.           (if (continuation? node)
  186.               (lambda-variables node)
  187.               (cdr (lambda-variables node)))
  188.           (join-point-arg-specs (lambda-env node)))
  189.      (walk (lambda (pair)
  190.              (mark (cdr pair) (car pair)))
  191.            (join-point-global-registers (lambda-env node))))))
  192.  
  193.  
  194.  
  195. (define (mark-vars-in-regs vars)
  196.   (do ((vars vars (cdr vars))
  197.        (reg A1 (fx+ reg 1)))
  198.       ((or (fx>= reg AN) (null? vars))
  199.        (do ((vars vars (cdr vars))
  200.             (reg (fx+ reg (fx+ *argument-registers* 1)) (fx+ reg 1)))
  201.            ((null? vars))
  202.          (cond ((and (car vars) (variable-refs (car vars)))
  203.                 (mark-temp (car vars) reg)))))
  204.     (cond ((and (car vars) (variable-refs (car vars)))
  205.            (mark (car vars) reg)))))
  206.      
  207. ;;; A closure is n-ary if it has a non null rest arg.
  208.  
  209. (define n-ary? lambda-rest-var)
  210.  
  211. (define (n-ary-setup node)
  212.   (cond ((used? (lambda-rest-var node))
  213.          (generate-nary-setup node
  214.                               (if (eq? (lambda-strategy node) strategy/stack)
  215.                                   (length (lambda-variables node))
  216.                                   (length (cdr (lambda-variables node))))))))
  217.  
  218.  
  219.  
  220. (define (allocate-primop-call node)
  221.   (let* ((prim (primop-value (call-proc node))))
  222.     (cond ((primop.conditional? prim)
  223.            (allocate-conditional-primop node prim))
  224.           ((and (eq? prim primop/contents-location)
  225.                 (neq? (leaf-value ((call-arg 2) node)) primop/cell-value))
  226.            (allocate-location node prim))
  227.           ((primop.special? prim)
  228.            (primop.generate prim node))
  229.           (else           
  230.            (really-allocate-primop-call node prim)))))
  231.                                        
  232.  
  233. ;;; ALLOCATE-CONDITIONAL-PRIMOP When we come to a split we save the state of
  234. ;;; the world and traverse one arm, then restore the state and traverse the
  235. ;;; other.
  236.  
  237. (define (allocate-conditional-primop node prim)
  238.   (primop.generate prim node)      
  239.   (let ((then (then-cont node))
  240.         (else (else-cont node)))
  241.   (receive (then else) (cond ((or (leaf-node? then) 
  242.                                   (leaf-node? else) 
  243.                                   (fx< (lambda-trace then)
  244.                                        (lambda-trace else)))
  245.                               (return then else))
  246.                              (t
  247.                               (return else then)))
  248.     (bind ((*registers* (copy-registers))
  249.            (*stack-pos* *stack-pos*)
  250.            (*lambda* *lambda*)) 
  251.       (emit-tag then)  
  252.       (cond ((lambda-node? then)
  253.              (walk (lambda (n)
  254.                      (kill-if-dead n then))
  255.                    (cons else (cddr (call-args node))))
  256.              (allocate-call (lambda-body then)))
  257.             (t
  258.              (allocate-conditional-continuation node then)))
  259.       (return-registers))
  260.     (restore-slots)
  261.     (emit-tag else)  
  262.     (cond ((lambda-node? else)
  263.            (walk (lambda (n)
  264.                    (kill-if-dead n else))
  265.                  (cons then (cddr (call-args node))))
  266.            (allocate-call (lambda-body else)))
  267.           (t
  268.            (allocate-conditional-continuation node else))))))
  269.                                         
  270. ;; We must decide whether to try to delay dereferencing the location.
  271. ;; We do this if the value is used just once and in the next frob and
  272. ;; is an operand to a primop.
  273.  
  274.  
  275. (define (allocate-location node prim)
  276.   (let ((c (cont node)))
  277.     (if (and (lambda-node? c)
  278.              (let ((refs (variable-refs (car (lambda-variables c)))))
  279.                (and refs
  280.                     (null? (cdr refs))
  281.                     (let ((p (node-parent (node-parent (car refs)))))
  282.                       (or (and (eq? p c) 
  283.                                (let ((proc (call-proc (lambda-body c))))
  284.                                  (and (primop-node? proc)
  285.                                       (neq? (primop-value proc) 
  286.                                             primop/make-cell))))
  287.                           (and (eq? (node-parent (node-parent p)) c)     
  288.                                (let ((proc (call-proc (node-parent (car refs)))))
  289.                                  (and (primop-node? proc)
  290.                                       (neq? (primop-value proc)
  291.                                             primop/contents-location)))                                                        
  292.                                (let ((p (call-proc (lambda-body c))))
  293.                                  (and (primop-node? p)
  294.                                       (eq? (primop-value p) 
  295.                                            primop/contents-location))))))
  296.                     (reps-compatable? 
  297.                       (primop.rep-wants (leaf-value ((call-arg 2) node)))
  298.                       (variable-rep (car (lambda-variables c)))))))
  299.         (generate-location-access node)
  300.         (really-allocate-primop-call node prim))))
  301.  
  302.  
  303. (define (reps-compatable? accessor-rep use-rep)
  304.   (and (eq? (rep-size accessor-rep) (rep-size use-rep))
  305.        (not (rep-converter accessor-rep use-rep))))
  306.  
  307. (define (really-allocate-primop-call node prim)
  308.   (let ((c (cont node)))
  309.     (cond ((lambda-node? c)
  310.            (cond ((call-hoisted-cont node)
  311.                   => (lambda (cont)
  312.                        (walk (lambda (a-pair)
  313.                                (or (memq? (car a-pair) (lambda-live c))
  314.                                    (fx= (variable-number (car a-pair)) 0)
  315.                                    (any? (lambda (node)
  316.                                            (and (leaf-node? node)
  317.                                                 (eq? (leaf-value node) (car a-pair ))))
  318.                                          (cdr (call-args node)))
  319.                                    (kill (car a-pair))))
  320.                              (closure-env (environment-closure (lambda-env cont)))))) )
  321.            (primop.generate prim node)
  322.            (walk (lambda (node)
  323.                    (kill-if-dead node c))
  324.                  (cdr (call-args node)))
  325.            (allocate-call (lambda-body c)))
  326.           (else                            
  327.            (primop.generate prim node)
  328.            (walk (lambda (node)
  329.                    (if (leaf-node? node) (kill (leaf-value node))))
  330.                  (cdr (call-args node)))
  331.            (restore-continuation node c)
  332.            (clear-slots)
  333.            (let ((j (variable-known (leaf-value c))))
  334.              (if (and j (not (n-ary? j))) 
  335.                  (generate-jump j)
  336.                  (generate-return (primop.values-returned prim))))))))
  337.  
  338. (define (access/make-closure node lam)
  339.   (let* ((closure (environment-closure (lambda-env lam))))
  340.     (cond ((eq? closure *unit*)
  341.            (lambda-queue lam)
  342.            (lookup node lam nil))
  343.           (else
  344.            (make-heap-closure node closure)
  345.            nil))))
  346.  
  347.  
  348. (define-local-syntax (dotimes spec . body)
  349.   (let ((index (car spec))
  350.         (limit (cadr spec)))
  351.     `(do ((,index 0 (fx+ ,index 1)))
  352.          ((fx= ,index ,limit))
  353.        ,@body)))
  354.  
  355.  
  356. ;;; MAKE-STACK-CLOSURE Push a continuation on the stack.  For now there are no
  357. ;;; scratch values.  When there are we will need to push zeroes for all the
  358. ;;; scratch slots and fill them in after pushing the template.  This is because
  359. ;;; the GC assumes that anything on top of the stack until the first template
  360. ;;; is a valid pointer.
  361.  
  362. (define (make-stack-closure node cont)
  363.   (let* ((closure (environment-closure (lambda-env cont)))
  364.          (members (closure-members closure))
  365.          (a-list (cdr (closure-env closure))))
  366.     (walk (lambda (x)
  367.             (lambda-queue (variable-binder x)))
  368.           members)
  369.     (do ((i (closure-scratch closure) (fx- i 1)))
  370.         ((fx<= i 0))
  371.       (generate-push (machine-num 0)))
  372.     (walk (lambda (pair)                                          
  373.             (let ((var (car pair)))
  374.               (if (memq? var members)
  375.                   (generate-push-address (template (variable-binder var)))
  376.                   (generate-push (access-value node var)))))
  377.           (reverse! (sublist a-list 0 (closure-pointer closure))))
  378.     (generate-push-address (template cont))
  379.     (walk (lambda (pair)
  380.             (really-rep-convert node
  381.                                 (access-value node (car pair))
  382.                                 (variable-rep (car pair))
  383.                                 (reg-offset SP (cdr pair))
  384.                                 (variable-rep (car pair))))
  385.           (nthcdr a-list (closure-pointer closure)))))
  386.                                                             
  387.  
  388. (define (make-vframe-closure node l closure)
  389.   (walk lambda-queue (closure-vframe-lambdas closure))
  390.   (let ((a-list (cdr (closure-env closure))))
  391.     (do ((i (closure-scratch closure) (fx- i 1)))
  392.         ((fx<= i 0))
  393.       (generate-push (machine-num 0)))
  394.     (walk (lambda (pair)
  395.             (generate-push (access-value node (car pair))))
  396.           (reverse! (sublist a-list 0 (closure-pointer closure))))
  397.     (let ((closure (environment-closure (lambda-env l))))
  398.       (generate-push (machine-num (vframe-header (closure-pointer closure)
  399.                                                  (closure-scratch closure)))))
  400.     (walk (lambda (pair)
  401.             (really-rep-convert node
  402.                                 (access-value node (car pair))
  403.                                 (variable-rep (car pair))
  404.                                 (reg-offset SP (cdr pair))
  405.                                 (variable-rep (car pair))))
  406.           (nthcdr a-list (closure-pointer closure)))))
  407.                                                             
  408.   
  409. (define (vframe-header p s)
  410.   (+ (fixnum-ashl p 16) (fixnum-ashl s 8) header/vframe))
  411.  
  412.