;;;; 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)
\f
(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)))
\f
(define *current-rnode*)
(define *dead-registers*)
(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)))
(*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))
(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*
'())
*cgen-rules*))
pattern)
\f
+(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)))))
+\f
;;;; Machine independent stuff
(define *register-map*)
(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*))
+\f
+(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)))))
\f
+(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))
(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))))
(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!)
(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*))
\f
(define *next-constant*)
(define *interned-constants*)
;;;; 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)
\f
(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)
(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
;;;; 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)
\f
(define-vector-method pnode-tag ':DESCRIBE
pnode-describe)
\f
-;;;; 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
(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))
+\f
+(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)))
\f
+;;;; 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)))
+\f
+;;;; Noops
+
(define noop-node-tag (make-vector-tag cfg-node-tag 'NOOP))
(define-vector-slots noop-node 1 previous next)
(define *noop-nodes*)
(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
;;;; 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)
\f
(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)))
+\f
(define-snode combination block compilation-type value operator operands
procedures known-operator)
(define *combinations*)
(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))))
generator)
(snode->scfg (make-snode invocation-tag number-pushed continuation procedure
generator)))
-\f
-(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
)
;;;; 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)
\f
(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)
;;;; 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)
\f
(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
;;;; 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)
\f
(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)
;;;; 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)
\f
(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))
(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)
;;;; 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)
(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 ()
(write-string " ")
(write register)))))))
(reverse bblocks))))
-\f
+
;;; end USING-SYNTAX
)
projects / mit-scheme.git / commitdiff