From: Chris Hanson Date: Mon, 15 Dec 1986 05:28:22 +0000 (+0000) Subject: *** empty log message *** X-Git-Tag: 20090517-FFI~13819 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=24796e943bcef8c09c6bcd9091e87ece27f4ec18;p=mit-scheme.git *** empty log message *** --- diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index d4e0834f6..061fb0aec 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -37,35 +37,37 @@ ;;;; LAP Code Generation +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.18 1986/12/15 05:26:52 cph Exp $ + (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) (define *code-object-label*) +(define *code-object-entry*) (define (generate-lap quotations procedures continuations receiver) (fluid-let ((*generation* (make-generation)) (*next-constant* 0) (*interned-constants* '()) (*block-start-label* (generate-label)) - (*code-object-label*)) - (for-each (lambda (continuation) - (set! *code-object-label* - (code-object-label-initialize continuation)) - (let ((rnode (cfg-entry-node (continuation-rtl continuation)))) - (hooks-disconnect! (node-previous rnode) rnode) - (cgen-rnode rnode))) - continuations) + (*code-object-label*) + (*code-object-entry*)) (for-each (lambda (quotation) - (set! *code-object-label* - (code-object-label-initialize quotation)) - (cgen-rnode (cfg-entry-node (quotation-rtl quotation)))) + (cgen-cfg quotation quotation-rtl)) quotations) (for-each (lambda (procedure) - (set! *code-object-label* - (code-object-label-initialize procedure)) - (cgen-rnode (cfg-entry-node (procedure-rtl procedure)))) + (cgen-cfg procedure procedure-rtl)) procedures) + (for-each (lambda (continuation) + (cgen-cfg continuation continuation-rtl)) + continuations) (receiver *interned-constants* *block-start-label*))) + +(define (cgen-cfg object extract-cfg) + (set! *code-object-label* (code-object-label-initialize object)) + (let ((rnode (cfg-entry-node (extract-cfg object)))) + (set! *code-object-entry* rnode) + (cgen-rnode rnode))) (define *current-rnode*) (define *dead-registers*) @@ -73,9 +75,10 @@ (define (cgen-rnode rnode) (define (cgen-right-node next) (if (and next (not (eq? (node-generation next) *generation*))) - (begin (if (not (null? (cdr (node-previous next)))) + (begin (if (node-previous>1? next) (let ((hook (find-hook rnode next)) (snode (statement->snode '(NOOP)))) + (set-node-generation! snode *generation*) (set-rnode-lap! snode (clear-map-instructions (rnode-register-map rnode))) @@ -95,8 +98,7 @@ (*needed-registers* '())) (let ((instructions (match-result))) (set-rnode-lap! rnode - (append! *prefix-instructions* - instructions))) + (append! *prefix-instructions* instructions))) (delete-dead-registers!) (set-rnode-register-map! rnode *register-map*)) (begin (error "CGEN-RNODE: No matching rules" (rnode-rtl rnode)) @@ -105,14 +107,6 @@ (cgen-right-node (pnode-consequent rnode)) (cgen-right-node (pnode-alternative rnode))) -(define (rnode-input-register-map node) - (let ((previous (node-previous node))) - (if (and (not (null? previous)) - (null? (cdr previous)) - (not (entry-holder? (hook-node (car previous))))) - (rnode-register-map (hook-node (car previous))) - (empty-register-map)))) - (define *cgen-rules* '()) @@ -122,6 +116,22 @@ *cgen-rules*)) pattern) +(define (rnode-input-register-map rnode) + (if (or (eq? rnode *code-object-entry*) + (not (node-previous=1? rnode))) + (empty-register-map) + (let ((previous (node-previous-first rnode))) + (let ((map (rnode-register-map previous))) + (if (rtl-pnode? previous) + (delete-pseudo-registers + map + (regset->list + (regset-difference + (bblock-live-at-exit (rnode-bblock previous)) + (bblock-live-at-entry (rnode-bblock rnode)))) + (lambda (map aliases) map)) + map))))) + ;;;; Machine independent stuff (define *register-map*) @@ -151,36 +161,71 @@ (define ((register-type-predicate type) register) (register-type? register type)) -(define (guarantee-machine-register! register type receiver) +(define-integrable (dead-register? register) + (memv register *dead-registers*)) + +(define (guarantee-machine-register! register type) (if (and (machine-register? register) (register-type? register type)) - (receiver register) - (with-alias-register! register type receiver))) + register + (load-alias-register! register type))) -(define (with-alias-register! register type receiver) +(define (load-alias-register! register type) (bind-allocator-values (load-alias-register *register-map* type *needed-registers* register) - (lambda (alias map instructions) - (set! *register-map* map) - (need-register! alias) - (append! instructions (receiver alias))))) + store-allocator-values!)) -(define (allocate-register-for-assignment! register type receiver) +(define (allocate-alias-register! register type) (bind-allocator-values (allocate-alias-register *register-map* type *needed-registers* register) (lambda (alias map instructions) - (set! *register-map* (delete-other-locations map alias)) - (need-register! alias) - (append! instructions (receiver alias))))) + (store-allocator-values! alias + (delete-other-locations map alias) + instructions)))) -(define (with-temporary-register! type receiver) +(define (allocate-temporary-register! type) (bind-allocator-values (allocate-temporary-register *register-map* type *needed-registers*) - (lambda (alias map instructions) - (set! *register-map* map) - (need-register! alias) - (append! instructions (receiver alias))))) + store-allocator-values!)) + +(define (store-allocator-values! alias map instructions) + (need-register! alias) + (set! *register-map* map) + (prefix-instructions! instructions) + alias) + +(define (move-to-alias-register! source type target) + (reuse-pseudo-register-alias! source type + (lambda (reusable-alias) + (add-pseudo-register-alias! target reusable-alias)) + (lambda () + (allocate-alias-register! target type)))) + +(define (move-to-temporary-register! source type) + (reuse-pseudo-register-alias! source type + need-register! + (lambda () + (allocate-temporary-register! type)))) + +(define (reuse-pseudo-register-alias! source type if-reusable if-not) + (let ((reusable-alias + (and (dead-register? source) + (register-alias source type)))) + (if reusable-alias + (begin (delete-dead-registers!) + (if-reusable reusable-alias) + (register-reference reusable-alias)) + (let ((source (coerce->any source))) + (delete-dead-registers!) + (let ((target (register-reference (if-not)))) + (prefix-instructions! `((MOVE L ,source ,target))) + target))))) +(define (add-pseudo-register-alias! register alias) + (set! *register-map* + (add-pseudo-register-alias *register-map* register alias)) + (need-register! alias)) + (define (clear-map!) (let ((instructions (clear-map))) (set! *register-map* (empty-register-map)) @@ -193,8 +238,7 @@ (define (clear-registers! . registers) (if (null? registers) '() - (let loop ((map *register-map*) - (registers registers)) + (let loop ((map *register-map*) (registers registers)) (save-machine-register map (car registers) (lambda (map instructions) (let ((map (delete-machine-register map (car registers)))) @@ -219,8 +263,7 @@ (set! *register-map* (delete-machine-register *register-map* register)) (set! *needed-registers* (set-delete *needed-registers* register))) -(package (delete-pseudo-register! - delete-dead-registers!) +(package (delete-pseudo-register! delete-dead-registers!) (define-export (delete-pseudo-register! register) (delete-pseudo-register *register-map* register delete-registers!)) (define-export (delete-dead-registers!) @@ -229,9 +272,6 @@ (define (delete-registers! map aliases) (set! *register-map* map) (set! *needed-registers* (set-difference *needed-registers* aliases)))) - -(define-integrable (dead-register? register) - (memv register *dead-registers*)) (define *next-constant*) (define *interned-constants*) diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm index fa52c5d76..92741f670 100644 --- a/v7/src/compiler/back/regmap.scm +++ b/v7/src/compiler/back/regmap.scm @@ -37,6 +37,8 @@ ;;;; Register Allocator +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 1.85 1986/12/15 05:27:32 cph Exp $ + (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -95,6 +97,7 @@ REGISTER-RENUMBERs are equal. (define load-alias-register) (define allocate-alias-register) (define allocate-temporary-register) +(define add-pseudo-register-alias) (define machine-register-contents) (define pseudo-register-aliases) @@ -369,6 +372,12 @@ REGISTER-RENUMBERs are equal. (register-map:add-home map false alias) instructions)))) +(define-export (add-pseudo-register-alias map register alias) + (let ((entry (map-entries:find-home map register))) + (if entry + (register-map:add-alias map entry alias) + (register-map:add-home map register alias)))) + (define-export (machine-register-contents map register) (let ((entry (map-entries:find-alias map register))) (and entry diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index 6058c7745..c1b5bf2d3 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -37,6 +37,8 @@ ;;;; Control Flow Graph Abstraction +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.137 1986/12/15 05:25:37 cph Exp $ + (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -83,7 +85,7 @@ (define-vector-method pnode-tag ':DESCRIBE pnode-describe) -;;;; Special Nodes +;;;; Holders ;;; Entry/Exit holder nodes are used to hold onto the edges of a ;;; graph. Entry holders need only a next connection, and exit @@ -120,7 +122,118 @@ (define-integrable (entry-holder-next entry) (next-reference (entry-holder-&next entry))) + +(define (node->holder node) + (let ((holder (make-entry-holder))) + (entry-holder-connect! holder node) + holder)) + +(define-integrable (entry-holder-hook? hook) + (entry-holder? (hook-node hook))) + +(define-integrable (node-previous=0? node) + (hooks=0? (node-previous node))) + +(define (hooks=0? hooks) + (or (null? hooks) + (and (entry-holder-hook? (car hooks)) + (hooks=0? (cdr hooks))))) + +(define-integrable (node-previous>0? node) + (hooks>0? (node-previous node))) + +(define (hooks>0? hooks) + (and (not (null? hooks)) + (or (not (entry-holder-hook? (car hooks))) + (hooks>0? (cdr hooks))))) + +(define-integrable (node-previous=1? node) + (hooks=1? (node-previous node))) + +(define (hooks=1? hooks) + (and (not (null? hooks)) + ((if (entry-holder-hook? (car hooks)) hooks=1? hooks=0?) + (cdr hooks)))) + +(define-integrable (node-previous>1? node) + (hooks>1? (node-previous node))) + +(define (hooks>1? hooks) + (and (not (null? hooks)) + ((if (entry-holder-hook? (car hooks)) hooks>1? hooks>0?) + (cdr hooks)))) + +(define-integrable (node-previous-first node) + (hook-node (hooks-first (node-previous node)))) + +(define (hooks-first hooks) + (cond ((null? hooks) (error "No first hook")) + ((entry-holder-hook? (car hooks)) (hooks-first (cdr hooks))) + (else (car hooks)))) + +(define (for-each-previous-node node procedure) + (for-each (lambda (hook) + (let ((node (hook-node hook))) + (if (not (entry-holder? node)) + (procedure node)))) + (node-previous node))) +;;;; Frames + +(define frame-tag (make-vector-tag false 'FRAME)) +(define-vector-slots frame 1 &entry) + +(define-integrable (frame-entry-node frame) + (entry-holder-next (frame-&entry frame))) + +(define sframe-tag (make-vector-tag frame-tag 'SFRAME)) +(define-vector-slots sframe 2 &next) + +(define-integrable (make-sframe entry next) + (vector sframe-tag entry next)) + +(define-integrable (sframe-next-hooks sframe) + (node-previous (sframe-&next sframe))) + +(define (scfg->sframe scfg) + (let ((entry (make-entry-holder)) + (exit (make-exit-holder))) + (entry-holder-connect! entry (cfg-entry-node scfg)) + (hooks-connect! (scfg-next-hooks scfg) exit) + (make-sframe entry exit))) + +(define (sframe->scfg sframe) + (make-scfg (frame-entry-node sframe) + (sframe-next-hooks sframe))) + +(define pframe-tag (make-vector-tag frame-tag 'PFRAME)) +(define-vector-slots pframe 2 &consequent &alternative) + +(define-integrable (make-pframe entry consequent alternative) + (vector pframe-tag entry consequent alternative)) + +(define-integrable (pframe-consequent-hooks pframe) + (node-previous (pframe-&consequent pframe))) + +(define-integrable (pframe-alternative-hooks pframe) + (node-previous (pframe-&alternative pframe))) + +(define (pcfg->pframe pcfg) + (let ((entry (make-entry-holder)) + (consequent (make-exit-holder)) + (alternative (make-exit-holder))) + (entry-holder-connect! entry (cfg-entry-node pcfg)) + (hooks-connect! (pcfg-consequent-hooks pcfg) consequent) + (hooks-connect! (pcfg-alternative-hooks pcfg) alternative) + (make-pframe entry consequent alternative))) + +(define (pframe->scfg pframe) + (make-scfg (frame-entry-node pframe) + (pframe-consequent-hooks pframe) + (pframe-alternative-hooks pframe))) + +;;;; Noops + (define noop-node-tag (make-vector-tag cfg-node-tag 'NOOP)) (define-vector-slots noop-node 1 previous next) (define *noop-nodes*) @@ -193,16 +306,6 @@ (set-cdr! entry item) (set-node-alist! node (cons (cons key item) (node-alist node)))))) -(define-integrable (node-previous-node node) - (hook-node (car (node-previous node)))) - -(define (for-each-previous-node node procedure) - (for-each (lambda (hook) - (let ((node (hook-node hook))) - (if (not (entry-holder? node)) - (procedure node)))) - (node-previous node))) - (define *generation*) (define make-generation diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index c491967c3..586edc14b 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -37,6 +37,8 @@ ;;;; Compiler CFG Datatypes +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.33 1986/12/15 05:26:07 cph Exp $ + (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -52,6 +54,31 @@ (vnode-connect! lvalue rvalue) (snode->scfg (make-snode definition-tag block lvalue rvalue))) +(define-pnode true-test rvalue) + +(define-integrable (make-true-test rvalue) + (pnode->pcfg (make-pnode true-test-tag rvalue))) + +(define-pnode type-test rvalue type) + +(define (make-type-test rvalue type) + (pnode->pcfg (make-pnode type-test-tag rvalue type))) + +(define-pnode unassigned-test block variable) + +(define-integrable (make-unassigned-test block variable) + (pnode->pcfg (make-pnode unassigned-test-tag block variable))) + +(define-pnode unbound-test block variable) + +(define-integrable (make-unbound-test block variable) + (pnode->pcfg (make-pnode unbound-test-tag block variable))) + +(define-snode rtl-quote generator) + +(define-integrable (make-rtl-quote generator) + (snode->scfg (make-snode rtl-quote-tag generator))) + (define-snode combination block compilation-type value operator operands procedures known-operator) (define *combinations*) @@ -67,21 +94,28 @@ (cons combination (vnode-combinations value))) (snode->scfg combination))) -(define-snode rtl-quote generator) - -(define-integrable (make-rtl-quote generator) - (snode->scfg (make-snode rtl-quote-tag generator))) - -(define-snode continuation block entry delta generator rtl label) +(define-snode continuation block &entry delta generator &rtl label) (define *continuations*) (define-integrable (make-continuation block entry delta generator) (let ((continuation - (make-snode continuation-tag block entry delta generator false - (generate-label 'CONTINUATION)))) + (make-snode continuation-tag block (node->holder entry) delta + generator false (generate-label 'CONTINUATION)))) (set! *continuations* (cons continuation *continuations*)) continuation)) +(define-integrable (continuation-entry continuation) + (entry-holder-next (continuation-&entry continuation))) + +(define-integrable (set-continuation-entry! continuation entry) + (set-continuation-&entry! continuation (node->holder entry))) + +(define-integrable (continuation-rtl continuation) + (sframe->scfg (continuation-&rtl continuation))) + +(define-integrable (set-continuation-rtl! continuation rtl) + (set-continuation-&rtl! continuation (scfg->sframe rtl))) + (define-unparser continuation-tag (lambda (continuation) (write (continuation-label continuation)))) @@ -92,26 +126,6 @@ generator) (snode->scfg (make-snode invocation-tag number-pushed continuation procedure generator))) - -(define-pnode true-test rvalue) - -(define-integrable (make-true-test rvalue) - (pnode->pcfg (make-pnode true-test-tag rvalue))) - -(define-pnode type-test rvalue type) - -(define (make-type-test rvalue type) - (pnode->pcfg (make-pnode type-test-tag rvalue type))) - -(define-pnode unassigned-test block variable) - -(define-integrable (make-unassigned-test block variable) - (pnode->pcfg (make-pnode unassigned-test-tag block variable))) - -(define-pnode unbound-test block variable) - -(define-integrable (make-unbound-test block variable) - (pnode->pcfg (make-pnode unbound-test-tag block variable))) ;;; end USING-SYNTAX ) diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 61d2dcbd4..73af84709 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -37,6 +37,8 @@ ;;;; Compiler Utilities +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.70 1986/12/15 05:28:22 cph Exp $ + (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -50,7 +52,8 @@ (unparse-with-brackets (lambda () (write-string "LIAR ") - ((vector-method object ':UNPARSE) object))))) + (fluid-let ((*unparser-radix* 16)) + ((vector-method object ':UNPARSE) object)))))) tag)) (define (vector-tag-put! tag key value) diff --git a/v7/src/compiler/rtlopt/ralloc.scm b/v7/src/compiler/rtlopt/ralloc.scm index 28ec0d46b..2a78b3786 100644 --- a/v7/src/compiler/rtlopt/ralloc.scm +++ b/v7/src/compiler/rtlopt/ralloc.scm @@ -38,6 +38,8 @@ ;;;; Register Allocation ;;; Based on the GNU C Compiler +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.8 1986/12/15 05:27:11 cph Exp $ + (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -70,7 +72,7 @@ (if renumber (regset-adjoin! live renumber))))) (walk-bblock-forward bblock - (lambda (rnode) + (lambda (rnode next) (for-each-regset-member live (lambda (renumber) (regset-union! (vector-ref conflict-matrix diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index dafd7ac87..fdd39e117 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -38,6 +38,8 @@ ;;;; RTL Common Subexpression Elimination ;;; Based on the GNU C Compiler +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.92 1986/12/15 05:27:18 cph Exp $ + (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -142,30 +144,26 @@ (thunk) (if (not volatile?) (insert-source!))) -(define-cse-method 'EQ-TEST - (lambda (statement) - (expression-replace! rtl:eq-test-expression-1 - rtl:set-eq-test-expression-1! - statement - trivial-action) - (expression-replace! rtl:eq-test-expression-2 - rtl:set-eq-test-expression-2! - statement - trivial-action))) +(define (define-trivial-one-arg-method type get set) + (define-cse-method type + (lambda (statement) + (expression-replace! get set statement trivial-action)))) -(define (define-trivial-method type get-expression set-expression!) +(define (define-trivial-two-arg-method type get-1 set-1 get-2 set-2) (define-cse-method type (lambda (statement) - (expression-replace! get-expression set-expression! statement - trivial-action)))) + (expression-replace! get-1 set-1 statement trivial-action) + (expression-replace! get-2 set-2 statement trivial-action)))) + +(define-trivial-two-arg-method 'EQ-TEST + rtl:eq-test-expression-1 rtl:set-eq-test-expression-1! + rtl:eq-test-expression-2 rtl:set-eq-test-expression-2!) -(define-trivial-method 'TRUE-TEST - rtl:true-test-expression - rtl:set-true-test-expression!) +(define-trivial-one-arg-method 'TRUE-TEST + rtl:true-test-expression rtl:set-true-test-expression!) -(define-trivial-method 'TYPE-TEST - rtl:type-test-expression - rtl:set-type-test-expression!) +(define-trivial-one-arg-method 'TYPE-TEST + rtl:type-test-expression rtl:set-type-test-expression!) (define-cse-method 'RETURN noop) (define-cse-method 'PROCEDURE-HEAP-CHECK noop) diff --git a/v7/src/compiler/rtlopt/rlife.scm b/v7/src/compiler/rtlopt/rlife.scm index 9d6b86f1d..cd9d1874b 100644 --- a/v7/src/compiler/rtlopt/rlife.scm +++ b/v7/src/compiler/rtlopt/rlife.scm @@ -38,6 +38,8 @@ ;;;; RTL Register Lifetime Analysis ;;; Based on the GNU C Compiler +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.50 1986/12/15 05:27:44 cph Exp $ + (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -76,7 +78,7 @@ (let ((next (snode-next snode))) (cond ((not next) (set-bblock-exit! bblock snode)) - ((or (not (null? (cdr (node-previous next)))) + ((or (node-previous>1? next) (rtl:invocation? (rnode-rtl snode))) (set-bblock-exit! bblock snode) (walk-next next)) @@ -143,14 +145,11 @@ (let ((old (bblock-live-at-entry bblock)) (dead (regset-allocate *n-registers*)) (live (regset-allocate *n-registers*))) - (let loop ((rnode (bblock-exit bblock))) - (regset-clear! dead) - (regset-clear! live) - (let ((previous - (and (not (eq? rnode (bblock-entry bblock))) - (node-previous-node rnode)))) - (procedure old dead live (rnode-rtl rnode) rnode) - (if previous (loop previous)))))) + (walk-bblock-backward bblock + (lambda (rnode previous) + (regset-clear! dead) + (regset-clear! live) + (procedure old dead live (rnode-rtl rnode) rnode))))) (define (update-live-registers! old dead live rtl rnode) (mark-set-registers! old dead rtl rnode) @@ -222,21 +221,20 @@ ;;;; Optimization (define (optimize-block bblock) - (let ((live (regset-copy (bblock-live-at-entry bblock))) - (births (make-regset *n-registers*))) - (define (loop rnode next) - (optimize-rtl live rnode next) - (if (not (eq? next (bblock-exit bblock))) - (begin (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) - (loop next (snode-next next))))) - (let ((entry (bblock-entry bblock))) - (if (not (eq? entry (bblock-exit bblock))) - (loop entry (snode-next entry)))))) + (if (not (eq? (bblock-entry bblock) (bblock-exit bblock))) + (let ((live (regset-copy (bblock-live-at-entry bblock))) + (births (make-regset *n-registers*))) + (walk-bblock-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)))))))) (define (rtl-snode-delete! rnode) (bblock-edit! (rnode-bblock rnode) @@ -268,29 +266,34 @@ (let ((register (rtl:register-number address))) (if (and (pseudo-register? register) (= 2 (register-n-refs register)) - (rnode-dead-register? next register)) - (begin - (let ((dead (rnode-dead-registers rnode))) - (for-each increment-register-live-length! dead) - (set-rnode-dead-registers! - next - (set-union dead - (delv! register - (rnode-dead-registers next))))) - (for-each-regset-member live - decrement-register-live-length!) - (rtl:modify-subexpressions (rnode-rtl next) - (lambda (expression set-expression!) - (if (and (rtl:register? expression) + (rnode-dead-register? next register) + (rtl:any-subexpression? (rnode-rtl next) + (lambda (expression) + (and (rtl:register? expression) (= (rtl:register-number expression) - register)) - (set-expression! (rtl:assign-expression rtl))))) - (rtl-snode-delete! rnode) - (reset-register-n-refs! register) - (reset-register-n-deaths! register) - (reset-register-live-length! register) - (set-register-next-use! register false) - (set-register-bblock! register false))))))))) + register))))) + (begin + (let ((dead (rnode-dead-registers rnode))) + (for-each increment-register-live-length! dead) + (set-rnode-dead-registers! + next + (set-union dead + (delv! register + (rnode-dead-registers next))))) + (for-each-regset-member live + decrement-register-live-length!) + (rtl:modify-subexpressions (rnode-rtl next) + (lambda (expression set-expression!) + (if (and (rtl:register? expression) + (= (rtl:register-number expression) + register)) + (set-expression! (rtl:assign-expression rtl))))) + (rtl-snode-delete! rnode) + (reset-register-n-refs! register) + (reset-register-n-deaths! register) + (reset-register-live-length! register) + (set-register-next-use! register false) + (set-register-bblock! register false))))))))) (define set-union (let () @@ -358,7 +361,7 @@ (write-string " ") (write register))))))) (reverse bblocks)))) - + ;;; end USING-SYNTAX )