since no register is used in more than one procedure.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.39 1987/07/08 22:00:41 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.40 1987/08/04 06:58:01 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define *block-start-label*)
-(define *code-object-label*)
-(define *code-object-entry*)
+(define *entry-rnode*)
(define *current-rnode*)
(define *dead-registers*)
(define *continuation-queue*)
-(define (generate-bits quotations procedures continuations receiver)
+(define (generate-bits rgraphs receiver)
(with-new-node-marks
(lambda ()
(fluid-let ((*next-constant* 0)
(*interned-constants* '())
(*interned-variables* '())
(*interned-uuo-links* '())
- (*block-start-label* (generate-label))
- (*code-object-label*)
- (*code-object-entry*)
- (*continuation-queue* (make-queue)))
- (for-each (lambda (quotation)
- (cgen-entry quotation quotation-rtl-entry))
- quotations)
- (for-each (lambda (procedure)
- (cgen-entry procedure procedure-rtl-entry))
- procedures)
- (queue-map! *continuation-queue*
- (lambda (continuation)
- (cgen-entry continuation continuation-rtl-entry)))
- (for-each (lambda (continuation)
- (if (not (continuation-frame-pointer-offset continuation))
- (error "GENERATE-LAP: Continuation not processed"
- continuation)))
- *continuations*)
+ (*block-start-label* (generate-label)))
+ (for-each cgen-rgraph rgraphs)
(receiver *block-start-label*
(generate/quotation-header *block-start-label*
*interned-constants*
*interned-variables*
*interned-uuo-links*))))))
-(define (cgen-entry object extract-entry)
- (set! *code-object-label* (code-object-label-initialize object))
- (let ((rnode (extract-entry object)))
- (set! *code-object-entry* rnode)
- (cgen-rnode rnode)))
+(define (cgen-rgraph rgraph)
+ (fluid-let ((*current-rgraph* rgraph)
+ (*continuation-queue* (make-queue)))
+ (cgen-entry (rgraph-edge rgraph))
+ (queue-map! *continuation-queue*
+ (lambda (continuation)
+ (cgen-entry (continuation-rtl-edge continuation))))))
+
+(define (cgen-entry edge)
+ (let ((rnode (edge-right-node edge)))
+ (fluid-let ((*entry-rnode* rnode))
+ (cgen-rnode rnode))))
\f
(define (cgen-rnode rnode)
(let ((offset (cgen-rnode-1 rnode)))
;; LOOP is for easy restart while debugging.
(let loop ()
(let ((match-result
- (pattern-lookup
- (cdr (or (if (eq? (car (rnode-rtl rnode)) 'ASSIGN)
- (assq (caadr (rnode-rtl rnode)) *assign-rules*)
- (assq (car (rnode-rtl rnode)) *cgen-rules*))
- (error "CGEN-RNODE: Unknown keyword" rnode)))
- (rnode-rtl rnode))))
+ (let ((rule
+ (if (eq? (car (rnode-rtl rnode)) 'ASSIGN)
+ (assq (caadr (rnode-rtl rnode)) *assign-rules*)
+ (assq (car (rnode-rtl rnode)) *cgen-rules*))))
+ (and rule
+ (pattern-lookup (cdr rule) (rnode-rtl rnode))))))
(if match-result
(fluid-let ((*current-rnode* rnode)
(*dead-registers* (rnode-dead-registers rnode))
(loop))))))
\f
(define (rnode-input-register-map rnode)
- (if (or (eq? rnode *code-object-entry*)
+ (if (or (eq? rnode *entry-rnode*)
(not (node-previous=1? rnode)))
(empty-register-map)
(let ((previous (node-previous-first rnode)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.49 1987/07/09 23:18:43 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.50 1987/08/04 06:54:06 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-integrable (combination-compiled-for-value? combination)
(eq? 'VALUE (combination-compilation-type combination)))
\f
-(define-snode continuation rtl-edge label frame-pointer-offset block)
+(define-snode continuation rtl-edge label frame-pointer-offset block rgraph)
(define *continuations*)
-(define-integrable (make-continuation block)
+(define-integrable (make-continuation block rgraph)
(let ((continuation
(make-snode continuation-tag
false
(generate-label 'CONTINUATION)
false
- block)))
+ block
+ rgraph)))
(set! *continuations* (cons continuation *continuations*))
+ (set-rgraph-continuations!
+ rgraph
+ (cons continuation (rgraph-continuations rgraph)))
(symbol-hash-table/insert! *label->object*
(continuation-label continuation)
continuation)
continuation))
-(define-integrable (continuation-rtl-entry continuation)
- (edge-right-node (continuation-rtl-edge continuation)))
-
-(define-integrable (set-continuation-rtl-entry! continuation node)
- (set-continuation-rtl-edge! continuation (node->edge node)))
-
(define-unparser continuation-tag
(lambda (continuation)
(write (continuation-label continuation))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.59 1987/07/08 21:52:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.60 1987/08/04 06:54:40 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(syntax-table-define compiler-syntax-table 'DEFINE-REGISTER-REFERENCES
(macro (slot)
(let ((name (symbol-append 'REGISTER- slot)))
- (let ((vector (symbol-append '* name '*)))
- `(BEGIN (DEFINE ,vector)
- (DEFINE-INTEGRABLE (,name REGISTER)
+ (let ((vector `(,(symbol-append 'RGRAPH- name) *CURRENT-RGRAPH*)))
+ `(BEGIN (DEFINE-INTEGRABLE (,name REGISTER)
(VECTOR-REF ,vector REGISTER))
(DEFINE-INTEGRABLE
(,(symbol-append 'SET- name '!) REGISTER VALUE)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 1.3 1987/07/10 01:09:34 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 1.4 1987/08/04 06:54:16 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(write-string "REFERENCE ")
(write (variable-name (reference-variable reference)))))
\f
-(define-rvalue procedure block value fg-edge rtl-edge externally-visible?
+(define-rvalue procedure block value fg-edge rgraph externally-visible?
closure-block label external-label name required optional rest
names values auxiliary original-parameters)
(define *procedures*)
names values auxiliary)
(let ((procedure
(make-rvalue procedure-tag block (subproblem-value subproblem)
- (cfg-entry-edge (subproblem-cfg subproblem)) false false
- false (generate-label (variable-name name))
+ (cfg-entry-edge (subproblem-cfg subproblem))
+ (rgraph-allocate) false false
+ (generate-label (variable-name name))
(generate-label) name required optional rest
- names values auxiliary
- (vector required optional rest))))
+ names values auxiliary (vector required optional rest))))
(set-block-procedure! block procedure)
(vnode-connect! name procedure)
(set! *procedures* (cons procedure *procedures*))
(define-integrable (unset-procedure-fg-entry! procedure)
(set-procedure-fg-edge! procedure false))
-(define-integrable (procedure-rtl-entry procedure)
- (edge-right-node (procedure-rtl-edge procedure)))
-
-(define-integrable (set-procedure-rtl-entry! procedure node)
- (set-procedure-rtl-edge! procedure (node->edge node)))
-
(define-integrable (procedure-original-required procedure)
(vector-ref (procedure-original-parameters procedure) 0))
(define-integrable (label->procedure label)
(symbol-hash-table/lookup *label->object* label))
\f
-(define-rvalue quotation block value fg-edge rtl-edge label)
+(define-rvalue quotation block value fg-edge rgraph label)
(define *quotations*)
(define (make-quotation block subproblem)
(let ((quotation
(make-rvalue quotation-tag block (subproblem-value subproblem)
(cfg-entry-edge (subproblem-cfg subproblem))
- false (generate-label 'QUOTATION))))
+ (rgraph-allocate)
+ (generate-label 'QUOTATION))))
(set! *quotations* (cons quotation *quotations*))
quotation))
(define-integrable (unset-quotation-fg-entry! quotation)
(set-quotation-fg-edge! quotation false))
-(define-integrable (quotation-rtl-entry quotation)
- (edge-right-node (quotation-rtl-edge quotation)))
-
-(define-integrable (set-quotation-rtl-entry! quotation node)
- (set-quotation-rtl-edge! quotation (node->edge node)))
\ No newline at end of file
+(define-vector-slots rgraph 0
+ edge
+ n-registers
+ continuations
+ bblocks
+ register-bblock
+ register-next-use
+ register-n-refs
+ register-n-deaths
+ register-live-length
+ register-crosses-call?
+ )
+
+(define-integrable rgraph-register-renumber rgraph-register-bblock)
+(define-integrable set-rgraph-register-renumber! set-rgraph-register-bblock!)
+
+(define *rgraphs*)
+(define *current-rgraph*)
+
+(define (rgraph-allocate)
+ (make-vector 10 false))
+
+(define (rgraph-entry-edges rgraph)
+ (cons (rgraph-edge rgraph)
+ (map continuation-rtl-edge (rgraph-continuations rgraph))))
+
+(define (rgraph-initial-edges rgraph)
+ (cons (rgraph-edge rgraph)
+ (let loop ((continuations (rgraph-continuations rgraph)))
+ (if (null? continuations)
+ '()
+ (let ((edge (continuation-rtl-edge (car continuations))))
+ (if (node-previous=0? (edge-right-node edge))
+ (cons edge (loop (cdr continuations)))
+ (loop (cdr continuations))))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.31 1987/07/22 21:01:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.32 1987/08/04 06:56:57 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (combination/subproblem combination operator operands)
(let ((block (combination-block combination)))
(define (finish call-prefix continuation-prefix)
- (let ((continuation (make-continuation block)))
+ (let ((continuation (make-continuation block *current-rgraph*)))
(let ((continuation-cfg
(scfg*scfg->scfg!
(rtl:make-continuation-heap-check continuation)
continuation-prefix)))
- (set-continuation-rtl-entry! continuation
- (cfg-entry-node continuation-cfg))
+ (set-continuation-rtl-edge!
+ continuation
+ (node->edge (cfg-entry-node continuation-cfg)))
(make-scfg
(cfg-entry-node
(scfg*scfg->scfg!
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.16 1987/07/29 02:16:52 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.17 1987/08/04 06:57:30 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (generate-rtl quotations procedures)
+(define (generate-rtl quotation procedures)
(with-new-node-marks
(lambda ()
- (for-each generate/quotation quotations)
- (for-each generate/procedure procedures))))
-
-(define (generate/quotation quotation)
- (set-quotation-rtl-entry!
- quotation
- (cfg-entry-node
- (scfg*scfg->scfg!
- (rtl:make-assignment register:frame-pointer
- (rtl:make-fetch register:stack-pointer))
- (generate/node (let ((entry (quotation-fg-entry quotation)))
- (if (not compiler:preserve-data-structures?)
- (unset-quotation-fg-entry! quotation))
- entry)
- false)))))
-
-(define (generate/procedure procedure)
- (set-procedure-rtl-entry!
- procedure
- (cfg-entry-node
- (generate/procedure-header
- procedure
- (generate/node (let ((entry (procedure-fg-entry procedure)))
- (if (not compiler:preserve-data-structures?)
- (unset-procedure-fg-entry! procedure))
- entry)
- false)))))
-
+ (generate/rgraph
+ (quotation-rgraph quotation)
+ (lambda ()
+ (scfg*scfg->scfg!
+ (rtl:make-assignment register:frame-pointer
+ (rtl:make-fetch register:stack-pointer))
+ (generate/node (let ((entry (quotation-fg-entry quotation)))
+ (if (not compiler:preserve-data-structures?)
+ (unset-quotation-fg-entry! quotation))
+ entry)
+ false))))
+ (for-each (lambda (procedure)
+ (generate/rgraph
+ (procedure-rgraph procedure)
+ (lambda ()
+ (generate/procedure-header
+ procedure
+ (generate/node
+ (let ((entry (procedure-fg-entry procedure)))
+ (if (not compiler:preserve-data-structures?)
+ (unset-procedure-fg-entry! procedure))
+ entry)
+ false)))))
+ procedures))))
+
+(define (generate/rgraph rgraph generator)
+ (fluid-let ((*current-rgraph* rgraph)
+ (*temporary->register-map* '())
+ (*next-pseudo-number* number-of-machine-registers))
+ (set-rgraph-edge! rgraph (node->edge (cfg-entry-node (generator))))
+ (set-rgraph-n-registers! rgraph *next-pseudo-number*)))
+\f
(define (generate/node node subproblem?)
;; This won't work when there are loops in the RTL.
(cond ((not (node-marked? node))
(define (define-generator tag generator)
(define-vector-method tag generate/node generator))
-\f
+
(define (generate/subproblem-cfg subproblem)
(if (cfg-null? (subproblem-cfg subproblem))
(make-null-cfg)
(transmit-values (generate/subproblem subproblem)
(lambda (cfg expression)
(scfg*scfg->scfg! cfg (rtl:make-push expression)))))
-
+\f
(define (define-statement-generator tag generator)
(define-generator tag
(lambda (node subproblem?)
(generate/node (pnode-consequent node) subproblem?))
(and (pnode-alternative node)
(generate/node (pnode-alternative node) subproblem?)))))
-\f
+
(define-integrable (node-rtl-result node)
(node-property-get node tag/node-rtl-result))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.10 1987/03/19 00:46:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.11 1987/08/04 06:56:02 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (register-allocation bblocks)
+(package (register-allocation)
+
+(define (register-allocation rgraphs)
+ (for-each walk-rgraph rgraphs))
+
+(define (walk-rgraph rgraph)
+ (let ((n-registers (rgraph-n-registers rgraph)))
+ (set-rgraph-register-renumber!
+ rgraph
+ (make-vector n-registers false))
+ (fluid-let ((*current-rgraph* rgraph))
+ (walk-bblocks n-registers
+ (let ((bblocks (rgraph-bblocks rgraph)))
+ (set-rgraph-bblocks! rgraph false))))))
+
+(define (walk-bblocks n-registers bblocks)
;; First, renumber all the registers remaining to be allocated.
(let ((next-renumber 0)
- (register->renumber (make-vector *n-registers* false)))
+ (register->renumber (make-vector n-registers false)))
(define (renumbered-registers n)
- (if (< n *n-registers*)
+ (if (< n n-registers)
(if (vector-ref register->renumber n)
(cons n (renumbered-registers (1+ n)))
(renumbered-registers (1+ n)))
(make-regset next-renumber))
allocation)))
(let ((allocation (loop 0)))
- (vector-set! *register-renumber* register allocation)
+ (set-register-renumber! register allocation)
(regset-adjoin! (vector-ref allocated allocation)
renumber))))
(sort (renumbered-registers number-of-machine-registers)
allocate<?))
next-allocation))))
+)
+
(define (allocate<? x y)
(< (/ (register-n-refs x) (register-live-length x))
(/ (register-n-refs y) (register-live-length y))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.1 1987/04/17 10:53:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.2 1987/08/04 06:56:48 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (dead-code-elimination bblocks)
- (for-each (lambda (bblock)
- (if (not (eq? (bblock-entry bblock) (bblock-exit bblock)))
- (let ((live (regset-copy (bblock-live-at-entry bblock)))
- (births (make-regset *n-registers*)))
- (bblock-walk-forward bblock
- (lambda (rnode next)
- (if next
- (begin (optimize-rtl live rnode next)
- (regset-clear! births)
- (mark-set-registers! live
- births
- (rnode-rtl rnode)
- false)
- (for-each (lambda (register)
- (regset-delete! live register))
- (rnode-dead-registers rnode))
- (regset-union! live births))))))))
- bblocks))
+(package (dead-code-elimination)
+(define-export (dead-code-elimination rgraphs)
+ (for-each walk-rgraph rgraphs))
+
+(define (walk-rgraph rgraph)
+ (fluid-let ((*current-rgraph* rgraph))
+ (for-each walk-bblock (rgraph-bblocks rgraph))))
+
+(define (walk-bblock bblock)
+ (if (not (eq? (bblock-entry bblock) (bblock-exit bblock)))
+ (let ((live (regset-copy (bblock-live-at-entry bblock)))
+ (births (make-regset (rgraph-n-registers *current-rgraph*))))
+ (bblock-walk-forward bblock
+ (lambda (rnode next)
+ (if next
+ (begin (optimize-rtl live rnode next)
+ (regset-clear! births)
+ (mark-set-registers! live
+ births
+ (rnode-rtl rnode)
+ false)
+ (for-each (lambda (register)
+ (regset-delete! live register))
+ (rnode-dead-registers rnode))
+ (regset-union! live births))))))))
+
+)
+\f
(define (optimize-rtl live rnode next)
(let ((rtl (rnode-rtl rnode)))
(if (rtl:assign? rtl)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.111 1987/07/03 18:58:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.112 1987/08/04 06:56:11 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (common-subexpression-elimination blocks n-registers)
+(define *initial-queue*)
+(define *branch-queue*)
+
+(define (common-subexpression-elimination rgraphs)
(with-new-node-marks
(lambda ()
- (fluid-let ((*next-quantity-number* 0))
- (state:initialize n-registers
- (lambda ()
- (for-each (lambda (block)
- (state:reset!)
- (walk-rnode block))
- blocks)))))))
-
+ (for-each cse-rgraph rgraphs))))
+
+(define (cse-rgraph rgraph)
+ (fluid-let ((*current-rgraph* rgraph)
+ (*next-quantity-number* 0)
+ (*initial-queue* (make-queue))
+ (*branch-queue* '()))
+ (for-each (lambda (edge)
+ (enqueue! *initial-queue* (edge-right-node edge)))
+ (rgraph-initial-edges rgraph))
+ (state:initialize rgraph continue-walk)))
+
+(define (continue-walk)
+ (cond ((not (null? *branch-queue*))
+ (let ((entry (car *branch-queue*)))
+ (set! *branch-queue* (cdr *branch-queue*))
+ (state:set! *current-rgraph* (car entry))
+ (walk-rnode (cdr entry))))
+ ((not (queue-empty? *initial-queue*))
+ (state:reset! *current-rgraph*)
+ (walk-rnode (dequeue! *initial-queue*)))))
+\f
(define (walk-rnode rnode)
(node-mark! rnode)
((vector-method rnode walk-rnode) rnode))
(cse-statement (rnode-rtl rnode))
(let ((next (snode-next rnode)))
(if (walk-next? next)
- (walk-next next)))))
+ (walk-next next)
+ (continue-walk)))))
(define-vector-method rtl-pnode-tag walk-rnode
(lambda (rnode)
(alternative (pnode-alternative rnode)))
(if (walk-next? consequent)
(if (walk-next? alternative)
- (cond ((node-previous>1? consequent)
- (walk-next alternative)
- (state:reset!)
- (walk-rnode consequent))
- ((node-previous>1? alternative)
- (walk-rnode consequent)
- (state:reset!)
- (walk-rnode alternative))
- (else
- (let ((state (state:get)))
- (walk-rnode consequent)
- (state:set! state))
- (walk-rnode alternative)))
+ (if (node-previous>1? consequent)
+ (begin (enqueue! *initial-queue* consequent)
+ (walk-next alternative))
+ (begin (if (node-previous>1? alternative)
+ (enqueue! *initial-queue* alternative)
+ (set! *branch-queue*
+ (cons (cons (state:get *current-rgraph*)
+ alternative)
+ *branch-queue*)))
+ (walk-rnode consequent)))
(walk-next consequent))
(if (walk-next? alternative)
- (walk-next alternative))))))
+ (walk-next alternative)
+ (continue-walk))))))
(define (walk-next? rnode)
(and rnode (not (node-marked? rnode))))
(define (walk-next rnode)
- (if (node-previous>1? rnode) (state:reset!))
+ (if (node-previous>1? rnode) (state:reset! *current-rgraph*))
(walk-rnode rnode))
\f
(define (cse-statement statement)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.2 1987/04/24 14:15:53 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.3 1987/08/04 06:56:31 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(set-register-quantity! register quantity)
quantity)))
+(define-integrable rgraph-register-quantity rgraph-register-bblock)
+(define-integrable rgraph-register-next-equivalent rgraph-register-next-use)
+(define-integrable rgraph-register-previous-equivalent rgraph-register-n-refs)
+(define-integrable rgraph-register-expression rgraph-register-n-deaths)
+(define-integrable rgraph-register-tick rgraph-register-live-length)
+(define-integrable rgraph-register-in-table rgraph-register-crosses-call?)
+
+(define-integrable set-rgraph-register-quantity! set-rgraph-register-bblock!)
+(define-integrable set-rgraph-register-next-equivalent!
+ set-rgraph-register-next-use!)
+(define-integrable set-rgraph-register-previous-equivalent!
+ set-rgraph-register-n-refs!)
+(define-integrable set-rgraph-register-expression!
+ set-rgraph-register-n-deaths!)
+(define-integrable set-rgraph-register-tick! set-rgraph-register-live-length!)
+(define-integrable set-rgraph-register-in-table!
+ set-rgraph-register-crosses-call?!)
+
(define-register-references quantity)
(define-register-references next-equivalent)
(define-register-references previous-equivalent)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.56 1987/04/17 10:52:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.57 1987/08/04 06:57:18 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
;;;; Lifetime Analysis
-(define (lifetime-analysis bblocks)
+(package (lifetime-analysis)
+
+(define-export (lifetime-analysis rgraphs)
+ (for-each walk-rgraph rgraphs))
+
+(define (walk-rgraph rgraph)
+ (let ((n-registers (rgraph-n-registers rgraph))
+ (bblocks (rgraph-bblocks rgraph)))
+ (set-rgraph-register-bblock! rgraph (make-vector n-registers false))
+ (set-rgraph-register-next-use! rgraph (make-vector n-registers false))
+ (set-rgraph-register-n-refs! rgraph (make-vector n-registers 0))
+ (set-rgraph-register-n-deaths! rgraph (make-vector n-registers 0))
+ (set-rgraph-register-live-length! rgraph (make-vector n-registers 0))
+ (set-rgraph-register-crosses-call?! rgraph (make-bit-string n-registers false))
+ (for-each (lambda (bblock)
+ (bblock-initialize-regsets! bblock n-registers))
+ bblocks)
+ (fluid-let ((*current-rgraph* rgraph))
+ (walk-bblock bblocks))))
+
+(define (walk-bblock bblocks)
(let ((changed? false))
(define (loop first-pass?)
(for-each (lambda (bblock)
bblocks)))
(loop true)))
+)
+\f
(define (propagate-block bblock)
(propagation-loop bblock
(lambda (old dead live rtl rnode)
(begin (update-live-registers! old dead live rtl rnode)
(for-each-regset-member old
increment-register-live-length!))))))
-\f
+
(define (propagation-loop bblock procedure)
(let ((old (bblock-live-at-entry bblock))
- (dead (regset-allocate *n-registers*))
- (live (regset-allocate *n-registers*)))
+ (dead (regset-allocate (rgraph-n-registers *current-rgraph*)))
+ (live (regset-allocate (rgraph-n-registers *current-rgraph*))))
(bblock-walk-backward bblock
(lambda (rnode previous)
(regset-clear! dead)
projects / mit-scheme.git / commitdiff