#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.8 1988/11/04 10:28:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.9 1988/12/12 21:52:53 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
;;;; Assignments
(define (generate/assignment assignment)
- (let ((block (assignment-block assignment))
+ (let ((context (assignment-context assignment))
(lvalue (assignment-lvalue assignment))
- (rvalue (assignment-rvalue assignment))
- (offset (node/offset assignment)))
+ (rvalue (assignment-rvalue assignment)))
(if (lvalue-integrated? lvalue)
(make-null-cfg)
- (generate/rvalue rvalue offset scfg*scfg->scfg!
+ (generate/rvalue rvalue scfg*scfg->scfg!
(lambda (expression)
- (find-variable block lvalue offset
+ (find-variable context lvalue
(lambda (locative)
(rtl:make-assignment locative expression))
(lambda (environment name)
(rtl:make-interpreter-call:set!
environment
- (intern-scode-variable! block name)
+ (intern-scode-variable! (reference-context/block context)
+ name)
expression))
(lambda (name)
(if (memq 'IGNORE-ASSIGNMENT-TRAPS
(scfg-next-hooks n6)))))))))
(define (generate/definition definition)
- (let ((block (definition-block definition))
+ (let ((context (definition-context definition))
(lvalue (definition-lvalue definition))
- (rvalue (definition-rvalue definition))
- (offset (node/offset definition)))
- (generate/rvalue rvalue offset scfg*scfg->scfg!
+ (rvalue (definition-rvalue definition)))
+ (generate/rvalue rvalue scfg*scfg->scfg!
(lambda (expression)
- (transmit-values (find-definition-variable block lvalue offset)
+ (with-values (lambda () (find-definition-variable context lvalue))
(lambda (environment name)
(rtl:make-interpreter-call:define environment
name
(define (generate/virtual-return return)
(let ((operator (virtual-return-operator return))
- (operand (virtual-return-operand return))
- (offset (node/offset return)))
+ (operand (virtual-return-operand return)))
(if (virtual-continuation/reified? operator)
- (generate/trivial-return (virtual-return-block return)
+ (generate/trivial-return (virtual-return-context return)
(virtual-continuation/reification operator)
- operand
- offset)
- (enumeration-case continuation-type
- (virtual-continuation/type operator)
- ((EFFECT)
- (make-null-cfg))
- ((REGISTER VALUE)
- (operand->register operand
- offset
- (virtual-continuation/register operator)))
- ((PUSH)
- (let ((block (virtual-continuation/block operator)))
+ operand)
+ ;; Special case for static links. These should be handled
+ ;; using the general mechanism in rgrval, except that there
+ ;; must be a block reference object, distinct from the block
+ ;; itself, that contains the context of the reference. It was
+ ;; a mistake to make blocks be rvalues in the first place.
+ (let ((static-link-reference
+ (lambda ()
+ (rtl:make-environment
+ (block-ancestor-or-self->locative
+ (virtual-continuation/context operator)
+ operand
+ 0
+ 0)))))
+ (enumeration-case continuation-type
+ (virtual-continuation/type operator)
+ ((EFFECT)
+ (make-null-cfg))
+ ((REGISTER VALUE)
+ (let ((register (virtual-continuation/register operator)))
+ (if (rvalue/block? operand)
+ (rtl:make-assignment register (static-link-reference))
+ (operand->register operand register))))
+ ((PUSH)
(cond ((rvalue/block? operand)
- (rtl:make-push
- (rtl:make-environment
- (block-ancestor-or-self->locative block
- operand
- offset))))
+ (rtl:make-push (static-link-reference)))
((rvalue/continuation? operand)
;; This is a pun set up by the FG generator.
- (generate/continuation-cons block operand))
+ (generate/continuation-cons operand))
(else
- (operand->push operand offset)))))
- (else
- (error "Unknown continuation type" return))))))
+ (operand->push operand))))
+ (else
+ (error "Unknown continuation type" return)))))))
-(define (operand->push operand offset)
- (generate/rvalue operand offset scfg*scfg->scfg! rtl:make-push))
+(define (operand->push operand)
+ (generate/rvalue operand scfg*scfg->scfg! rtl:make-push))
-(define (operand->register operand offset register)
- (generate/rvalue operand offset scfg*scfg->scfg!
+(define (operand->register operand register)
+ (generate/rvalue operand scfg*scfg->scfg!
(lambda (expression)
(rtl:make-assignment register expression))))
(let ((setup (rtl:make-assignment temporary expression)))
(receiver setup (generator (rtl:make-fetch temporary))))))
-(define (generate/continuation-cons block continuation)
- block
+(define (generate/continuation-cons continuation)
(let ((closing-block (continuation/closing-block continuation)))
(scfg-append!
(if (ic-block? closing-block)
(begin
(enqueue-continuation! continuation)
(rtl:make-push-return (continuation/label continuation)))))))
-
+\f
(define (generate/pop pop)
(rtl:make-pop (continuation*/register (pop-continuation pop))))
+
+(define (generate/stack-overwrite stack-overwrite)
+ (let ((locative
+ (stack-overwrite-locative (stack-overwrite-context stack-overwrite)
+ (stack-overwrite-target stack-overwrite)))
+ (continuation (stack-overwrite-continuation stack-overwrite)))
+ (enumeration-case continuation-type (continuation*/type continuation)
+ ((REGISTER)
+ (let ((simple
+ (lambda ()
+ (rtl:make-assignment
+ locative
+ (rtl:make-fetch (continuation*/register continuation))))))
+ (if (procedure? continuation)
+ (let ((lvalue (continuation/parameter continuation)))
+ (if (lvalue-integrated? lvalue)
+ (generate/rvalue (lvalue-known-value lvalue)
+ scfg*scfg->scfg!
+ (lambda (expression)
+ (rtl:make-assignment locative expression)))
+ (simple)))
+ (simple))))
+ ((PUSH)
+ (rtl:make-pop locative))
+ (else
+ (error "Unknown continuation type" continuation)))))
+
+(define (stack-overwrite-locative context target)
+ (cond ((variable? target)
+ (find-closure-variable context target))
+ ((block? target)
+ (block-ancestor-or-self->locative
+ context
+ target
+ 0
+ (let ((procedure (block-procedure target)))
+ (if (procedure/closure? procedure)
+ (procedure-closure-offset procedure)
+ (-1+ (block-frame-size target))))))
+ (else
+ (error "Unknown target type" target))))
\f
;;;; Predicates
(define (generate/true-test true-test)
(generate/predicate (true-test-rvalue true-test)
(pnode-consequent true-test)
- (pnode-alternative true-test)
- (node/offset true-test)))
+ (pnode-alternative true-test)))
-(define (generate/predicate rvalue consequent alternative offset)
+(define (generate/predicate rvalue consequent alternative)
(if (rvalue/unassigned-test? rvalue)
- (generate/unassigned-test rvalue consequent alternative offset)
+ (generate/unassigned-test rvalue consequent alternative)
(let ((value (rvalue-known-value rvalue)))
(if value
(generate/known-predicate value consequent alternative)
(pcfg*scfg->scfg!
- (generate/rvalue rvalue offset scfg*pcfg->pcfg!
+ (generate/rvalue rvalue scfg*pcfg->pcfg!
rtl:make-true-test)
(generate/node consequent)
(generate/node alternative))))))
(generate/node (if (and (constant? value) (false? (constant-value value)))
alternative
consequent)))
-\f
-(define (generate/unassigned-test rvalue consequent alternative offset)
- (let ((block (unassigned-test-block rvalue))
- (lvalue (unassigned-test-lvalue rvalue)))
+
+(define (generate/unassigned-test rvalue consequent alternative)
+ (let ((lvalue (unassigned-test-lvalue rvalue)))
(let ((value (lvalue-known-value lvalue)))
(cond ((not value)
(pcfg*scfg->scfg!
- (find-variable block lvalue offset
+ (find-variable (unassigned-test-context rvalue) lvalue
(lambda (locative)
(rtl:make-unassigned-test (rtl:make-fetch locative)))
(lambda (environment name)
projects / mit-scheme.git / commitdiff