#| -*-Scheme-*-
-$Id: uenvir.scm,v 14.35 1995/02/09 21:23:49 adams Exp $
+$Id: uenvir.scm,v 14.36 1995/07/27 21:11:41 adams Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1995 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (environment? object)
(or (system-global-environment? object)
(ic-environment? object)
- (stack-ccenv? object)
- (closure-ccenv? object)))
+ (ccenv? object)))
(define (environment-has-parent? environment)
(cond ((system-global-environment? environment)
false)
((ic-environment? environment)
(ic-environment/has-parent? environment))
- ((stack-ccenv? environment)
- (stack-ccenv/has-parent? environment))
- ((closure-ccenv? environment)
- (closure-ccenv/has-parent? environment))
- (else (error "Illegal environment" environment))))
+ ((ccenv? environment)
+ (ccenv/has-parent? environment))
+ (else (illegal-environment environment 'ENVIRONMENT-HAS-PARENT?))))
(define (environment-parent environment)
(cond ((system-global-environment? environment)
(error "Global environment has no parent" environment))
((ic-environment? environment)
(ic-environment/parent environment))
- ((stack-ccenv? environment)
- (stack-ccenv/parent environment))
- ((closure-ccenv? environment)
- (closure-ccenv/parent environment))
- (else (error "Illegal environment" environment))))
+ ((ccenv? environment)
+ (ccenv/parent environment))
+ (else (illegal-environment environment 'ENVIRONMENT-PARENT))))
(define (environment-bound-names environment)
(cond ((system-global-environment? environment)
(system-global-environment/bound-names environment))
((ic-environment? environment)
(ic-environment/bound-names environment))
- ((stack-ccenv? environment)
- (stack-ccenv/bound-names environment))
- ((closure-ccenv? environment)
- (closure-ccenv/bound-names environment))
- (else (error "Illegal environment" environment))))
+ ((ccenv? environment)
+ (ccenv/bound-names environment))
+ (else (illegal-environment environment 'ENVIRONMENT-BOUND-NAMES))))
(define (environment-bindings environment)
(map (lambda (name)
'()
(list value)))))
(environment-bound-names environment)))
-\f
+
(define (environment-arguments environment)
- (cond ((ic-environment? environment)
- (ic-environment/arguments environment))
- ((stack-ccenv? environment)
- (stack-ccenv/arguments environment))
- ((or (system-global-environment? environment)
- (closure-ccenv? environment))
+ (cond ((system-global-environment? environment)
'UNKNOWN)
- (else (error "Illegal environment" environment))))
-
+ ((ic-environment? environment)
+ (ic-environment/arguments environment))
+ ((ccenv? environment)
+ (ccenv/arguments environment))
+ (else (illegal-environment environment 'ENVIRONMENT-ARGUMENTS))))
+\f
(define (environment-procedure-name environment)
(let ((scode-lambda (environment-lambda environment)))
(and scode-lambda
false)
((ic-environment? environment)
(ic-environment/lambda environment))
- ((stack-ccenv? environment)
- (stack-ccenv/lambda environment))
- ((closure-ccenv? environment)
- (closure-ccenv/lambda environment))
- (else (error "Illegal environment" environment))))
+ ((ccenv? environment)
+ (ccenv/lambda environment))
+ (else (illegal-environment environment 'ENVIRONMENT-LAMBDA))))
(define (environment-bound? environment name)
(cond ((interpreter-environment? environment)
(interpreter-environment/bound? environment name))
- ((stack-ccenv? environment)
- (stack-ccenv/bound? environment name))
- ((closure-ccenv? environment)
- (closure-ccenv/bound? environment name))
- (else (error "Illegal environment" environment))))
+ ((ccenv? environment)
+ (ccenv/bound? environment name))
+ (else (illegal-environment environment 'ENVIRONMENT-BOUND?))))
(define (environment-lookup environment name)
(cond ((interpreter-environment? environment)
(interpreter-environment/lookup environment name))
- ((stack-ccenv? environment)
- (stack-ccenv/lookup environment name))
- ((closure-ccenv? environment)
- (closure-ccenv/lookup environment name))
- (else (error "Illegal environment" environment))))
+ ((ccenv? environment)
+ (ccenv/lookup environment name))
+ (else (illegal-environment environment 'ENVIRONMENT-LOOKUP))))
(define (environment-assignable? environment name)
(cond ((interpreter-environment? environment)
true)
- ((stack-ccenv? environment)
- (stack-ccenv/assignable? environment name))
- ((closure-ccenv? environment)
- (closure-ccenv/assignable? environment name))
- (else (error "Illegal environment" environment))))
+ ((ccenv? environment)
+ (ccenv/assignable? environment name))
+ (else (illegal-environment environment 'ENVIRONMENT-ASSIGNABLE?))))
(define (environment-assign! environment name value)
(cond ((interpreter-environment? environment)
(interpreter-environment/assign! environment name value))
- ((stack-ccenv? environment)
- (stack-ccenv/assign! environment name value))
- ((closure-ccenv? environment)
- (closure-ccenv/assign! environment name value))
- (else (error "Illegal environment" environment))))
+ ((ccenv? environment)
+ (ccenv/assign! environment name value))
+ (else (illegal-environment environment 'ENVIRONMENT-ASSIGN!))))
+
+(define (illegal-environment object procedure)
+ (error:wrong-type-argument object "environment" procedure))
\f
;;;; Interpreter Environments
(extension-names external parameters))))
(lambda (name)
(unbound-name? environment name))))
-
+\f
(define (unbound-name? environment name)
(if (eq? name package-name-tag)
true
(lexical-unbound? environment name)))
-\f
+
(define (ic-environment/arguments environment)
(lambda-components* (ic-environment/lambda environment)
(lambda (name required optional rest body)
(ic-environment/set-parent! environment null-environment))
-;; This corresponds to the #defines in sdata.h
+;; This corresponds to the `#define END_OF_CHAIN ...' in sdata.h
(define null-environment
(object-new-type (object-type #F)
(fix:xor (object-datum #F) 1)))
-;;(define null-environment
-;; (object-new-type (ucode-type null) 1))
-
(define (make-null-interpreter-environment)
(let ((environment (let () (the-environment))))
(ic-environment/remove-parent! environment)
\f
;;;; Compiled Code Environments
-(define-structure (stack-ccenv
+(define-structure (ccenv
(type vector)
(named
((ucode-primitive string->symbol)
- "#[(runtime environment)stack-ccenv]"))
- (conc-name stack-ccenv/))
+ "#[(runtime environment)ccenv]"))
+ (conc-name ccenv/))
+ ;; BLOCK is a block structure description (a DBG-BLOCK).
(block false read-only true)
- (frame false read-only true)
- (start-index false read-only true))
+ ;; ROOT is the object from which to de-reference access paths, usually a
+ ;; STACK-FRAME or a compiled closure.
+ (root false read-only true))
+
+(define (ccenv/has-parent? env)
+ (let ((block (ccenv/block env)))
+ (and (dbg-block/parent block)
+ #T)))
+
+(define (ccenv/parent env)
+ (let ((block (ccenv/block env))
+ (root (ccenv/root env)))
+ (let ((parent (dbg-block/parent block))
+ (p-path (dbg-block/parent-path-prefix block)))
+ (let ((root* (if p-path
+ (lookup-path p-path root #F)
+ root)))
+ (cond ((eq? parent 'IC)
+ (guarantee-interpreter-environment root*))
+ (else
+ (make-ccenv parent root*)))))))
+
+(define (ccenv/bound-names environment)
+ (map dbg-variable/name
+ (list-transform-positive
+ (vector->list
+ (dbg-block/variables (ccenv/block environment)))
+ (lambda (thing)
+ (and (dbg-variable? thing)
+ (ccenv/path-bound? environment (dbg-variable/path thing)))))))
+
+(define (ccenv/bound? environment name)
+ (let* ((block (ccenv/block environment))
+ (variable (dbg-block/find-variable block name)))
+ (and variable
+ (ccenv/path-bound? environment (dbg-variable/path variable)))))
+
+(define (ccenv/path-bound? environment path)
+ ;; Some paths are only valid from an interrupt frame. The same block is
+ ;; used for the interrupt frame of a continuation and the
+ ;; (pre-invocation) frame.
+ (or (let ((root (ccenv/root environment)))
+ (and (stack-frame? root)
+ (stack-frame/compiled-interrupt? root)))
+ (not (interrupt-frame-path? path))))
+
+(define (ccenv/lookup environment name)
+ (lookup-path (ccenv/find-bound-path environment name)
+ (ccenv/root environment)
+ #F))
+\f
+(define (ccenv/assignable? environment name)
+ (let* ((block (ccenv/block environment))
+ (var (dbg-block/find-variable block name)))
+ (and var
+ (assignable-path? (dbg-variable/path var)))))
+
+(define (ccenv/assign! environment name value)
+ (assign-path! (ccenv/find-bound-path environment name)
+ (ccenv/root environment)
+ name
+ value))
+
+(define (ccenv/arguments environment)
+ ;; Try to piece together the original arguments, taking into account
+ ;; unassigned optionals and unavailable values.
+ (let* ((block (ccenv/block environment))
+ (source (dbg-block/source-code block)))
+ (if (lambda? source)
+ (let ((lookup
+ (lambda (name)
+ (if (ccenv/bound? environment name)
+ (ccenv/lookup environment name)
+ unavailable-object))))
+ (lambda-components source
+ (lambda (name required optional rest auxiliary decl body)
+ name auxiliary decl body
+ (let ((required* (map lookup required))
+ (optional* (map lookup optional))
+ (rest* (if rest (lookup rest) '())))
+ (define (known)
+ (append required* optional* rest*))
+ (cond ((and (not *allow-unavailable-environment-arguments*)
+ (or (there-exists? required* unavailable?)
+ (there-exists? optional* unavailable?)
+ (unavailable? rest*)))
+ 'UNKNOWN)
+ ((pair? rest*) (known))
+ ((null? optional) (known))
+ (else
+ (let loop ((opts (reverse optional*)) (next #F))
+ (cond ((null? opts)
+ (if (unavailable? next)
+ 'UNKNOWN
+ required*))
+ ((unassigned-reference-trap? (car opts))
+ (loop (cdr opts) (car opts)))
+ ((unavailable? (car opts))
+ (loop (cdr opts) (car opts)))
+ ((unavailable? next)
+ 'UNKNOWN)
+ (else
+ (append required* (reverse opts)))))))))))
+ 'UNKNOWN)))
-(define (stack-frame/environment frame default)
- (let* ((ret-add (stack-frame/return-address frame))
- (object (compiled-entry/dbg-object ret-add)))
+(define *allow-unavailable-environment-arguments* #T)
+\f
+(define unavailable-object (string->symbol "??"))
+
+(define (unavailable? thing)
+ (eq? thing unavailable-object))
+
+(define (ccenv/lambda environment)
+ (dbg-block/source-code (ccenv/block environment)))
+
+(define (ccenv/find-bound-path environment name)
+ (let* ((block (ccenv/block environment))
+ (var (dbg-block/find-variable block name)))
+ (if var
+ (dbg-variable/path var)
+ ((condition-signaller condition-type:unbound-variable
+ '(ENVIRONMENT LOCATION)
+ standard-error-handler)
+ environment name))))
+
+(define (stack-frame/environment frame entry default)
+ (let* ((object (compiled-entry/dbg-object entry)))
(cond ((not object)
default)
((dbg-continuation? object)
- (let ((block (dbg-continuation/block object)))
- (let ((parent (dbg-block/parent block)))
- (case (dbg-block/type parent)
- ((STACK)
- (make-stack-ccenv parent
- frame
- (+ (dbg-continuation/offset object)
- (dbg-block/length block))))
- ((IC)
- (let ((index (dbg-block/ic-parent-index block)))
- (if index
- (guarantee-interpreter-environment
- (stack-frame/ref frame index))
- default)))
- (else
- (error "Illegal continuation parent block" parent))))))
+ (make-ccenv (dbg-continuation/block object) frame))
((dbg-procedure? object)
- (let ((block (dbg-procedure/block object)))
- (case (dbg-block/type block)
- ((STACK)
- (make-stack-ccenv
- block
- frame
- (if (compiled-closure? ret-add)
- 0
- 1)))
- (else
- (error "Illegal procedure block" block)))))
- #|
+ (let ((invocation-block (dbg-procedure/block object)))
+ (if (stack-frame/compiled-interrupt? frame)
+ (make-ccenv invocation-block frame)
+ (error "Non-interrupt procedure frame" entry frame))))
+ #| ;
((dbg-expression? object)
;; for now
default)
(define (compiled-procedure/environment entry)
(if (not (compiled-procedure? entry))
- (error "Not a compiled procedure" entry
- 'COMPILED-PROCEDURE/ENVIRONMENT))
+ (error "Not a compiled procedure" entry 'COMPILED-PROCEDURE/ENVIRONMENT))
(let ((procedure (compiled-entry/dbg-object entry)))
(if (not procedure)
(error "Unable to obtain closing environment" entry))
- (let ((block (dbg-procedure/block procedure)))
- (if (not block)
+ (let ((invocation-block (dbg-procedure/block procedure)))
+ (if (not invocation-block)
(error "Unable to obtain closing environment (missing block info)"
entry))
- (let ((parent (dbg-block/parent block)))
- (define (use-compile-code-block-environment)
- (guarantee-interpreter-environment
- (compiled-code-block/environment
- (compiled-code-address->block entry))))
- (if parent
- (case (dbg-block/type parent)
- ((CLOSURE)
- (make-closure-ccenv (dbg-block/original-parent block)
- parent
- entry))
- ((IC)
- (use-compile-code-block-environment))
+ (let ((parent (dbg-block/parent invocation-block)))
+ (cond ((and (eq? parent 'IC)
+ (equal? (dbg-block/parent-path-prefix invocation-block)
+ '((TOP-LEVEL-ENVIRONMENT))))
+ (guarantee-interpreter-environment
+ (compiled-code-block/environment
+ (compiled-code-address->block entry))))
+ ((compiled-closure? entry)
+ (make-ccenv parent entry))
(else
- (error "Illegal procedure parent block" parent)))
- ;; This happens when the procedure has no free variables:
- (use-compile-code-block-environment))))))
+ (error "Illegal procedure parent block" parent)))))))
\f
-(define (stack-ccenv/has-parent? environment)
- (if (dbg-block/parent (stack-ccenv/block environment))
- true
- 'SIMULATED))
-
-(define (stack-ccenv/parent environment)
- (let ((block (stack-ccenv/block environment)))
- (let ((parent (dbg-block/parent block)))
- (if parent
- (case (dbg-block/type parent)
- ((STACK)
- (let loop
- ((block block)
- (frame (stack-ccenv/frame environment))
- (index
- (+ (stack-ccenv/start-index environment)
- (dbg-block/length block))))
- (let ((stack-link (dbg-block/stack-link block)))
- (cond ((not stack-link)
- (with-values
- (lambda ()
- (stack-frame/resolve-stack-address
- frame
- (stack-ccenv/static-link environment)))
- (lambda (frame index)
- (let ((block (dbg-block/parent block)))
- (if (eq? block parent)
- (make-stack-ccenv parent frame index)
- (loop block frame index))))))
- ((eq? stack-link parent)
- (make-stack-ccenv parent frame index))
- (else
- (loop stack-link
- frame
- (+ (vector-length
- (dbg-block/layout-vector stack-link))
- (case (dbg-block/type stack-link)
- ((STACK)
- 0)
- ((CONTINUATION)
- (dbg-continuation/offset
- (dbg-block/procedure stack-link)))
- (else
- (error "illegal stack-link type"
- stack-link)))
- index)))))))
- ((CLOSURE)
- (make-closure-ccenv (dbg-block/original-parent block)
- parent
- (stack-ccenv/normal-closure environment)))
- ((IC)
- (guarantee-interpreter-environment
- (if (dbg-block/static-link-index block)
- (stack-ccenv/static-link environment)
- (compiled-code-block/environment
- (compiled-code-address->block
- (stack-frame/return-address
- (stack-ccenv/frame environment)))))))
+(define (lookup-path initial-path root leave-last-instruction?)
+
+ (let ((stack (vector root #f #f #f #f #f))
+ (sp 0))
+ (define (dispatch instruction)
+ (define (path-error message)
+ (error message instruction initial-path root sp stack))
+ (define (push item)
+ (set! sp (+ sp 1))
+ (vector-set! stack sp item))
+ (define (unary-operation procedure)
+ (vector-set! stack sp (procedure (vector-ref stack sp))))
+ (define (binary-operation procedure)
+ (let* ((sp1 (- sp 1)))
+ (vector-set! stack sp1
+ (procedure (vector-ref stack sp1)
+ (vector-ref stack sp)))
+ (vector-set! stack sp #F)
+ (set! sp sp1)))
+ (define (->compiled-code-block place)
+ (let ((entry (or (and (compiled-entry? place) place)
+ (and (stack-frame? place)
+ (stack-frame/return-address place)))))
+ (or (and entry
+ (compiled-entry/block entry))
+ (path-error "Cant find a compiled-code block"))))
+ (define (compiled-entry? object)
+ (object-type? (ucode-type compiled-entry) object))
+
+ (define (cell-ref cell index)
+ (cond ((and (cell? cell) (zero? index))
+ (cell-contents cell))
+ ((vector? cell)
+ (vector-ref cell index))
+ (else (path-error "Not a cell"))))
+ (define (constant-block-ref place index)
+ (let ((block (->compiled-code-block place)))
+ (if (and (<= (compiled-code-block/constants-start block) index)
+ (< index (compiled-code-block/constants-end block)))
+ (system-vector-ref (->compiled-code-block place) index)
+ (path-error "Illegal constants block offset"))))
+ (define (closure-ref closure index)
+ (if (not (compiled-closure? closure))
+ (path-error "Not a compiled closure"))
+ ((ucode-primitive primitive-object-ref) closure index))
+ (define (stack-frame-ref frame index)
+ (if (not (stack-frame? frame))
+ (path-error "Not a stack frame"))
+ (let ((elements (stack-frame/elements frame)))
+ (vector-ref elements (- (vector-length elements) index))))
+ (define (interrupt-frame-ref frame index)
+ (if (not (and (stack-frame? frame)
+ (stack-frame/compiled-interrupt? frame)))
+ (path-error "Not a compiled interrupt stack frame"))
+ (let ((elements (stack-frame/elements frame)))
+ (vector-ref elements index)))
+ (define (cc-block-entry place offset)
+ ((ucode-primitive primitive-object-new-type)
+ (ucode-type compiled-entry)
+ (fix:+ (object-datum (->compiled-code-block place)) offset)))
+ (define (uncoerce-procedure procedure)
+ ;; just use the coerced procedure for now
+ procedure)
+ (define (top-level-environment place)
+ (compiled-code-block/environment (->compiled-code-block place)))
+
+ (cond ((pair? instruction)
+ (push (cdr instruction))
+ (dispatch (car instruction)))
+ ((primitive-procedure? instruction)
+ (case (primitive-procedure-arity instruction)
+ ((1) (unary-operation instruction))
+ ((2) (binary-operation instruction))
+ (else (path-error "Unknown primitive arity"))))
(else
- (error "illegal parent block" parent)))
- (let ((environment
- (compiled-code-block/environment
- (compiled-code-address->block
- (stack-frame/return-address
- (stack-ccenv/frame environment))))))
- (if (ic-environment? environment)
- environment
- system-global-environment))))))
-\f
-(define (stack-ccenv/lambda environment)
- (dbg-block/source-code (stack-ccenv/block environment)))
-
-(define (stack-ccenv/arguments environment)
- (let ((procedure (dbg-block/procedure (stack-ccenv/block environment))))
- (if procedure
- (letrec ((lookup
- (lambda (variable)
- (case (dbg-variable/type variable)
- ((INTEGRATED)
- (dbg-variable/value variable))
- ((INDIRECTED)
- (lookup (dbg-variable/value variable)))
- (else
- (stack-ccenv/lookup environment
- (dbg-variable/name variable)))))))
- (map* (map* (let ((rest (dbg-procedure/rest procedure)))
- (if rest (lookup rest) '()))
- lookup
- (dbg-procedure/optional procedure))
- lookup
- (dbg-procedure/required procedure)))
- 'UNKNOWN)))
-
-(define (stack-ccenv/bound-names environment)
- (map dbg-variable/name
- (list-transform-positive
- (vector->list
- (dbg-block/layout-vector (stack-ccenv/block environment)))
- dbg-variable?)))
-
-(define (stack-ccenv/bound? environment name)
- (dbg-block/find-name (stack-ccenv/block environment) name))
-
-(define (stack-ccenv/lookup environment name)
- (lookup-dbg-variable (stack-ccenv/block environment)
- name
- (stack-ccenv/get-value environment)))
-
-(define (stack-ccenv/assignable? environment name)
- (assignable-dbg-variable? (stack-ccenv/block environment) name))
-
-(define (stack-ccenv/assign! environment name value)
- (assign-dbg-variable! (stack-ccenv/block environment)
- name
- (stack-ccenv/get-value environment)
- value))
-\f
-(define (stack-ccenv/get-value environment)
- (lambda (index)
- (stack-frame/ref (stack-ccenv/frame environment)
- (+ (stack-ccenv/start-index environment) index))))
-
-(define (stack-ccenv/static-link environment)
- (let ((static-link
- (find-stack-element environment
- dbg-block/static-link-index
- "static link")))
- (if (not (or (stack-address? static-link)
- (interpreter-environment? static-link)))
- (error "Illegal static link in frame" static-link environment))
- static-link))
-
-(define (stack-ccenv/normal-closure environment)
- (let ((closure
- (find-stack-element environment
- dbg-block/normal-closure-index
- "closure")))
- (if (not (or (compiled-closure? closure) (vector? closure)))
- (error "Frame missing closure" closure environment))
-#|
- ;; Temporarily disable this consistency check until the compiler
- ;; is modified to provide the correct information for
- ;; multi-closed procedures.
- (if (not (eq? (compiled-entry/dbg-object closure)
- (dbg-block/procedure (stack-ccenv/block environment))))
- (error "Wrong closure in frame" closure environment))
-|#
- closure))
-
-(define (find-stack-element environment procedure name)
- (let ((frame (stack-ccenv/frame environment)))
- (stack-frame/ref
- frame
- (let ((index
- (find-stack-index (stack-ccenv/block environment)
- (stack-ccenv/start-index environment)
- (stack-frame/length frame)
- procedure)))
- (if (not index)
- (error (string-append "Unable to find " name) environment))
- index))))
-
-(define (find-stack-index block start end procedure)
- (let loop ((block block) (start start))
- (let ((index (procedure block)))
- (if index
- (+ start index)
- (let ((start (+ start (dbg-block/length block)))
- (link (dbg-block/stack-link block)))
- (and link
- (< start end)
- (loop link start)))))))
-
-(define-integrable (dbg-block/length block)
- (vector-length (dbg-block/layout-vector block)))
+ (case instruction
+ ((INTEGRATED)
+ ;; we have the root and the constant on the stack!
+ (vector-set! stack (- sp 1) (vector-ref stack sp))
+ (set! sp (- sp 1)))
+ ((UNASSIGNED)
+ ;; replace root:
+ (vector-set! stack sp (make-unassigned-reference-trap)))
+ ((CELL) (binary-operation cell-ref))
+ ((CONSTANT-BLOCK) (binary-operation constant-block-ref))
+ ((TOP-LEVEL-ENVIRONMENT)
+ (unary-operation top-level-environment))
+ ((CLOSURE) (binary-operation closure-ref))
+ ((STACK) (binary-operation stack-frame-ref))
+ ((INTERRUPT-FRAME) (binary-operation interrupt-frame-ref))
+ ((CC-ENTRY) (binary-operation cc-block-entry))
+ ((UNCOERCE) (unary-operation uncoerce-procedure))
+
+ ((ROOT) (push root))
+ (else (path-error "Unknown path expression"))))))
+
+ (define (loop path i end)
+ (if (< i end)
+ (begin
+ (dispatch (vector-ref path i))
+ (loop path (+ i 1) end))))
+
+ (if initial-path
+ (begin
+ (if (vector? initial-path)
+ (loop initial-path 0 (- (vector-length initial-path)
+ (if leave-last-instruction? 1 0)))
+ (if leave-last-instruction?
+ 'done
+ (dispatch initial-path)))
+ (if (not (= sp 0))
+ (error "Path did not evaluate to a single result!"
+ initial-path sp stack))
+ (map-reference-trap
+ (lambda ()
+ (vector-ref stack 0))))
+ unavailable-object)))
\f
-(define-structure (closure-ccenv
- (type vector)
- (named
- ((ucode-primitive string->symbol)
- "#[(runtime environment)closure-ccenv]"))
- (conc-name closure-ccenv/))
- (stack-block false read-only true)
- (closure-block false read-only true)
- (closure false read-only true))
-
-(define (closure-ccenv/bound-names environment)
- (map dbg-variable/name
- (list-transform-positive
- (vector->list
- (dbg-block/layout-vector (closure-ccenv/stack-block environment)))
- (lambda (variable)
- (and (dbg-variable? variable)
- (closure-ccenv/variable-bound? environment variable))))))
-
-(define (closure-ccenv/bound? environment name)
- (let ((block (closure-ccenv/stack-block environment)))
- (let ((index (dbg-block/find-name block name)))
- (and index
- (closure-ccenv/variable-bound?
- environment
- (vector-ref (dbg-block/layout-vector block) index))))))
-
-(define (closure-ccenv/variable-bound? environment variable)
- (or (eq? (dbg-variable/type variable) 'INTEGRATED)
- (vector-find-next-element
- (dbg-block/layout-vector (closure-ccenv/closure-block environment))
- variable)))
-
-(define (closure-ccenv/lookup environment name)
- (lookup-dbg-variable (closure-ccenv/closure-block environment)
- name
- (closure-ccenv/get-value environment)))
-
-(define (closure-ccenv/assignable? environment name)
- (assignable-dbg-variable? (closure-ccenv/closure-block environment) name))
-
-(define (closure-ccenv/assign! environment name value)
- (assign-dbg-variable! (closure-ccenv/closure-block environment)
- name
- (closure-ccenv/get-value environment)
- value))
+(define (path/last-element path)
+ (cond ((pair? path) path)
+ ((vector? path) (vector-ref path (- (vector-length path) 1)))
+ (else #F)))
+
+(define (assignable-path? path)
+ (define (cell-op? thing) (and (pair? thing) (eq? (car thing) 'CELL)))
+ (cell-op? (path/last-element path)))
+
+(define (interrupt-frame-path? path)
+ ;; Does the path start from an interrupt frame?
+ (define (frame-op? thing)
+ (and (pair? thing) (eq? (car thing) 'INTERRUPT-FRAME)))
+ (cond ((vector? path)
+ (and (not (zero? (vector-length path)))
+ (frame-op? (vector-ref path 0))))
+ ((pair? path)
+ (frame-op? path))
+ (else #F)))
\f
-(define-integrable (closure/get-value closure closure-block index)
- (compiled-closure/ref closure
- index
- (dbg-block/layout-first-offset closure-block)))
-
-(define (closure-ccenv/get-value environment)
- (lambda (index)
- (closure/get-value (closure-ccenv/closure environment)
- (closure-ccenv/closure-block environment)
- index)))
-
-(define (closure-ccenv/has-parent? environment)
- (or (let ((stack-block (closure-ccenv/stack-block environment)))
- (let ((parent (dbg-block/parent stack-block)))
- (and parent
- (case (dbg-block/type parent)
- ((CLOSURE) (and (dbg-block/original-parent stack-block) true))
- ((STACK IC) true)
- (else (error "Illegal parent block" parent))))))
- 'SIMULATED))
-
-(define (closure-ccenv/parent environment)
- (let ((stack-block (closure-ccenv/stack-block environment))
- (closure-block (closure-ccenv/closure-block environment))
- (closure (closure-ccenv/closure environment)))
- (let ((parent (dbg-block/parent stack-block))
- (use-simulation
- (lambda ()
- (if (compiled-closure? closure)
- (let ((environment
- (compiled-code-block/environment
- (compiled-entry/block closure))))
- (if (ic-environment? environment)
- environment
- system-global-environment))
- system-global-environment))))
- (if parent
- (case (dbg-block/type parent)
- ((STACK)
- (make-closure-ccenv parent closure-block closure))
- ((CLOSURE)
- (let ((parent (dbg-block/original-parent stack-block)))
- (if parent
- (make-closure-ccenv parent closure-block closure)
- (use-simulation))))
- ((IC)
- (guarantee-interpreter-environment
- (let ((index (dbg-block/ic-parent-index closure-block)))
- (if index
- (closure/get-value closure closure-block index)
- (use-simulation)))))
- (else
- (error "Illegal parent block" parent)))
- (use-simulation)))))
+(define (assign-path! path root name value)
+ (let* ((place (lookup-path path root #T))
+ (element (path/last-element path)))
+ (cond ((and (pair? element) (eq? (car element) 'CELL))
+ (let ((index (cdr element)))
+ (cond ((and (cell? place) (zero? index))
+ (set-cell-contents! place value))
+ ((vector? place)
+ (vector-set! place index value))
+ (else (error "Value of variable should be in cell/vector"
+ name place path))))
+ unspecific)
+ (else
+ (error "Unassignable variable:" name)))))
-(define (closure-ccenv/lambda environment)
- (dbg-block/source-code (closure-ccenv/stack-block environment)))
-\f
-(define (lookup-dbg-variable block name get-value)
- (let loop ((name name))
- (let* ((index (dbg-block/find-name block name))
- (variable (vector-ref (dbg-block/layout-vector block) index)))
- (case (dbg-variable/type variable)
- ((NORMAL)
- (get-value index))
- ((CELL)
- (let ((value (get-value index)))
- (if (not (cell? value))
- (error "Value of variable should be in cell" variable value))
- (cell-contents value)))
- ((INTEGRATED)
- (dbg-variable/value variable))
- ((INDIRECTED)
- (loop (dbg-variable/name (dbg-variable/value variable))))
- (else
- (error "Unknown variable type" variable))))))
-
-(define (assignable-dbg-variable? block name)
- (eq? 'CELL
- (dbg-variable/type
- (vector-ref (dbg-block/layout-vector block)
- (dbg-block/find-name block name)))))
-
-(define (assign-dbg-variable! block name get-value value)
- (let* ((index (dbg-block/find-name block name))
- (variable (vector-ref (dbg-block/layout-vector block) index)))
- (case (dbg-variable/type variable)
- ((CELL)
- (let ((cell (get-value index)))
- (if (not (cell? cell))
- (error "Value of variable should be in cell" name cell))
- (set-cell-contents! cell value)
- unspecific))
- ((NORMAL INTEGRATED INDIRECTED)
- (error "Variable cannot be side-effected" variable))
- (else
- (error "Unknown variable type" variable)))))
(define (dbg-block/name block)
(let ((procedure (dbg-block/procedure block)))
(define (dbg-block/source-code block)
(let ((procedure (dbg-block/procedure block)))
(and procedure
- (dbg-procedure/source-code procedure))))
\ No newline at end of file
+ (dbg-procedure/source-code procedure))))
+\f
+#|
+Path expressions.
+
+A path is either (1) #F, indicating that the value is not available,
+(2) a single path item, or (3) a vector of path items.
+
+The evaluation model is that the path items are reverse-polish
+operations. The stack initially contains the ROOT value (typically a
+stack frame or compiled-closure). The operations are processed in
+order to produce a single value (returning ofther than 1 value is an
+evaluation error).
+
+Path items are simple or `compound'. A compound item is a pair
+comprising a simple item and a literal. The literal (any scheme
+object) is pushed on the stack before evaluating the simple item.
+Simple items are primitive procedures, which are called with the right
+number of items from the top of the stack (The top two elements are
+called TOS & 2ND below), and special operations, which are encoded as
+symbols.
+
+The special items, in their usual syntax (simple or compound) are
+described briefly:
+
+(INTEGRATED . object)
+ Replace TOS with OBJECT
+
+UNASSIGNED
+ Replace TOS with an unassigned reference trap.
+
+(CELL . offset)
+ TOS is a cell (a cell or a vector). The value is within the cell at
+ OFFSET. This path describes a location which is used for reading or
+ assignment.
+
+(CONSTANT-BLOCK . offset)
+ Find the compiled code block for TOS and index into it. This is used
+ instead of INTEGRATED for constants that are available from the
+ constants block (rather than a non-EQ? version).
+
+TOP-LEVEL-ENVIRONMENT
+ Find the compiled code block for TOS and retrun its environment.
+
+(CLOSURE . offset)
+ TOS is a compiled closure. Replace with its component.
+
+(STACK . offset)
+ TOS must be a stack frame. Replace the element indexed from the base.
+
+(INTERUPT-FRAME . offset)
+ TOS must be an interrupt stack frame. Replace with index from the
+ start.
+
+(CC-ENTRY . byte-offset)
+ Find the compiled code block for TOS and replace with the compiled
+ entry at that offset from the compiled code block.
+
+UNCOERCE
+ Undo effect of COERCE-TO-COMPILED-PROCEURE
+
+ROOT
+ Push the original ROOT to start a new subexpression.
+
+Example 1
+
+ UNASSIGNED - the variable is unassigned
+
+Example 2
+
+ #((STACK . 3) (CLOSURE . 3) VECTOR-LENGTH
+ ROOT (INTEGRATED . 1)
+ MINUS-FIXNUM)
+
+ The expression `(fix:- (vector-length foo) 1)' where FOO is a closed
+ variable and the closure is available from the stack-frame.
+ Note: this could have been optimized to
+
+ #((STACK . 3) (CLOSURE . 3) VECTOR-LENGTH (MINUS-FIXNUM . 1))
+
+ but this kind of expression is sufficiently rare that the space
+ savings are not worth the effort in writing the code.
+
+|#
projects / mit-scheme.git / commitdiff