home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / loop.t < prev    next >
Encoding:
Text File  |  1989-10-27  |  10.1 KB  |  283 lines
  1. (herald fix1)
  2.  
  3. (define (analyze-Y cont master depth -trace)
  4.   (let* ((lambdas (call-args (lambda-body master)))
  5.          (strategy (get-labels-strategy master)))
  6.     (walk (lambda (var l) 
  7.             (set (lambda-strategy l) strategy)
  8.             (if var (set (variable-type var) l)))
  9.           (cdr (lambda-variables master))
  10.           (cdr lambdas))                                  
  11.     (set (lambda-strategy master) strategy)
  12.     (set (lambda-strategy (car lambdas)) strategy/open)
  13.     (let ((tr (cond ((not (lambda-node? cont)) -trace)
  14.                     ((and (eq? strategy strategy/label)
  15.               (constant-continuation? master)
  16.               (check-continuation-refs lambdas
  17.                            (lambda-variables master)))
  18.                      (set (lambda-strategy cont) strategy/label)
  19.                      (walk (lambda (l)
  20.                              (set (variable-type (lambda-cont-var l)) cont))
  21.                            (cdr lambdas))
  22.                      (analyze-lambda cont (fx+ depth 1) -trace))
  23.             (else
  24.                      (set (lambda-strategy cont) strategy/stack)
  25.                      (analyze-lambda cont (fx+ depth 1) -trace)))))
  26.       (really-analyze-body lambdas (fx+ depth 1) tr))))
  27.  
  28. (define (check-continuation-refs l vars)
  29.   (every? (lambda (l)
  30.         (every? (lambda (ref)
  31.               (or (eq? (node-role ref) call-proc)
  32.               (let ((proc (call-proc (node-parent ref))))
  33.                 (memq? (reference-variable proc) vars))))
  34.             (variable-refs (lambda-cont-var l))))
  35.       l))
  36.  
  37. (define (live-analyze-leaf node)
  38.   (cond ((literal-node? node)
  39.          (cond ((or (addressable? (leaf-value node))
  40.                     (primop? (leaf-value node)))
  41.                 (return '() nil '()))
  42.                (else
  43.                 (return '() t '()))))
  44.         ((primop-node? node)
  45.          (cond ((foreign-name (primop-value node))
  46.                 (return '() t '()))
  47.                (else 
  48.                 (return '() nil '()))))
  49.         ((variable-known (reference-variable node))
  50.          => (lambda (label)
  51.               (select (lambda-strategy label)
  52.                 ((strategy/label)
  53.                  (return (lambda-live label)
  54.                          (eq? (lambda-env label) 'needs-link)
  55.                          (if (labels-lambda? label) 
  56.                              (list label)  
  57.                              '())))
  58.                 ((strategy/stack)
  59.                  (return '() nil '()))
  60.                 (else 
  61.                  (if (eq? (lambda-env label) 'unit-internal-closure)
  62.                      (return '() t '())
  63.                      (return `(,(lambda-self-var label)) nil '()))))))
  64.         ((bound-to-continuation? (reference-variable node))
  65.          (return '() nil '()))
  66.         ((variable-binder (reference-variable node))
  67.          (return `(,(reference-variable node)) nil '()))
  68.         (else 
  69.          (return '() t '()))))
  70.  
  71. (define (sort-by-difficulty args pos-list)
  72.   (iterate loop ((args args) (do-now '()) (trivial '()) (do-later '())
  73.                  (pos-list pos-list))
  74.     (cond ((null? args)
  75.            (return do-now trivial do-later))
  76.           ((lambda-node? (car args)) 
  77.            (let ((l (car args)))
  78.              (cond ((eq? (environment-closure (lambda-env l)) *unit*)
  79.                     (loop (cdr args)
  80.                           do-now
  81.                           trivial
  82.                           (cons (cons l (car pos-list)) do-later)
  83.                           (cdr pos-list)))
  84.                    (else
  85.                     (loop (cdr args)
  86.                           do-now
  87.                           (cons (cons l (car pos-list)) trivial)
  88.                           do-later
  89.                           (cdr pos-list))))))
  90.           ((addressable? (leaf-value (car args)))
  91.            (loop (cdr args)
  92.                  do-now
  93.                  (cons (cons (car args) (car pos-list)) trivial)
  94.                  do-later
  95.                  (cdr pos-list)))
  96.           (else
  97.            (let* ((val (leaf-value (car args)))
  98.                   (value (cond ((and (variable? val) (variable-known val))
  99.                                => lambda-self-var)
  100.                               (else val))))
  101.              (cond ((let ((reg (register-loc value))
  102.                   (temp (temp-loc value)))
  103.                  (if (and reg temp (eq? temp (car pos-list)))
  104.                  temp
  105.               (or reg temp)))   
  106.                     => (lambda (reg)
  107.                          (loop (cdr args)
  108.                                (cons (mover reg (car pos-list))
  109.                                      do-now)
  110.                                trivial
  111.                                do-later
  112.                                (cdr pos-list))))
  113.                    (else
  114.                     (loop (cdr args)
  115.                           do-now
  116.                           trivial
  117.                           (if (fx= (car pos-list) P)
  118.                               (append! do-later (list (cons value (car pos-list))))
  119.                               (cons (cons value (car pos-list)) do-later))
  120.                           (cdr pos-list)))))))))
  121.  
  122.  
  123.  
  124.                           
  125. (define (live-analyze-lambda node)
  126.   (receive (live global? known) (live-analyze-body (lambda-body node))
  127.    (let* ((live-1 (set-difference live (lambda-all-variables node)))
  128.            (live (if (neq? (node-role node) call-proc)  ;; Let
  129.                      live-1       
  130.                      (set-difference live-1 (map (lambda (node) 
  131.                                             (and (lambda-node? node)
  132.                                                  (lambda-self-var node)))
  133.                                           (call-args (node-parent node)))))))
  134.     (set (lambda-live node) live)
  135.     (select (lambda-strategy node)
  136.       ((strategy/heap)    
  137.        (walk change-to-heap known)
  138.        (cond ((and (null? live) (not (known-lambda? node)))
  139.               (set (lambda-env node) 'unit-internal-closure)
  140.               (return live t known))
  141.              (global? 
  142.               (set (lambda-env node) 'unit-internal-template)
  143.               (return live t known))
  144.              (else
  145.               (set (lambda-env node) nil)
  146.               (return live nil known))))
  147.       ((strategy/label)                
  148.        (cond ((fully-recursive? node)
  149.           (walk change-to-vframe-or-heap 
  150.             (if (memq? node known) known (cons node known)))))
  151.        (set (lambda-env node) (if global? 'needs-link '#f))
  152.        (return live global? known))
  153.       ((strategy/stack)           
  154.        (set (lambda-env node) (if global? 'needs-link '#f))
  155.        (walk (lambda (l)
  156.            (if (fully-recursive? l)
  157.            (change-to-heap l)))
  158.          known)
  159.        (return live global? known))
  160.       (else
  161.        (return live global? known))))))
  162.  
  163.  
  164. (define (create-join-point env contour needed? lamb)
  165.   (let ((j (make-join-point)))
  166.     (set (join-point-env j) env)
  167.     (set (join-point-arg-specs j) nil)
  168.     (set (join-point-global-registers j) 'not-yet-determined)
  169.     (set (join-point-contour-needed? j) needed?)
  170.     (set (join-point-contour j) contour)
  171.     (set (join-point-call-below? j) 
  172.      (if (continuation? lamb)
  173. nil;         (fx= (call-below? (lambda-body lamb)) call-below/definitely)
  174.          (fx>= (call-below? (lambda-body lamb)) call-below/maybe)))
  175.     j))
  176.  
  177. (define (analyze top-node)
  178.   (analyze-top top-node)
  179.   (live-analyze-top top-node)
  180.   (collect-top top-node)
  181.   (call-analyze-top top-node)
  182.   (bind ((*noise-flag* t))
  183.     (print-variable-info *unit-variables*))
  184. ;  (type-analyze-top top-node)
  185. ;  (rep-analyze-top top-node)
  186.   (hoist-continuations (lambda-body top-node))
  187.   (close-analyze-top top-node nil))
  188.  
  189. (define-constant call-below? node-instructions)
  190. (define-constant call-below/never 0)
  191. (define-constant call-below/maybe 1)
  192. (define-constant call-below/definitely 2)
  193.  
  194.  
  195. (define (call-analyze-top node)
  196.   (call-analyze (lambda-body node)))
  197.  
  198.  
  199.  
  200. (define (call-analyze-leaf node)
  201.   (cond ((lambda-node? node)
  202.      (let ((call-below? (call-analyze (lambda-body node))))
  203.        (select (lambda-strategy node)
  204.          ((strategy/stack) call-below/definitely)
  205.          ((strategy/heap) call-below/never)
  206.          (else call-below?))))
  207.     (else
  208.      call-below/never)))
  209.  
  210. (define (call-analyze node) 
  211.   (let ((below?
  212.        (case (call-exits node)
  213.      ((0)
  214.       (cond ((lambda-node? (call-proc node))
  215.          (call-analyze-let node))
  216.         (else
  217.          (walk call-analyze-leaf (call-args node))
  218.          (call-analyze-known (call-proc node)))))
  219.      ((1)
  220.       (cond ((primop-ref? (call-proc node) primop/y)
  221.          (destructure (((cont master) (call-args node)))
  222.                    (call-analyze-leaf cont)
  223.            (destructure (((body-expr . label-exprs) 
  224.                   (call-args (lambda-body master))))
  225.              (let ((v (call-analyze-leaf body-expr)))
  226.                (cond ((or (and (lambda-node? cont)
  227.                        (eq? (lambda-strategy cont)
  228.                         strategy/stack))
  229.                   (fx= v call-below/definitely))
  230.                   (walk call-analyze-leaf label-exprs)
  231.                   call-below/definitely)
  232.                  (else
  233.                   (do ((l label-exprs (cdr l))
  234.                    (val v (call-below-combine 
  235.                        val
  236.                        (call-analyze-leaf (car l)))))
  237.                   ((null? l) val))))))))
  238.         ((lambda-node? (call-proc node))
  239.          (call-analyze-let node))
  240.         (else
  241.          (destructure (((exit . rest) (call-args node)))
  242.                    (walk call-analyze-leaf rest)
  243.            (cond ((lambda-node? exit)
  244.               (call-analyze-leaf exit))
  245.              (else
  246.               (call-analyze-known (call-proc node))))))))
  247.      (else
  248.       (destructure (((th el . rest) (call-args node)))
  249.         (walk call-analyze-leaf rest)
  250.         (call-below-combine (call-analyze-leaf th) (call-analyze-leaf el)))))))
  251.     (set (call-below? node) below?)
  252.     below?))
  253.  
  254. (define (call-analyze-let node)
  255.   (iterate loop ((args (call-args node))
  256.          (val call-below/never))
  257.     (cond ((null? args) 
  258.        (let ((body-val (call-analyze-leaf (call-proc node))))
  259.          (cond ((fx= body-val call-below/definitely)
  260.             body-val)
  261.            (else 
  262.             (call-below-combine val body-val)))))
  263.       ((lambda-node? (car args))
  264.        (loop (cdr args)
  265.          (call-below-combine 
  266.           val 
  267.           (call-analyze-leaf (car args)))))
  268.       (else
  269.        (loop (cdr args) val)))))
  270.  
  271. (define (call-analyze-known proc)
  272.     (cond ((and (reference-node? proc)
  273.         (variable-known (reference-variable proc)))
  274.        => (lambda (l) 
  275.         (let ((cb (call-below? (lambda-body l))))
  276.           (if (fixnum? cb) cb call-below/never))))
  277.       (else call-below/never)))
  278.  
  279.  
  280. (let ((vec '#(#(0 1 1) #(1 1 1) #(1 1 2))))
  281.   (define (call-below-combine x y)
  282.     (vref (vref vec x) y)))
  283.