From: Chris Hanson Date: Mon, 12 Dec 1988 21:52:15 +0000 (+0000) Subject: * Move everything except the core block search stuff to another file. X-Git-Tag: 20090517-FFI~12376 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d063ae5d8af88f1ae97d9c31d1f325af8e21ad69;p=mit-scheme.git * Move everything except the core block search stuff to another file. * Update to use reference contexts. --- diff --git a/v7/src/compiler/rtlgen/fndblk.scm b/v7/src/compiler/rtlgen/fndblk.scm index 84372738b..f460c50dc 100644 --- a/v7/src/compiler/rtlgen/fndblk.scm +++ b/v7/src/compiler/rtlgen/fndblk.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.9 1988/11/01 04:53:37 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.10 1988/12/12 21:52:15 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -36,162 +36,39 @@ MIT in each case. |# (declare (usual-integrations)) -(define (find-variable start-block variable offset if-compiler if-ic if-cached) - (if (variable/value-variable? variable) - (if-compiler - (let ((continuation (block-procedure start-block))) - (if (continuation/ever-known-operator? continuation) - (continuation/register continuation) - register:value))) - (find-variable-internal start-block variable offset - (lambda (locative) - (if-compiler - (if (variable-in-cell? variable) - (rtl:make-fetch locative) - locative))) - (lambda (block locative) - (cond ((variable-in-known-location? start-block variable) - (if-compiler - (rtl:locative-offset locative - (variable-offset block variable)))) - ((ic-block/use-lookup? block) - (if-ic locative (variable-name variable))) - (else - (if-cached (variable-name variable)))))))) - -(define (find-known-variable block variable offset) - (find-variable block variable offset identity-procedure - (lambda (environment name) - environment - (error "Known variable found in IC frame" name)) - (lambda (name) - (error "Known variable found in IC frame" name)))) - -(define (find-closure-variable block variable offset) - (find-variable-internal block variable offset - identity-procedure - (lambda (block locative) - block locative - (error "Closure variable in IC frame" variable)))) - -(define (find-variable-internal block variable offset if-compiler if-ic) - (let ((rvalue (lvalue-known-value variable))) - (cond ((not - (and rvalue - (rvalue/procedure? rvalue) - (procedure/closure? rvalue) - (block-ancestor-or-self? block (procedure-block rvalue)))) - (find-block/variable block variable offset - (lambda (offset-locative) - (lambda (block locative) - (if-compiler - (offset-locative locative (variable-offset block variable))))) - if-ic)) - ;; This is just for paranoia. - ((procedure/trivial-closure? rvalue) - (error "FIND-VARIABLE-INTERNAL: Trivial closure value encountered")) - (else - (if-compiler - (stack-locative-offset - (block-ancestor-or-self->locative block - (procedure-block rvalue) - offset) - (procedure-closure-offset rvalue))))))) - -(define (find-definition-variable block lvalue offset) - (find-block/variable block lvalue offset - (lambda (offset-locative) - offset-locative - (lambda (block locative) - block locative - (error "Definition of compiled variable" lvalue))) - (lambda (block locative) - block - (return-2 locative (variable-name lvalue))))) - -(define (find-block/variable block variable offset if-known if-ic) - (find-block block - offset - (lambda (block) - (if block - (or (memq variable (block-bound-variables block)) - (and (not (block-parent block)) - (memq variable (block-free-variables block)))) - (error "Unable to find variable" variable))) - (lambda (block locative) - ((enumeration-case block-type (block-type block) - ((STACK) (if-known stack-locative-offset)) - ((CLOSURE) (if-known rtl:locative-offset)) - ((IC) if-ic) - (else (error "Illegal result type" block))) - block locative)))) - -(define (nearest-ic-block-expression block offset) - (find-block block offset (lambda (block) (not (block-parent block))) - (lambda (block locative) - (if (ic-block? block) - locative - (error "NEAREST-IC-BLOCK-EXPRESSION: No IC block"))))) - -(define (closure-ic-locative closure-block block offset) - (find-block closure-block offset (lambda (block*) (eq? block* block)) - (lambda (block locative) - (if (ic-block? block) - locative - (error "Closure parent not IC block"))))) - -(define (block-ancestor-or-self->locative block block* offset) - (find-block block offset (lambda (block) (eq? block block*)) - (lambda (block locative) - (if (eq? block block*) - locative - (error "Block is not an ancestor" block*))))) - -(define (popping-limit/locative block offset block* extra) - (rtl:make-address - (stack-locative-offset (block-ancestor-or-self->locative block - block* - offset) - (+ extra (block-frame-size block*))))) - -(define (block-closure-locative block offset) - ;; BLOCK must be the invocation block of a closure. - (stack-locative-offset (rtl:make-fetch register:stack-pointer) - (+ (procedure-closure-offset (block-procedure block)) - offset))) - -(package (find-block) - -(define-export (find-block block offset end-block? receiver) - (transmit-values - (find-block/loop block end-block? (find-block/initial block offset)) - receiver)) - -(define (find-block/initial block offset) - (if (null? block) - (begin - (error "find-block/initial: Null block!" block) - (rtl:make-fetch register:environment)) - (enumeration-case block-type (block-type block) - ((STACK) - (stack-locative-offset (rtl:make-fetch register:stack-pointer) offset)) - ((IC) - (rtl:make-fetch register:environment)) - (else - (error "Illegal initial block type" block))))) - -(define (find-block/loop block end-block? locative) +(define (find-block context extra-offset end-block?) + (find-block/loop (reference-context/block context) + context + end-block? + (find-block/initial context extra-offset))) + +(define (find-block/initial context extra-offset) + (let ((block (reference-context/block context))) + (if (not block) + (error "find-block/initial: Null block!" block)) + (enumeration-case block-type (block-type block) + ((STACK) + (stack-locative-offset (rtl:make-fetch register:stack-pointer) + (+ extra-offset + (reference-context/offset context)))) + ((IC) + (rtl:make-fetch register:environment)) + (else + (error "Illegal initial block type" block))))) + +(define (find-block/loop block context end-block? locative) (cond ((null? block) (error "find-block/loop: Null block!" block) - (return-2 block locative)) + (values block locative)) ((or (end-block? block) (ic-block? block)) - (return-2 block locative)) + (values block locative)) (else - (find-block/loop (block-parent block) - end-block? - ((find-block/parent-procedure block) - block locative))))) + (find-block/loop + (block-parent block) + context + end-block? + ((find-block/parent-procedure block) block context locative))))) (define (find-block/parent-procedure block) (enumeration-case block-type (block-type block) @@ -228,57 +105,57 @@ MIT in each case. |# ((CLOSURE) closure-block/parent-locative) ((CONTINUATION) continuation-block/parent-locative) (else (error "Illegal parent block type" block)))) - -(define (find-block/same-block? block) - (lambda (block*) - (eq? block block*))) - -(define (find-block/specific start-block end-block locative) - (transmit-values - (find-block/loop start-block (find-block/same-block? end-block) locative) - (lambda (end-block locative) - end-block - locative))) -(define (internal-block/parent-locative block locative) +(define (internal-block/parent-locative block context locative) (let ((link (block-stack-link block))) (if link - (find-block/specific - link - (block-parent block) - (stack-locative-offset locative (block-frame-size block))) - (stack-block/static-link-locative block locative)))) - -(define (continuation-block/parent-locative block locative) + (let ((end-block? + (let ((end-block (block-parent block))) + (lambda (block) (eq? block end-block))))) + (with-values + (lambda () + (find-block/loop + link + context + end-block? + (stack-locative-offset locative (block-frame-size block)))) + (lambda (end-block locative) + (if (not (end-block? end-block)) + (error "Couldn't find internal block parent!" block)) + locative))) + (stack-block/static-link-locative block context locative)))) + +(define (continuation-block/parent-locative block context locative) + context (stack-locative-offset locative (+ (block-frame-size block) (continuation/offset (block-procedure block))))) -(define (stack-block/static-link-locative block locative) - (rtl:make-fetch - (stack-locative-offset locative (-1+ (block-frame-size block))))) +(define (stack-block/static-link-locative block context locative) + (if (reference-context/adjacent-parent? context block) + (stack-locative-offset locative (block-frame-size block)) + (rtl:make-fetch + (stack-locative-offset locative (-1+ (block-frame-size block)))))) -(define (stack-block/closure-parent-locative block locative) +(define (stack-block/closure-parent-locative block context locative) + context (rtl:make-fetch (stack-locative-offset locative (procedure-closure-offset (block-procedure block))))) -;; This value should make anyone trying to look at it crash. - -(define (trivial-closure/bogus-locative block locative) - block locative +(define (trivial-closure/bogus-locative block context locative) + block context locative + ;; This value should make anyone trying to look at it crash. 'TRIVIAL-CLOSURE-BOGUS-LOCATIVE) -(define (closure-block/parent-locative block locative) - block +(define (closure-block/parent-locative block context locative) + block context (rtl:make-fetch - (rtl:locative-offset locative - closure-block-first-offset))) + (rtl:locative-offset locative closure-block-first-offset))) -(define (stack-block/parent-of-dummy-closure-locative block locative) +(define (stack-block/parent-of-dummy-closure-locative block context locative) (closure-block/parent-locative block - (stack-block/closure-parent-locative block locative))) - -) \ No newline at end of file + context + (stack-block/closure-parent-locative block context locative))) \ No newline at end of file