home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / generate.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  8.9 KB  |  222 lines
  1. (herald (back_end generate)
  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-let node)
  30.   (destructure (((body . exprs) (call-proc+args node)))
  31.     (iterate loop ((exprs exprs) (vars '()) (lambdas '()) (stack nil))
  32.       (cond ((null? exprs)
  33.              (really-generate-let node body vars lambdas stack))
  34.             ((not (lambda-node? (car exprs)))
  35.              (loop (cdr exprs) (cons (car exprs) vars) lambdas stack))
  36.             ((eq? (lambda-strategy (car exprs)) strategy/label)
  37.              (loop (cdr exprs) vars lambdas stack))
  38.             ((eq? (lambda-strategy (car exprs)) strategy/stack)
  39.              (loop (cdr exprs) vars lambdas (car exprs)))
  40.             (else
  41.              (loop (cdr exprs) vars (cons (car exprs) lambdas) stack))))
  42.     (allocate-call (lambda-body body))))
  43.  
  44.                        
  45. ;; ************** the variables of leaves MUST BE FREE. They should have been
  46. ;; substituted.  Otherwise there would be aliasing.
  47.  
  48. (define (really-generate-let node body leaves closures stack)  
  49.   (let ((bind-leaf 
  50.           (lambda (leaf) 
  51.             (if (variable-binder (leaf-value leaf))
  52.                 (bug "lexical variable being bound by LET ~s" (leaf-value leaf)))
  53.             (let* ((var (nth (lambda-variables body)
  54.                                  (fx- (call-arg-number (node-role leaf)) 1)))
  55.                    (acc (access-value node (leaf-value leaf)))
  56.                    (reg (get-register (if (eq? (variable-rep var) 'rep/pointer)
  57.                                           'pointer 'scratch)
  58.                                       node '*)))
  59.               (really-rep-convert node acc 'rep/pointer reg (variable-rep var))
  60.               (set (register-loc (leaf-value leaf)) nil)
  61.               (mark var reg)))))                            
  62.     (cond (stack
  63.            (set (lambda-strategy body) strategy/stack)
  64.            (set (lambda-env body) (lambda-env stack))))
  65.     (cond ((not closures) 
  66.            (walk bind-leaf leaves))
  67.           (else
  68.            (cond ((get-member closures)
  69.                   => (lambda (member)
  70.            (let ((closure (environment-closure (lambda-env member))))
  71.              (make-heap-closure node closure)
  72.              (lock AN)
  73.              (walk (lambda (var)
  74.                      (let ((reg (get-register 'pointer node '*))
  75.                            (offset (cdr (assq var (closure-env closure)))))
  76.                        (generate-move-address (reg-offset AN offset) reg)
  77.                        (mark var reg)))
  78.                    (cdr (closure-members closure)))
  79.              (unlock AN)
  80.              (mark (car (closure-members closure)) AN)))))
  81.        (walk bind-leaf leaves)
  82.        (walk (lambda (closure)
  83.                    (lambda-queue closure)
  84.                    (mark (lambda-self-var closure) 
  85.                          (->register 'pointer node closure '*)))
  86.                  (filter (lambda (l)
  87.                            (eq? (environment-closure (lambda-env l)) 
  88.                                 *unit*))
  89.                          closures))))))
  90.  
  91. (define (get-member closures)
  92.   (iterate loop ((closures closures))
  93.     (cond ((null? closures) nil)     
  94.           ((neq? (environment-closure (lambda-env (car closures)))
  95.                  *unit*)
  96.            (car closures))
  97.           (else (loop (cdr closures))))))
  98.  
  99.  
  100.                                     
  101.  
  102.  
  103. ;;; RESULT-WANT-LOC Determines where to target the result of a primop.
  104. ;;; If the continuation is a variable, it is a return of one argument in
  105. ;;; A1.  Otherwise we look at the most important use (now done non-optimally)
  106. ;;; and see where is is needed.  If it is the argument to a primop we look
  107. ;;; at the arg-specs of that primop, otherwise it is in a position for the
  108. ;;; standard calling sequence.
  109.  
  110. (define-operation (foreign-name foreign) nil)
  111.  
  112. (define (continuation-wants cont)
  113.   (cond ((lambda-node? cont)
  114.          (cond ((n-ary? cont) (return '* 'rep/pointer))
  115.                (else
  116.                 (let ((var (car (lambda-variables cont))))
  117.                   (return (likely-next-reg var cont)
  118.                           (variable-rep var))))))
  119.         (else 
  120.          (return A1 'rep/pointer))))
  121.  
  122. (define (likely-next-reg var cont)
  123.   (let ((spec (really-likely-next-reg var cont)))
  124.     (cond ((fixnum? spec)
  125.            (if (eq? (reg-type spec) 'pointer)
  126.                (if (eq? (variable-rep var) 'rep/pointer) spec 'scratch)
  127.                (if (neq? (variable-rep var) 'rep/pointer) spec 'pointer)))
  128.           (else spec))))
  129.  
  130.  
  131. (define (really-likely-next-reg var cont)
  132.   (let ((refs (mem (lambda (x ref) 
  133.                      (fx= (lambda-trace (node-parent (node-parent ref))) x))
  134.                    (lambda-trace cont)
  135.                    (variable-refs var))))
  136.     (iterate loop ((refs refs))
  137.       (if (null? refs)
  138.           (variable-register-type var)
  139.           (let* ((parent (node-parent (car refs)))
  140.                  (proc (call-proc parent))
  141.                  (number (call-arg-number (node-role (car refs)))))
  142.             (cond ((primop-node? proc)
  143.                    (cond ((primop.arg-specs (primop-value proc))
  144.                           => (lambda (specs)
  145.                    (let ((spec (nth specs (fx- (fx- number
  146.                                   (call-exits parent))
  147.                                   1))))
  148.                  (if (eq? spec '*)
  149.                      (loop (cdr refs))
  150.                      spec))))
  151.                          (else
  152.                           (loop (cdr refs)))))
  153.                   ((variable-known (leaf-value proc))
  154.                    => (lambda (label)
  155.                         (cond ((neq? (lambda-strategy label) strategy/label)
  156.                                (fx- (fx+ number *scratch-registers*)
  157.                                     (call-exits parent)))
  158.                               ((join-point-arg-specs (lambda-env label))
  159.                                => (lambda (args)
  160.                                     (car (nth args
  161.                                       (fx- (fx- number (call-exits parent)) 1)))))
  162.                               (else (loop '())))))
  163.                   (else
  164.                    (fx- (fx+ number *scratch-registers*)
  165.                         (call-exits parent)))))))))
  166.  
  167.  
  168.  
  169.  
  170. ;;; locatives
  171.                                 
  172.  
  173. (define (generate-locative node)
  174.   (receive (t-spec t-rep) (continuation-wants ((call-arg 1) node))
  175.     (let* ((dest (get-target-register node t-spec))
  176.            (acc (lookup node (get-lvalue (leaf-value ((call-arg 2) node))) nil)))
  177.       (free-register node dest)
  178.       (generate-move acc dest)
  179.       (mark-continuation node dest))))
  180.  
  181.  
  182. (define (get-lvalue var)
  183.   (cond ((ass (lambda (x y)
  184.                 (and (loc-list? y)
  185.                      (eq? x (loc-list-var y))))
  186.               var
  187.               (closure-env *unit*))
  188.          => car)
  189.         (else
  190.          (bug "couldn't find lvalue ~s" var))))
  191.  
  192.  
  193. (define (mark-continuation node reg)
  194.   (let ((cont (car (call-args node))))
  195.     (if (lambda-node? cont)
  196.         (if (not (n-ary? cont))
  197.             (mark (car (lambda-variables cont)) reg))
  198.         (generate-move reg A1))))
  199.  
  200. ;;; Data manipulation
  201. ;;; ---------------------------------------------------------------------
  202.  
  203.  
  204. (define (generate-define-var node)
  205.   (let* ((value ((call-arg 3) node)))
  206.     (cond ((and (lambda-node? value) 
  207.              (not (eq? (primop.definition-variant (leaf-value (call-proc node)))
  208.                        'lset))
  209.              (eq? (environment-closure (lambda-env value)) *unit*))
  210.            (lambda-queue value))
  211.           ((primop-node? value))
  212.           (else
  213.            (generate-set node ((call-arg 2) node) value)))))
  214.  
  215.  
  216.  
  217.     
  218.                                                            
  219.  
  220.  
  221.  
  222.