#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 1.2 1987/08/11 06:11:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.1 1987/12/04 20:17:21 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
(define-structure (rgraph (type vector)
(copier false)
- (constructor false))
- edge
+ (constructor make-rgraph (n-registers)))
n-registers
- continuations
+ (address-registers (reverse initial-address-registers))
+ entry-edges
bblocks
register-bblock
register-n-refs
register-live-length
register-crosses-call?
)
-(define (rgraph-allocate)
- (make-vector 9 false))
+(define (add-rgraph-address-register! rgraph register)
+ (set-rgraph-address-registers! rgraph
+ (cons register
+ (rgraph-address-registers rgraph))))
+
+(define (add-rgraph-entry-node! rgraph node)
+ (set-rgraph-entry-edges! rgraph
+ (cons (node->edge node)
+ (rgraph-entry-edges rgraph))))
(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-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
+ (list-transform-positive (rgraph-entry-edges rgraph)
+ (lambda (edge)
+ (node-previous=0? (edge-right-node edge)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 1.5 1987/08/08 23:21:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 4.1 1987/12/04 20:17:27 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-vector-slots bblock 5
instructions
- (live-at-entry
- register-map)
+ (live-at-entry register-map)
live-at-exit
- (new-live-at-exit
- frame-pointer-offset)
+ (new-live-at-exit frame-pointer-offset)
label)
(define (make-sblock instructions)
instructions
register-map
frame-pointer-offset))))
- (define-vector-method sblock-tag ':DESCRIBE
- (lambda (sblock)
- (append! ((vector-tag-method snode-tag ':DESCRIBE) sblock)
- (bblock-describe sblock))))
- (define-vector-method pblock-tag ':DESCRIBE
- (lambda (pblock)
- (append! ((vector-tag-method pnode-tag ':DESCRIBE) pblock)
- (bblock-describe pblock)
- (descriptor-list pblock
- consequent-lap-generator
- alternative-lap-generator)))))
+ (set-vector-tag-description!
+ sblock-tag
+ (lambda (sblock)
+ (append! ((vector-tag-description snode-tag) sblock)
+ (bblock-describe sblock))))
+ (set-vector-tag-description!
+ pblock-tag
+ (lambda (pblock)
+ (append! ((vector-tag-description pnode-tag) pblock)
+ (bblock-describe pblock)
+ (descriptor-list pblock
+ consequent-lap-generator
+ alternative-lap-generator)))))
\f
(define (rinst-dead-register? rinst register)
(memq register (rinst-dead-registers rinst)))
(set-bblock-instructions! bblock instructions)
(begin
(snode-delete! bblock)
- (let ((rgraph *current-rgraph*))
- (set-rgraph-bblocks! rgraph
- (delq! bblock (rgraph-bblocks rgraph))))))))
\ No newline at end of file
+ (set-rgraph-bblocks! *current-rgraph*
+ (delq! bblock
+ (rgraph-bblocks *current-rgraph*)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 1.13 1987/09/03 05:15:47 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.1 1987/12/04 20:17:34 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(lambda (expression)
(%make-unassigned-test expression))))
-;;; Some statements vanish, converted into lower-level patterns.
-
(define (rtl:make-pop locative)
(locative-dereference-for-statement locative
- (lambda (address)
- (%make-assign address (stack-pop-address)))))
-
-(define (rtl:make-pop-frame n)
- (rtl:make-assignment
- register:stack-pointer
- (rtl:make-address
- (stack-locative-offset (rtl:make-fetch register:stack-pointer) n))))
+ (lambda (locative)
+ (%make-assign locative (stack-pop-address)))))
(define (rtl:make-push expression)
(expression-simplify-for-statement expression
(lambda (expression)
(%make-assign (stack-push-address) expression))))
-(define (rtl:make-push-return continuation)
- (%make-assign (stack-push-address)
- (rtl:make-entry:continuation continuation)))
+(define-integrable (rtl:make-address->environment address)
+ (rtl:make-cons-pointer (rtl:make-constant (ucode-type stack-environment))
+ address))
+\f
+(define (rtl:make-push-link)
+ (scfg*scfg->scfg!
+ (rtl:make-push
+ (rtl:make-cons-pointer (rtl:make-constant (ucode-type stack-environment))
+ (rtl:make-fetch register:dynamic-link)))
+ (rtl:make-assignment register:dynamic-link
+ (rtl:make-fetch register:stack-pointer))))
+
+(define-integrable (rtl:make-push-return continuation)
+ (rtl:make-push (rtl:make-entry:continuation continuation)))
+
+(define (rtl:make-unlink-return)
+ (scfg*scfg->scfg!
+ (rtl:make-pop-link)
+ (rtl:make-pop-return)))
+
+(define (rtl:make-pop-link)
+ (scfg*scfg->scfg!
+ (rtl:make-assignment register:stack-pointer
+ (rtl:make-fetch register:dynamic-link))
+ (rtl:make-assignment register:dynamic-link
+ (rtl:make-object->address (stack-pop-address)))))
\f
;;; Interpreter Calls
-(define ((interpreter-lookup-maker %make) environment name)
+(define rtl:make-interpreter-call:access)
+(define rtl:make-interpreter-call:cache-unassigned?)
+(define rtl:make-interpreter-call:unassigned?)
+(define rtl:make-interpreter-call:unbound?)
+(let ((interpreter-lookup-maker
+ (lambda (%make)
+ (lambda (environment name)
+ (expression-simplify-for-statement environment
+ (lambda (environment)
+ (%make environment name)))))))
+ (set! rtl:make-interpreter-call:access
+ (interpreter-lookup-maker %make-interpreter-call:access))
+ (set! rtl:make-interpreter-call:cache-unassigned?
+ (interpreter-lookup-maker %make-interpreter-call:cache-unassigned?))
+ (set! rtl:make-interpreter-call:unassigned?
+ (interpreter-lookup-maker %make-interpreter-call:unassigned?))
+ (set! rtl:make-interpreter-call:unbound?
+ (interpreter-lookup-maker %make-interpreter-call:unbound?)))
+
+(define rtl:make-interpreter-call:define)
+(define rtl:make-interpreter-call:set!)
+(let ((interpreter-assignment-maker
+ (lambda (%make)
+ (lambda (environment name value)
+ (expression-simplify-for-statement value
+ (lambda (value)
+ (expression-simplify-for-statement environment
+ (lambda (environment)
+ (%make environment name value)))))))))
+ (set! rtl:make-interpreter-call:define
+ (interpreter-assignment-maker %make-interpreter-call:define))
+ (set! rtl:make-interpreter-call:set!
+ (interpreter-assignment-maker %make-interpreter-call:set!)))
+
+(define (rtl:make-interpreter-call:lookup environment name safe?)
(expression-simplify-for-statement environment
(lambda (environment)
- (%make environment name))))
-
-(define ((interpreter-assignment-maker %make) environment name value)
- (expression-simplify-for-statement value
- (lambda (value)
- (expression-simplify-for-statement environment
- (lambda (environment)
- (%make environment name value))))))
-
-(define rtl:make-interpreter-call:access
- (interpreter-lookup-maker %make-interpreter-call:access))
+ (%make-interpreter-call:lookup environment name safe?))))
(define (rtl:make-interpreter-call:cache-assignment name value)
(expression-simplify-for-statement name
(expression-simplify-for-statement name
(lambda (name)
(%make-interpreter-call:cache-reference name safe?))))
-
-(define (rtl:make-interpreter-call:cache-unassigned? name)
- (expression-simplify-for-statement name
- (lambda (name)
- (%make-interpreter-call:cache-unassigned? name))))
-
-(define rtl:make-interpreter-call:define
- (interpreter-assignment-maker %make-interpreter-call:define))
-
-(define (rtl:make-interpreter-call:lookup environment name safe?)
- (expression-simplify-for-statement environment
- (lambda (environment)
- (%make-interpreter-call:lookup environment name safe?))))
-
-(define rtl:make-interpreter-call:set!
- (interpreter-assignment-maker %make-interpreter-call:set!))
-
-(define rtl:make-interpreter-call:unassigned?
- (interpreter-lookup-maker %make-interpreter-call:unassigned?))
-
-(define rtl:make-interpreter-call:unbound?
- (interpreter-lookup-maker %make-interpreter-call:unbound?))
-\f
-;;;; Invocations
-
-(define (rtl:make-invocation:apply frame-size prefix continuation)
- (%make-invocation:apply
- frame-size prefix (and continuation (continuation-label continuation))))
-
-(define (rtl:make-invocation:cache-reference frame-size prefix continuation
- extension)
- (expression-simplify-for-statement extension
- (lambda (extension)
- (%make-invocation:cache-reference
- frame-size prefix (and continuation (continuation-label continuation))
- extension))))
-
-(define (rtl:make-invocation:jump frame-size prefix continuation procedure)
- (%make-invocation:jump
- frame-size prefix (and continuation (continuation-label continuation))
- (procedure-label procedure)))
-
-(define (rtl:make-invocation:lexpr frame-size prefix continuation procedure)
- (%make-invocation:lexpr
- frame-size prefix (and continuation (continuation-label continuation))
- (procedure-label procedure)))
-
-(define (rtl:make-invocation:lookup frame-size prefix continuation
- environment name)
- (expression-simplify-for-statement environment
- (lambda (environment)
- (%make-invocation:lookup
- frame-size prefix (and continuation (continuation-label continuation))
- environment name))))
-
-(define (rtl:make-invocation:primitive frame-size prefix continuation
- procedure)
- (%make-invocation:primitive
- frame-size prefix (and continuation (continuation-label continuation))
- procedure))
-
-(define (rtl:make-invocation:special-primitive name frame-size
- prefix continuation)
- (%make-invocation:special-primitive
- name frame-size prefix
- (and continuation (continuation-label continuation))))
-
-(define (rtl:make-invocation:uuo-link frame-size prefix continuation name)
- (%make-invocation:uuo-link
- frame-size prefix (and continuation (continuation-label continuation))
- name))
\f
;;;; Expression Simplification
(if-register register)
(if-memory (interpreter-regs-pointer)
(rtl:interpreter-register->offset locative)))))
- ((temporary? locative)
- (if-register (temporary->register locative)))
((pair? locative)
(case (car locative)
+ ((REGISTER)
+ (if-register locative))
((FETCH)
- (locative-fetch (cadr locative) scfg-append!
- (lambda (register)
- (if-memory register 0))))
+ (locative-fetch (cadr locative) 0 scfg-append! if-memory))
((OFFSET)
(let ((fetch (cadr locative)))
(if (and (pair? fetch) (eq? (car fetch) 'FETCH))
- (locative-fetch (cadr fetch) scfg-append!
- (lambda (register)
- (if-memory register (caddr locative))))
+ (locative-fetch (cadr fetch)
+ (caddr locative)
+ scfg-append!
+ if-memory)
(error "LOCATIVE-DEREFERENCE: Bad OFFSET" locative))))
((CONSTANT)
(assign-to-temporary locative scfg-append!
(lambda (register)
- (assign-to-temporary (rtl:make-object->address register)
- scfg-append!
+ (assign-to-address-temporary register scfg-append!
(lambda (register)
(if-memory register 0))))))
(else
(else
(error "LOCATIVE-DEREFERENCE: Illegal locative" locative))))
\f
-(define (locative-fetch locative scfg-append! receiver)
- (locative-fetch-1 locative scfg-append!
- (lambda (register)
- (if (register-contains-address? (rtl:register-number register))
- (receiver register)
- (assign-to-temporary (rtl:make-object->address register)
- scfg-append!
- receiver)))))
+(define (locative-fetch locative offset scfg-append! receiver)
+ (let ((receiver
+ (lambda (register)
+ (guarantee-address register scfg-append!
+ (lambda (address)
+ (receiver address offset))))))
+ (locative-dereference locative scfg-append!
+ receiver
+ (lambda (register offset)
+ (assign-to-temporary (rtl:make-offset register offset)
+ scfg-append!
+ receiver)))))
-(define (locative-fetch-1 locative scfg-append! receiver)
+(define (locative-fetch-1 locative offset scfg-append! receiver)
(locative-dereference locative scfg-append!
- receiver
- (lambda (register offset)
- (assign-to-temporary (rtl:make-offset register offset)
- scfg-append!
- receiver))))
+ (lambda (register)
+ (receiver register offset))
+ (lambda (register offset*)
+ (receiver (rtl:make-offset register offset*) offset))))
+
+(define (guarantee-address expression scfg-append! receiver)
+ (if (rtl:address-expression? expression)
+ (receiver expression)
+ (guarantee-register expression scfg-append!
+ (lambda (register)
+ (assign-to-address-temporary register scfg-append! receiver)))))
+
+(define (rtl:address-expression? expression)
+ (if (rtl:register? expression)
+ (register-contains-address? (rtl:register-number expression))
+ (rtl:object->address? expression)))
+
+(define (guarantee-register expression scfg-append! receiver)
+ (if (rtl:register? expression)
+ (receiver expression)
+ (assign-to-temporary expression scfg-append! receiver)))
+
+(define (generate-offset-address expression offset scfg-append! receiver)
+ (guarantee-address expression scfg-append!
+ (lambda (address)
+ (guarantee-register address scfg-append!
+ (lambda (register)
+ (receiver (rtl:make-offset-address register offset)))))))
\f
(define-export (expression-simplify-for-statement expression receiver)
(expression-simplify expression scfg*scfg->scfg! receiver))
(define-export (expression-simplify-for-predicate expression receiver)
(expression-simplify expression scfg*pcfg->pcfg! receiver))
-(define (expression-simplify expression scfg-append! receiver)
- (let ((entry (assq (car expression) expression-methods))
- (receiver (expression-receiver scfg-append! receiver)))
- (if entry
- (apply (cdr entry) receiver scfg-append! (cdr expression))
- (receiver expression))))
+(define (expression-simplify* expression scfg-append! receiver)
+ (expression-simplify expression
+ scfg-append!
+ (expression-receiver scfg-append! receiver)))
(define ((expression-receiver scfg-append! receiver) expression)
- (if (memq (car expression)
- '(REGISTER CONSTANT ENTRY:CONTINUATION ENTRY:PROCEDURE UNASSIGNED))
+ (if (rtl:trivial-expression? expression)
(receiver expression)
(assign-to-temporary expression scfg-append! receiver)))
+(define (expression-simplify expression scfg-append! receiver)
+ (let ((entry (assq (car expression) expression-methods)))
+ (if entry
+ (apply (cdr entry) receiver scfg-append! (cdr expression))
+ (receiver expression))))
+
(define (assign-to-temporary expression scfg-append! receiver)
(let ((pseudo (rtl:make-pseudo-register)))
+ (if (rtl:object->address? expression)
+ (add-rgraph-address-register! *current-rgraph*
+ (rtl:register-number pseudo)))
(scfg-append! (%make-assign pseudo expression) (receiver pseudo))))
+(define (assign-to-address-temporary expression scfg-append! receiver)
+ (let ((pseudo (rtl:make-pseudo-register)))
+ (add-rgraph-address-register! *current-rgraph*
+ (rtl:register-number pseudo))
+ (scfg-append! (%make-assign pseudo (rtl:make-object->address expression))
+ (receiver pseudo))))
+
(define (define-expression-method name method)
(let ((entry (assq name expression-methods)))
(if entry
(define expression-methods
'())
-
-(define-expression-method 'ADDRESS
+\f
+(define (address-method generator)
(lambda (receiver scfg-append! locative)
(locative-dereference-1 locative scfg-append! locative-fetch-1
(lambda (register)
(error "Can't take ADDRESS of a register" locative))
- (lambda (register offset)
- (receiver (if (zero? offset)
- register
- (rtl:make-offset-address register offset)))))))
-\f
+ (generator receiver scfg-append!))))
+
+(define-expression-method 'ADDRESS
+ (address-method
+ (lambda (receiver scfg-append!)
+ (lambda (expression offset)
+ (if (zero? offset)
+ (guarantee-address expression scfg-append! receiver)
+ (generate-offset-address expression
+ offset
+ scfg-append!
+ receiver))))))
+
(define-expression-method 'CELL-CONS
(lambda (receiver scfg-append! expression)
- (expression-simplify expression scfg-append!
+ (expression-simplify* expression scfg-append!
(lambda (expression)
(let ((free (interpreter-free-pointer)))
(assign-to-temporary
(%make-assign (rtl:make-post-increment free 1) expression)
(receiver temporary)))))))))
+(define-expression-method 'ENVIRONMENT
+ (address-method
+ (lambda (receiver scfg-append!)
+ (lambda (expression offset)
+ (if (zero? offset)
+ (receiver
+ (if (rtl:address-expression? expression)
+ (rtl:make-address->environment expression)
+ expression))
+ (generate-offset-address expression offset scfg-append!
+ (lambda (expression)
+ (assign-to-temporary expression scfg-append!
+ (lambda (register)
+ (receiver (rtl:make-address->environment register)))))))))))
+\f
(define-expression-method 'FETCH
(lambda (receiver scfg-append! locative)
(locative-dereference locative scfg-append!
(lambda (receiver scfg-append! type car cdr)
(let ((free (interpreter-free-pointer)))
(let ((target (rtl:make-post-increment free 1)))
- (expression-simplify type scfg-append!
+ (expression-simplify* type scfg-append!
(lambda (type)
- (expression-simplify car scfg-append!
+ (expression-simplify* car scfg-append!
(lambda (car)
- (expression-simplify cdr scfg-append!
+ (expression-simplify* cdr scfg-append!
(lambda (cdr)
(assign-to-temporary (rtl:make-cons-pointer type free)
scfg-append!
(scfg-append! (%make-assign target cdr)
(receiver temporary)))))))))))))))
-(define-expression-method 'OBJECT->TYPE
+(define (object-selector make-object-selector)
(lambda (receiver scfg-append! expression)
- (expression-simplify expression scfg-append!
+ (expression-simplify* expression scfg-append!
(lambda (expression)
- (receiver (rtl:make-object->type expression))))))
+ (receiver (make-object-selector expression))))))
+
+(define-expression-method 'OBJECT->TYPE
+ (object-selector rtl:make-object->type))
+
+(define-expression-method 'OBJECT->DATUM
+ (object-selector rtl:make-object->datum))
+
+(define-expression-method 'OBJECT->ADDRESS
+ (object-selector rtl:make-object->address))
(define-expression-method 'CONS-POINTER
(lambda (receiver scfg-append! type datum)
- (expression-simplify type scfg-append!
+ (expression-simplify* type scfg-append!
(lambda (type)
- (expression-simplify datum scfg-append!
+ (expression-simplify* datum scfg-append!
(lambda (datum)
(receiver (rtl:make-cons-pointer type datum))))))))
;;; end EXPRESSION-SIMPLIFY package
-)
+)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 1.3 1987/09/03 05:16:17 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.1 1987/12/04 20:17:56 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (rtl:invocation? rtl)
+(define-integrable (rtl:invocation? rtl)
(memq (rtl:expression-type rtl)
'(INVOCATION:APPLY
INVOCATION:JUMP
INVOCATION:SPECIAL-PRIMITIVE
INVOCATION:UUO-LINK)))
+(define-integrable (rtl:trivial-expression? rtl)
+ (memq (rtl:expression-type rtl)
+ '(REGISTER
+ CONSTANT
+ ENTRY:CONTINUATION
+ ENTRY:PROCEDURE
+ UNASSIGNED
+ VARIABLE-CACHE)))
+
(define (rtl:machine-register-expression? expression)
(and (rtl:register? expression)
(machine-register? (rtl:register-number expression))))
(define (rtl:any-subexpression? expression predicate)
(and (not (rtl:constant? expression))
- ((there-exists?
- (lambda (x)
- (and (pair? x)
- (predicate x))))
- (cdr expression))))
+ (there-exists? (cdr expression)
+ (lambda (x)
+ (and (pair? x)
+ (predicate x))))))
(define (rtl:all-subexpressions? expression predicate)
(or (rtl:constant? expression)
- ((for-all?
- (lambda (x)
- (or (not (pair? x))
- (predicate x))))
- (cdr expression))))
+ (for-all? (cdr expression)
+ (lambda (x)
+ (or (not (pair? x))
+ (predicate x))))))
\f
(define (rtl:reduce-subparts expression operator initial if-expression if-not)
(let ((remap
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.1 1987/12/04 20:18:04 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Linearizer for CFG
+
+(declare (usual-integrations))
+
+;;; The linearizer attaches labels to nodes under two conditions. The
+;;; first is that the node in question has more than one previous
+;;; neighboring node. The other is when a conditional branch requires
+;;; such a label. It is assumed that if one encounters a node that
+;;; has already been linearized, that it has a label, since this
+;;; implies that it has more than one previous neighbor.
+\f
+;;;; RTL linearizer
+
+(package (bblock-linearize-rtl)
+
+(define-export (bblock-linearize-rtl bblock)
+ (node-mark! bblock)
+ (if (and (not (bblock-label bblock))
+ (node-previous>1? bblock))
+ (bblock-label! bblock))
+ (let ((kernel
+ (lambda ()
+ (let loop ((rinst (bblock-instructions bblock)))
+ (cond ((rinst-next rinst)
+ (cons (rinst-rtl rinst)
+ (loop (rinst-next rinst))))
+ ((sblock? bblock)
+ (cons (rinst-rtl rinst)
+ (linearize-sblock-next (snode-next bblock))))
+ (else
+ (linearize-pblock bblock
+ (rinst-rtl rinst)
+ (pnode-consequent bblock)
+ (pnode-alternative bblock))))))))
+ (if (bblock-label bblock)
+ `(,(rtl:make-label-statement (bblock-label bblock)) ,@(kernel))
+ (kernel))))
+
+(define (linearize-sblock-next bblock)
+ (cond ((not bblock) '())
+ ((node-marked? bblock)
+ `(,(rtl:make-jump-statement (bblock-label! bblock))))
+ (else (bblock-linearize-rtl bblock))))
+
+(define (linearize-pblock pblock predicate cn an)
+ (if (node-marked? cn)
+ (if (node-marked? an)
+ `(,(rtl:make-jumpc-statement predicate (bblock-label! cn))
+ ,(rtl:make-jump-statement (bblock-label! an)))
+ `(,(rtl:make-jumpc-statement predicate (bblock-label! cn))
+ ,@(bblock-linearize-rtl an)))
+ (if (node-marked? an)
+ `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate)
+ (bblock-label! an))
+ ,@(bblock-linearize-rtl cn))
+ (let ((label (bblock-label! cn))
+ (alternative (bblock-linearize-rtl an)))
+ `(,(rtl:make-jumpc-statement predicate label)
+ ,@alternative
+ ,@(if (node-marked? cn)
+ '()
+ (bblock-linearize-rtl cn)))))))
+
+)
+\f
+;;;; Linearizers
+
+(define (make-linearizer map-inst bblock-linearize)
+ (lambda (rgraphs)
+ (with-new-node-marks
+ (lambda ()
+ (map-inst (lambda (rgraph)
+ (map-inst (lambda (edge)
+ (let ((bblock (edge-right-node edge)))
+ (if (node-marked? bblock)
+ '()
+ (bblock-linearize bblock))))
+ (rgraph-entry-edges rgraph)))
+ rgraphs)))))
+
+(define linearize-rtl
+ (make-linearizer mapcan bblock-linearize-rtl))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.1 1987/12/04 20:18:09 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Register Transfer Language: Object Datatypes
+
+(declare (usual-integrations))
+\f
+(define-structure (rtl-expr
+ (conc-name rtl-expr/)
+ (constructor make-rtl-expr (rgraph label entry-edge))
+ (print-procedure
+ (standard-unparser 'RTL-EXPR
+ (lambda (expression)
+ (write (rtl-expr/label expression))))))
+ (rgraph false read-only true)
+ (label false read-only true)
+ (entry-edge false read-only true))
+
+(set-type-object-description!
+ rtl-expr
+ (lambda (expression)
+ `((RTL-EXPR/RGRAPH ,(rtl-expr/rgraph expression))
+ (RTL-EXPR/LABEL ,(rtl-expr/label expression))
+ (RTL-EXPR/ENTRY-EDGE ,(rtl-expr/entry-edge expression)))))
+
+(define-integrable (rtl-expr/entry-node expression)
+ (edge-right-node (rtl-expr/entry-edge expression)))
+\f
+(define-structure (rtl-procedure
+ (conc-name rtl-procedure/)
+ (constructor make-rtl-procedure
+ (rgraph label entry-edge n-required n-optional
+ rest? closure?))
+ (print-procedure
+ (standard-unparser 'RTL-PROCEDURE
+ (lambda (procedure)
+ (write (rtl-procedure/label procedure))))))
+ (rgraph false read-only true)
+ (label false read-only true)
+ (entry-edge false read-only true)
+ (n-required false read-only true)
+ (n-optional false read-only true)
+ (rest? false read-only true)
+ (closure? false read-only true))
+
+(set-type-object-description!
+ rtl-procedure
+ (lambda (procedure)
+ `((RTL-PROCEDURE/RGRAPH ,(rtl-procedure/rgraph procedure))
+ (RTL-PROCEDURE/LABEL ,(rtl-procedure/label procedure))
+ (RTL-PROCEDURE/ENTRY-EDGE ,(rtl-procedure/entry-edge procedure))
+ (RTL-PROCEDURE/N-REQUIRED ,(rtl-procedure/n-required procedure))
+ (RTL-PROCEDURE/N-OPTIONAL ,(rtl-procedure/n-optional procedure))
+ (RTL-PROCEDURE/REST? ,(rtl-procedure/rest? procedure))
+ (RTL-PROCEDURE/CLOSURE? ,(rtl-procedure/closure? procedure)))))
+
+(define-integrable (rtl-procedure/entry-node procedure)
+ (edge-right-node (rtl-procedure/entry-edge procedure)))
+\f
+(define-structure (rtl-continuation
+ (conc-name rtl-continuation/)
+ (constructor make-rtl-continuation
+ (rgraph label entry-edge))
+ (print-procedure
+ (standard-unparser 'RTL-CONTINUATION
+ (lambda (continuation)
+ (write (rtl-continuation/label continuation))))))
+ (rgraph false read-only true)
+ (label false read-only true)
+ (entry-edge false read-only true))
+
+(set-type-object-description!
+ rtl-continuation
+ (lambda (continuation)
+ `((RTL-CONTINUATION/RGRAPH ,(rtl-continuation/rgraph continuation))
+ (RTL-CONTINUATION/LABEL ,(rtl-continuation/label continuation))
+ (RTL-CONTINUATION/ENTRY-EDGE
+ ,(rtl-continuation/entry-edge continuation)))))
+
+(define-integrable (rtl-continuation/entry-node continuation)
+ (edge-right-node (rtl-continuation/entry-edge continuation)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 1.1 1987/03/19 00:44:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 4.1 1987/12/04 20:18:13 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define machine-register-map
- (make-vector number-of-machine-registers))
+(define *machine-register-map*)
-(let loop ((n 0))
- (if (< n number-of-machine-registers)
- (begin (vector-set! machine-register-map n (%make-register n))
- (loop (1+ n)))))
+(define (with-machine-register-map thunk)
+ (fluid-let ((*machine-register-map*
+ (let ((map (make-vector number-of-machine-registers)))
+ (let loop ((n 0))
+ (if (< n number-of-machine-registers)
+ (begin (vector-set! map n (%make-register n))
+ (loop (1+ n)))))
+ map)))
+ (thunk)))
(define-integrable (rtl:make-machine-register n)
- (vector-ref machine-register-map n))
+ (vector-ref *machine-register-map* n))
-(define *next-pseudo-number*)
-(define *temporary->register-map*)
+(define-integrable (machine-register? register)
+ (< register number-of-machine-registers))
+
+(define (for-each-machine-register procedure)
+ (let ((limit number-of-machine-registers))
+ (define (loop register)
+ (if (< register limit)
+ (begin (procedure register)
+ (loop (1+ register)))))
+ (loop 0)))
(define (rtl:make-pseudo-register)
- (let ((n *next-pseudo-number*))
- (set! *next-pseudo-number* (1+ *next-pseudo-number*))
+ (let ((n (rgraph-n-registers *current-rgraph*)))
+ (set-rgraph-n-registers! *current-rgraph* (1+ n))
(%make-register n)))
-(define (temporary->register temporary)
- (let ((entry (assq temporary *temporary->register-map*)))
- (if entry
- (cdr entry)
- (let ((register (rtl:make-pseudo-register)))
- (set! *temporary->register-map*
- (cons (cons temporary register)
- *temporary->register-map*))
- register))))
\ No newline at end of file
+(define-integrable (pseudo-register? register)
+ (>= register number-of-machine-registers))
+
+(define (for-each-pseudo-register procedure)
+ (let ((n-registers (rgraph-n-registers *current-rgraph*)))
+ (define (loop register)
+ (if (< register n-registers)
+ (begin (procedure register)
+ (loop (1+ register)))))
+ (loop number-of-machine-registers)))
+\f
+(let-syntax
+ ((define-register-references
+ (macro (slot)
+ (let ((name (symbol-append 'REGISTER- slot)))
+ (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)
+ (VECTOR-SET! ,vector REGISTER VALUE))))))))
+ (define-register-references bblock)
+ (define-register-references n-refs)
+ (define-register-references n-deaths)
+ (define-register-references live-length)
+ (define-register-references renumber))
+
+(define-integrable (reset-register-n-refs! register)
+ (set-register-n-refs! register 0))
+
+(define (increment-register-n-refs! register)
+ (set-register-n-refs! register (1+ (register-n-refs register))))
+
+(define-integrable (reset-register-n-deaths! register)
+ (set-register-n-deaths! register 0))
+
+(define (increment-register-n-deaths! register)
+ (set-register-n-deaths! register (1+ (register-n-deaths register))))
+
+(define-integrable (reset-register-live-length! register)
+ (set-register-live-length! register 0))
+
+(define (increment-register-live-length! register)
+ (set-register-live-length! register (1+ (register-live-length register))))
+
+(define (decrement-register-live-length! register)
+ (set-register-live-length! register (-1+ (register-live-length register))))
+
+(define-integrable (register-crosses-call? register)
+ (bit-string-ref (rgraph-register-crosses-call? *current-rgraph*) register))
+
+(define-integrable (register-crosses-call! register)
+ (bit-string-set! (rgraph-register-crosses-call? *current-rgraph*) register))
+
+(define-integrable (register-contains-address? register)
+ (memq register (rgraph-address-registers *current-rgraph*)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.14 1987/10/05 20:22:15 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.1 1987/12/04 20:18:20 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-rtl-expression pre-increment rtl: register number)
(define-rtl-expression post-increment rtl: register number)
+(define-rtl-expression assignment-cache rtl: name)
(define-rtl-expression cons-pointer rtl: type datum)
(define-rtl-expression constant % value)
(define-rtl-expression variable-cache rtl: name)
-(define-rtl-expression assignment-cache rtl: name)
-(define-rtl-expression entry:continuation % continuation)
-(define-rtl-expression entry:procedure % procedure)
+(define-rtl-expression entry:continuation rtl: continuation)
+(define-rtl-expression entry:procedure rtl: procedure)
(define-rtl-expression offset-address rtl: register number)
(define-rtl-expression unassigned rtl:)
(define-rtl-predicate unassigned-test % expression)
(define-rtl-statement assign % address expression)
-(define-rtl-statement continuation-heap-check % continuation)
-(define-rtl-statement procedure-heap-check % procedure)
-(define-rtl-statement return rtl:)
-(define-rtl-statement setup-lexpr % procedure)
+(define-rtl-statement continuation-heap-check rtl: continuation)
+(define-rtl-statement procedure-heap-check rtl: procedure)
+(define-rtl-statement setup-lexpr rtl: procedure)
+(define-rtl-statement pop-return rtl:)
(define-rtl-statement interpreter-call:access % environment name)
-(define-rtl-statement interpreter-call:cache-assignment % name value)
-(define-rtl-statement interpreter-call:cache-reference % name safe?)
-(define-rtl-statement interpreter-call:cache-unassigned? % name)
(define-rtl-statement interpreter-call:define % environment name value)
-(define-rtl-statement interpreter-call:enclose rtl: size)
(define-rtl-statement interpreter-call:lookup % environment name safe?)
(define-rtl-statement interpreter-call:set! % environment name value)
(define-rtl-statement interpreter-call:unassigned? % environment name)
(define-rtl-statement interpreter-call:unbound? % environment name)
-(define-rtl-statement invocation:apply % pushed prefix continuation)
-(define-rtl-statement invocation:cache-reference % pushed prefix continuation
+(define-rtl-statement interpreter-call:cache-assignment % name value)
+(define-rtl-statement interpreter-call:cache-reference % name safe?)
+(define-rtl-statement interpreter-call:cache-unassigned? % name)
+(define-rtl-statement interpreter-call:enclose rtl: size)
+
+(define-rtl-statement invocation:apply rtl: pushed continuation)
+(define-rtl-statement invocation:cache-reference rtl: pushed continuation name)
+(define-rtl-statement invocation:jump rtl: pushed continuation procedure)
+(define-rtl-statement invocation:lexpr rtl: pushed continuation procedure)
+(define-rtl-statement invocation:lookup rtl: pushed continuation environment
name)
-(define-rtl-statement invocation:jump % pushed prefix continuation procedure)
-(define-rtl-statement invocation:lexpr % pushed prefix continuation procedure)
-(define-rtl-statement invocation:lookup % pushed prefix continuation
- environment name)
-(define-rtl-statement invocation:primitive % pushed prefix continuation
+(define-rtl-statement invocation:primitive rtl: pushed continuation procedure)
+(define-rtl-statement invocation:special-primitive rtl: pushed continuation
procedure)
-(define-rtl-statement invocation:special-primitive % name pushed prefix
- continuation)
-(define-rtl-statement invocation:uuo-link % pushed prefix continuation name)
-
-(define-rtl-statement message-sender:value rtl: size)
-(define-rtl-statement message-receiver:closure rtl: size)
-(define-rtl-statement message-receiver:stack rtl: size)
-(define-rtl-statement message-receiver:subproblem % continuation)
\ No newline at end of file
+(define-rtl-statement invocation:uuo-link rtl: pushed continuation name)
+
+(define-rtl-statement invocation-prefix:move-frame-up rtl: frame-size locative)
+(define-rtl-statement invocation-prefix:dynamic-link rtl: frame-size locative)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 1.2 1987/07/19 21:34:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.1 1987/12/04 20:18:28 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-integrable rtl:address-register second)
(define-integrable rtl:address-number third)
(define-integrable rtl:invocation-pushed second)
-(define-integrable rtl:invocation-prefix third)
-(define-integrable rtl:invocation-continuation fourth)
+(define-integrable rtl:invocation-continuation third)
(define-integrable rtl:test-expression second)
-(define-integrable (rtl:make-entry:continuation continuation)
- (%make-entry:continuation (continuation-label continuation)))
-
-(define-integrable (rtl:make-entry:procedure procedure)
- (%make-entry:procedure (procedure-label procedure)))
-
-(define-integrable (rtl:make-continuation-heap-check continuation)
- (%make-continuation-heap-check (continuation-label continuation)))
-
-(define-integrable (rtl:make-procedure-heap-check procedure)
- (%make-procedure-heap-check (procedure-label procedure)))
-
-(define-integrable (rtl:make-setup-lexpr procedure)
- (%make-setup-lexpr (procedure-label procedure)))
-
-(define-integrable (rtl:make-message-receiver:subproblem continuation)
- (%make-message-receiver:subproblem (continuation-label continuation)))
-
(define (rtl:make-constant value)
(if (scode/unassigned-object? value)
(rtl:make-unassigned)
(define-integrable register:environment
'ENVIRONMENT)
-(define-integrable register:frame-pointer
- 'FRAME-POINTER)
-
(define-integrable register:stack-pointer
'STACK-POINTER)
+(define-integrable register:dynamic-link
+ 'DYNAMIC-LINK)
+
(define-integrable register:value
'VALUE)
\f
;;; Expressions that are used in the intermediate form.
-(define-integrable (rtl:make-fetch locative)
- `(FETCH ,locative))
-
(define-integrable (rtl:make-address locative)
`(ADDRESS ,locative))
+(define-integrable (rtl:make-environment locative)
+ `(ENVIRONMENT ,locative))
+
(define-integrable (rtl:make-cell-cons expression)
`(CELL-CONS ,expression))
+(define-integrable (rtl:make-fetch locative)
+ `(FETCH ,locative))
+
(define-integrable (rtl:make-typed-cons:pair type car cdr)
`(TYPED-CONS:PAIR ,type ,car ,cdr))
projects / mit-scheme.git / commitdiff