From 2b2699f45a57ec7fa7e6ba980f4ef14c8582d6db Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 4 Aug 1987 06:58:01 +0000 Subject: [PATCH] Allocate RTL registers separately for each procedure (and quotation), since no register is used in more than one procedure. --- v7/src/compiler/back/lapgn1.scm | 58 +++++++++++-------------- v7/src/compiler/base/ctypes.scm | 18 ++++---- v7/src/compiler/base/macros.scm | 7 ++-- v7/src/compiler/base/rvalue.scm | 63 +++++++++++++++++++--------- v7/src/compiler/rtlgen/rgcomb.scm | 9 ++-- v7/src/compiler/rtlgen/rtlgen.scm | 70 ++++++++++++++++--------------- v7/src/compiler/rtlopt/ralloc.scm | 27 +++++++++--- v7/src/compiler/rtlopt/rcompr.scm | 49 +++++++++++++--------- v7/src/compiler/rtlopt/rcse1.scm | 68 ++++++++++++++++++------------ v7/src/compiler/rtlopt/rcserq.scm | 20 ++++++++- v7/src/compiler/rtlopt/rlife.scm | 32 +++++++++++--- 11 files changed, 260 insertions(+), 161 deletions(-) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 6ab80acb1..766ca26a6 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,48 +37,38 @@ MIT in each case. |# (declare (usual-integrations)) (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)))) (define (cgen-rnode rnode) (let ((offset (cgen-rnode-1 rnode))) @@ -107,12 +97,12 @@ MIT in each case. |# ;; 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)) @@ -131,7 +121,7 @@ MIT in each case. |# (loop)))))) (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))) diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index e5465fe69..7e77a5019 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -97,28 +97,26 @@ MIT in each case. |# (define-integrable (combination-compiled-for-value? combination) (eq? 'VALUE (combination-compilation-type combination))) -(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)))) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index 50aee55e1..c9e10489c 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -230,9 +230,8 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/base/rvalue.scm b/v7/src/compiler/base/rvalue.scm index 185e74447..c6f7bbc51 100644 --- a/v7/src/compiler/base/rvalue.scm +++ b/v7/src/compiler/base/rvalue.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -86,7 +86,7 @@ MIT in each case. |# (write-string "REFERENCE ") (write (variable-name (reference-variable reference))))) -(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*) @@ -95,11 +95,11 @@ MIT in each case. |# 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*)) @@ -114,12 +114,6 @@ MIT in each case. |# (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)) @@ -137,14 +131,15 @@ MIT in each case. |# (define-integrable (label->procedure label) (symbol-hash-table/lookup *label->object* label)) -(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)) @@ -154,8 +149,38 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index bd030e216..fc2364cc1 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -158,13 +158,14 @@ MIT in each case. |# (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! diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index 8a8731605..f1dd8c252 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,37 +36,41 @@ MIT in each case. |# (declare (usual-integrations)) -(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*))) + (define (generate/node node subproblem?) ;; This won't work when there are loops in the RTL. (cond ((not (node-marked? node)) @@ -82,7 +86,7 @@ MIT in each case. |# (define (define-generator tag generator) (define-vector-method tag generate/node generator)) - + (define (generate/subproblem-cfg subproblem) (if (cfg-null? (subproblem-cfg subproblem)) (make-null-cfg) @@ -104,7 +108,7 @@ MIT in each case. |# (transmit-values (generate/subproblem subproblem) (lambda (cfg expression) (scfg*scfg->scfg! cfg (rtl:make-push expression))))) - + (define (define-statement-generator tag generator) (define-generator tag (lambda (node subproblem?) @@ -129,7 +133,7 @@ MIT in each case. |# (generate/node (pnode-consequent node) subproblem?)) (and (pnode-alternative node) (generate/node (pnode-alternative node) subproblem?))))) - + (define-integrable (node-rtl-result node) (node-property-get node tag/node-rtl-result)) diff --git a/v7/src/compiler/rtlopt/ralloc.scm b/v7/src/compiler/rtlopt/ralloc.scm index 7f53d09be..6d68a0f72 100644 --- a/v7/src/compiler/rtlopt/ralloc.scm +++ b/v7/src/compiler/rtlopt/ralloc.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,12 +37,27 @@ MIT in each case. |# (declare (usual-integrations)) -(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))) @@ -104,13 +119,15 @@ MIT in each case. |# (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) allocate1? 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)) (define (cse-statement statement) diff --git a/v7/src/compiler/rtlopt/rcserq.scm b/v7/src/compiler/rtlopt/rcserq.scm index 57dcc1aeb..755c97776 100644 --- a/v7/src/compiler/rtlopt/rcserq.scm +++ b/v7/src/compiler/rtlopt/rcserq.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -65,6 +65,24 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/rtlopt/rlife.scm b/v7/src/compiler/rtlopt/rlife.scm index d1092a4e0..5dc9700dd 100644 --- a/v7/src/compiler/rtlopt/rlife.scm +++ b/v7/src/compiler/rtlopt/rlife.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -39,7 +39,27 @@ MIT in each case. |# ;;;; 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) @@ -68,6 +88,8 @@ MIT in each case. |# bblocks))) (loop true))) +) + (define (propagate-block bblock) (propagation-loop bblock (lambda (old dead live rtl rnode) @@ -86,11 +108,11 @@ MIT in each case. |# (begin (update-live-registers! old dead live rtl rnode) (for-each-regset-member old increment-register-live-length!)))))) - + (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) -- 2.25.1