From 1b8124a7d4e5b89e7fde9deeeff8335d063ddc13 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 12 Dec 1988 21:52:53 +0000 Subject: [PATCH] Block->context changes. Improve handling of static links. New type: stack-overwrite. --- v7/src/compiler/rtlgen/rgstmt.scm | 150 +++++++++++++++++++----------- 1 file changed, 97 insertions(+), 53 deletions(-) diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index 051083c46..5769e409e 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -39,21 +39,21 @@ MIT in each case. |# ;;;; 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 @@ -86,13 +86,12 @@ MIT in each case. |# (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 @@ -102,42 +101,49 @@ MIT in each case. |# (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)))) @@ -152,8 +158,7 @@ MIT in each case. |# (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) @@ -167,26 +172,66 @@ MIT in each case. |# (begin (enqueue-continuation! continuation) (rtl:make-push-return (continuation/label continuation))))))) - + (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)))) ;;;; 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)))))) @@ -195,14 +240,13 @@ MIT in each case. |# (generate/node (if (and (constant? value) (false? (constant-value value))) alternative consequent))) - -(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) -- 2.25.1