home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / strategy.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  11.7 KB  |  298 lines
  1. (herald (back_end strategy)
  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. (define (variable-known var)
  28.   (if (not (variable? var))
  29.       nil
  30.       (let ((type (variable-type var)))
  31.         (cond ((and (node? type) (lambda-node? type))
  32.                type)
  33.               (else nil)))))
  34.  
  35. (define (variable-y-lambda var)
  36.   (node-parent (node-parent (variable-binder var))))
  37.  
  38. (define (object-lambda? node)
  39.   (and (lambda-node? node)
  40.        (primop-ref? (call-proc (lambda-body node)) primop/proc+handler)))
  41.  
  42. (define (let-lambda? l)
  43.   (lambda-node? (call-proc (node-parent l))))
  44.  
  45. (define (call-in-body? proc node)
  46.   (fx> (lambda-trace proc) (lambda-trace (node-parent node))))
  47.  
  48. (define-local-syntax (define-lambda-strategies . strategies)
  49.   `(block ,@(map! (lambda (strat)      
  50.                     (let ((strat (concatenate-symbol 'strategy/ strat)))
  51.                       `(define-constant ,strat ',strat)))
  52.                    strategies)))
  53.  
  54.  
  55. (define-lambda-strategies open label ezclose vframe stack heap hack)
  56.  
  57. (define (set-lambda-strategy! node)
  58.   (cond ((lambda-strategy node))
  59.         (else                
  60.          (set (lambda-strategy node)
  61.               (let* ((parent (node-parent node))
  62.                      (proc   (call-proc parent)))
  63.                 (cond ((or (and (fx<= 2 (call-exits parent))
  64.                                 (call-exit? node))
  65.                            (and (call-exit? node)
  66.                                 (primop-node? proc)))
  67.                        strategy/open)
  68.                       ((call-exit? node)
  69.                        strategy/stack)
  70.                       ((cons-on-stack? proc (call-arg-number (node-role node)))
  71.                        strategy/hack)
  72.                       (else
  73.                        strategy/heap)))))))
  74.  
  75. (define (cons-on-stack? proc number) '#f)
  76.    
  77. (define db cons)
  78. (define (lambda-depth lam) (car (lambda-db lam)))
  79. (define (lambda-trace lam) (cdr (lambda-db lam)))
  80.  
  81. (define (analyze-top node)
  82.   (analyze-lambda ((call-arg 1) (lambda-body node)) 0 0))
  83.                                    
  84. (define (analyze-lambda node depth -trace)
  85.   (set (lambda-db node) (db depth -trace))
  86.   (set-lambda-strategy! node)
  87.   (let ((tr (analyze-body (lambda-body node) depth -trace)))
  88.     (walk sort-by-db (if (continuation? node)
  89.                          (lambda-variables node)
  90.                          (cdr (lambda-variables node))))
  91.     (fx+ tr 1)))
  92.  
  93.                              
  94. (define (analyze-body node depth -trace)
  95.   (let ((proc (call-proc node)))
  96.     (cond ((primop-node? proc)
  97.            (select (primop-value proc) 
  98.              ((primop/conditional)
  99.               (analyze-if node depth -trace))
  100.              ((primop/Y) 
  101.               (analyze-Y ((call-arg 1) node) ((call-arg 2) node) depth -trace))                
  102.              ((primop/undefined-effect) -trace)
  103.              (else
  104.               (really-analyze-body (call-args node) depth -trace))))
  105.           ((lambda-node? proc)
  106.            (analyze-let node depth -trace))   
  107.           (else  
  108.            (really-analyze-body (call-args node) depth -trace)))))
  109.  
  110.  
  111. (define (really-analyze-body args depth -trace)
  112.   (iterate loop ((-trace -trace) (args args))
  113.     (cond ((null? args) -trace)
  114.           ((lambda-node? (car args))             
  115.            (loop (analyze-lambda (car args) (fx+ depth 1) -trace) 
  116.                  (cdr args)))
  117.           (else
  118.            (loop -trace (cdr args))))))
  119.  
  120.  
  121. (define (analyze-if node depth -trace)
  122.   (receive (trac other) (determine-if-trace ((call-arg 1) node) ((call-arg 2) node))
  123.     (let ((-trace (if (lambda-node? trac)
  124.                        (analyze-lambda trac (fx+ depth 1) -trace)
  125.                        -trace)))
  126.       (if (lambda-node? other)
  127.           (analyze-lambda other (fx+ depth 1) -trace)
  128.           -trace))))
  129.                                       
  130.  
  131. (define (determine-if-trace th el)
  132.   (cond ((leaf-node? th)
  133.          (return el th))
  134.         ((leaf-node? el)
  135.          (return th el))
  136.         (else
  137.          (let ((th-body (lambda-body th))
  138.                (el-body (lambda-body el)))
  139.            (cond ((fx= (call-exits th-body) 0)
  140.                   (if (and (leaf-node? (call-proc th-body))
  141.                            (variable-known (leaf-value (call-proc th-body))))
  142.                       (return th el)
  143.                       (return el th)))
  144.                  ((fx= (call-exits el-body) 0)
  145.                   (if (and (leaf-node? (call-proc el-body))
  146.                            (variable-known (leaf-value (call-proc el-body))))
  147.                       (return el th)
  148.                       (return th el)))
  149.                  ((primop-node? (call-proc th-body))
  150.                   (return th el))
  151.                  (else 
  152.                   (return el th)))))))
  153.              
  154.  
  155. (define (analyze-let let-node depth -trace)
  156.   (if (lambda-rest-var (call-proc let-node)) 
  157.       (bug "nary-let not implemented yet"))
  158.   (let ((lambdas (call-proc+args let-node)))
  159.     (set (lambda-strategy (car lambdas)) strategy/open)
  160.     (walk set-let-strategy!
  161.           (lambda-variables (car lambdas))
  162.           (cdr lambdas))            
  163.     (analyze-lambda (car lambdas) (fx+ depth 1) -trace)
  164.     (let ((lambdas (filter lambda-node? (cdr lambdas))))
  165.       (cond ((null? lambdas) (fx+ -trace 1))
  166.             ((and (null? (cdr lambdas))
  167.                   (continuation? (car lambdas)))
  168.              (let ((tr (analyze-lambda (car lambdas) (fx+ depth 1) (fx+ -trace 1))))
  169.                (if (stack-below? (car lambdas))
  170.                    (set (lambda-strategy (car lambdas)) strategy/stack))
  171.                tr))
  172.             (else                  
  173.              (really-analyze-body lambdas (fx+ depth 1) (fx+ -trace 1)))))))
  174.  
  175. (define (set-let-strategy! var arg)
  176.   (cond ((and var (lambda-node? arg))
  177.          (set (variable-type var) arg)
  178.          (set (lambda-strategy arg)
  179.               (cond ((and (all-refs-are-calls? var) 
  180.                           (not (and (lambda-rest-var arg)
  181.                                     (used? (lambda-rest-var arg)))))
  182.                      strategy/label)
  183.                     ((continuation? arg)       
  184.                      strategy/stack)
  185.                     (else 
  186.                      strategy/heap))))))
  187.        
  188.  
  189. (define (analyze-Y cont master depth -trace)
  190.   (let* ((lambdas (call-args (lambda-body master)))
  191.          (strategy (get-labels-strategy master)))
  192.     (walk (lambda (var l) 
  193.             (set (lambda-strategy l) strategy)
  194.             (if var (set (variable-type var) l)))
  195.           (cdr (lambda-variables master))
  196.           (cdr lambdas))                                  
  197.     (set (lambda-strategy master) strategy)
  198.     (set (lambda-strategy (car lambdas)) strategy/open)
  199.     (let ((tr (cond ((lambda-node? cont)
  200.                      (set (lambda-strategy cont) strategy/stack)
  201.                      (analyze-lambda cont (fx+ depth 1) -trace))
  202.                     (else
  203.                      -trace))))
  204.       (really-analyze-body lambdas (fx+ depth 1) tr))))
  205.           
  206.  
  207. (define (get-labels-strategy master)
  208.   (cond ((or (not (every? all-refs-are-calls? (cdr (lambda-variables master))))
  209.              (any? lambda-rest-var (call-args (lambda-body master))))
  210.          strategy/heap)
  211.         ((and (need-to-pop-stack? (node-parent master))
  212.               (not (constant-continuation? master)))
  213.          strategy/vframe)
  214.         (else
  215.          strategy/label)))
  216.  
  217. (define (vframe-allowed? l)
  218.   (eq? (lambda-db (node-parent (node-parent l))) 'vframe))
  219.                                                              
  220. (define (vframe-or-ezclose master)
  221.   (cond ((constant-continuation? master)
  222.          'ezclose)
  223.         ((vframe-possible? master) 
  224.          'vframe)
  225.         (else 'label)))
  226.  
  227. (define (ezclose-allowed? l)
  228.   (eq? (lambda-db (node-parent (node-parent l))) 'ezclose))
  229.  
  230. (define (sort-by-db var)
  231.  (if var
  232.   (set (variable-refs var)
  233.        (sort-list! (variable-refs var)
  234.               (lambda (ref1 ref2)
  235.                 (let ((l1 (node-parent (node-parent ref1)))
  236.                       (l2 (node-parent (node-parent ref2))))
  237.                   (cond ((fx< (lambda-trace l1) (lambda-trace l2)) t)
  238.                         ((fx> (lambda-trace l1) (lambda-trace l2)) nil)
  239.                         (else
  240.                          (fx<= (lambda-depth l1) (lambda-depth l2))))))))))
  241.               
  242.                  
  243. (define (stack-below? node)
  244.   (if (eq? (node-role (node-parent (node-parent node))) call-proc)
  245.       '#f
  246.       (let ((body (lambda-body node)))
  247.         (select (call-exits body)
  248.           ((0) nil)
  249.           ((1) (let ((exit (car (call-args body))))
  250.                  (xcond ((lambda-node? (call-proc body))
  251.                          (stack-below? (call-proc body)))
  252.                         ((leaf-node? exit) nil)
  253.                         ((eq? (lambda-strategy exit) strategy/stack) t)
  254.                         ((eq? (lambda-strategy exit) strategy/open)
  255.                          (stack-below? exit)))))
  256.           ((2) (let ((exit1 ((call-arg 1) body))
  257.                      (exit2 ((call-arg 2) body)))
  258.                  (and (and (lambda-node? exit1) (stack-below? exit1))
  259.                      (and (lambda-node? exit2) (stack-below? exit2)))))))))
  260.  
  261. (define (constant-continuation? node)
  262.   (every? (lambda (var)
  263.             (every? (lambda (ref)
  264.                       (let ((cont ((call-arg 1) (node-parent ref))))
  265.                         (and (leaf-node? cont) 
  266.                              (labels-lambda? 
  267.                               (variable-binder (leaf-value cont))))))
  268.                     (variable-refs var)))
  269.           (cdr (lambda-variables node))))
  270.           
  271. (define (vframe-possible? master)
  272.   (every? (lambda (l)
  273.             (every? (lambda (ref)
  274.                       (or (eq? (node-role ref) call-proc)
  275.                           (let ((proc (call-proc (node-parent ref))))
  276.                             (or (primop-node? proc)
  277.                                 (vframe-call-ok? (reference-variable proc) master)))))
  278.                     (variable-refs (lambda-cont-var l))))
  279.           (cdr (call-args (lambda-body master)))))
  280.                 
  281. (define (vframe-call-ok? var master) 
  282.   (cond ((not (variable-binder var)) '#t)
  283.         ((variable-known var)
  284.          => (lambda (l)
  285.               (eq? (node-parent (node-parent l)) master)))
  286.         (else '#t)))
  287.  
  288.  
  289.  
  290. (define (labels-lambda? node)
  291.   (labels-master-lambda? (node-parent (node-parent node))))
  292.  
  293. (define (labels-master-lambda? node)
  294.   (and (eq? (node-role node) (call-arg 2))
  295.        (primop-ref? (call-proc (node-parent node)) primop/y)))
  296.  
  297.  
  298.