From: Stephen Adams Date: Thu, 27 Jul 1995 21:11:41 +0000 (+0000) Subject: The debugging information have been completely overhauled for the new X-Git-Tag: 20090517-FFI~6106 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c6a373e4707bafc3cb2493dd7acba47f637785fd;p=mit-scheme.git The debugging information have been completely overhauled for the new compiler. Compiled files (.com files) now countain a COMPILED-MODULE object. Debugging information is accessed by a DBG-LOCATOR, and the located files must contains a DBG-WRAPPER with corresponding timestamps. These objects also contain a version which allows safe extension of the dbg information. DBG-BLOCKs now contain access paths which describe how to find the value for the bindings (they used to describe the inverse, i.e. the layout of the object). DBG-PROCEDURES have been streamlined to get lambda list information from the source code. DBG-VARIABLES are implemented as pairs to save on storage. Improved error message for ENVIRONMENT-* operations. Now there is only one kind of compiled environment which contains a root object and a DBG-BLOCK. The access paths in the DBG-BLOCK are relative to the root object. The access paths are evaluated by a stack machine which understands a fixed vocabulary of operations and 1- and 2- place primitives. CCENV/LOOKUP and CCENV/ASSIGN! now give an unbound variable error if he variable is not bound. They used to return an unavailable object (currently the symbol "??"). CCENV/ARGUMENTS tries to be clever with #!OPTIONAL arguements - an assignment trap (i.e. default-object?) determines the number of arguments provided that the previous argument is either required or available. --- diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index 3079fa089..bfec4fc3c 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unpars.scm,v 14.43 1995/05/25 18:25:54 ziggy Exp $ +$Id: unpars.scm,v 14.44 1995/07/27 21:10:31 adams Exp $ Copyright (c) 1988-95 Massachusetts Institute of Technology @@ -611,7 +611,8 @@ MIT in each case. |# entry (lambda () (let ((name (and procedure? (compiled-procedure/name entry)))) - (with-values (lambda () (compiled-entry/filename entry)) + (with-values + (lambda () (compiled-entry/filename-and-index entry)) (lambda (filename block-number) (*unparse-char #\() (if name diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 18b2be23f..e89cd1a57 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.260 1995/06/20 05:59:57 cph Exp $ +$Id: runtime.pkg,v 14.261 1995/07/27 21:08:59 adams Exp $ Copyright (c) 1988-95 Massachusetts Institute of Technology @@ -222,10 +222,8 @@ MIT in each case. |# (files "infstr" "infutl") (parent ()) (export () - compiled-code-block/filename compiled-entry/block compiled-entry/dbg-object - compiled-entry/filename compiled-entry/offset compiled-expression/scode compiled-procedure/name @@ -234,48 +232,44 @@ MIT in each case. |# load-debugging-info-on-demand? uncompress-ports) (export (runtime load) - dbg-info-vector/purification-root - dbg-info-vector? + compiled-module? + compiled-module/expression + compiled-module/purification-root fasload/update-debugging-info!) - (export (runtime program-copier) - dbg-info-vector?) + ;;(export (runtime program-copier) + ;; dbg-info-vector?) (export (runtime debugger-command-loop) special-form-procedure-name?) (export (runtime environment) - dbg-block/find-name - dbg-block/ic-parent-index - dbg-block/layout - dbg-block/layout-first-offset - dbg-block/layout-vector - dbg-block/normal-closure-index - dbg-block/original-parent + ;;dbg-block/find-name + dbg-block/find-variable dbg-block/parent + dbg-block/parent-path-prefix dbg-block/procedure - dbg-block/stack-link - dbg-block/static-link-index dbg-block/type + dbg-block/variables dbg-continuation? dbg-continuation/block - dbg-continuation/offset dbg-expression? dbg-procedure? dbg-procedure/block + dbg-procedure/label dbg-procedure/name - dbg-procedure/required - dbg-procedure/optional - dbg-procedure/rest dbg-procedure/source-code + dbg-variable? dbg-variable/name - dbg-variable/type - dbg-variable/value - dbg-variable?) + dbg-variable/path) (export (runtime debugging-info) dbg-continuation? - dbg-continuation/source-code + dbg-continuation/inner + dbg-continuation/outer + dbg-continuation/type dbg-procedure? dbg-procedure/block dbg-procedure/source-code dbg-expression?) + (export (runtime unparser) + compiled-entry/filename-and-index) (export (runtime compress) uncompress-internal) (initialization (initialize-package!))) @@ -328,6 +322,7 @@ MIT in each case. |# stack-frame-type/subproblem? stack-frame-type? stack-frame/compiled-code? + stack-frame/compiled-interrupt? stack-frame/dynamic-state stack-frame/elements stack-frame/interrupt-mask @@ -349,7 +344,8 @@ MIT in each case. |# stack-frame?) (export (runtime debugging-info) stack-frame-type/interrupt-compiled-procedure - stack-frame-type/interrupt-compiled-expression) + stack-frame-type/interrupt-compiled-expression + stack-frame-type/interrupt-compiled-return-address) (initialization (initialize-package!))) (define-package (runtime control-point) @@ -536,6 +532,8 @@ MIT in each case. |# interpreter-environment? make-null-interpreter-environment system-global-environment?) + (export (runtime debugger-utilities) + unavailable?) (export (runtime advice) ic-environment/arguments ic-environment/procedure) diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index ca1bc11b5..37fa36a97 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -40,41 +40,34 @@ MIT in each case. |# (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) @@ -84,17 +77,16 @@ MIT in each case. |# '() (list value))))) (environment-bound-names environment))) - + (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)))) + (define (environment-procedure-name environment) (let ((scode-lambda (environment-lambda environment))) (and scode-lambda @@ -105,47 +97,40 @@ MIT in each case. |# 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)) ;;;; Interpreter Environments @@ -209,12 +194,12 @@ MIT in each case. |# (extension-names external parameters)))) (lambda (name) (unbound-name? environment name)))) - + (define (unbound-name? environment name) (if (eq? name package-name-tag) true (lexical-unbound? environment name))) - + (define (ic-environment/arguments environment) (lambda-components* (ic-environment/lambda environment) (lambda (name required optional rest body) @@ -241,15 +226,12 @@ MIT in each case. |# (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) @@ -278,51 +260,151 @@ MIT in each case. |# ;;;; 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)) + +(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) + +(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) @@ -332,353 +414,179 @@ MIT in each case. |# (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))))))) -(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)))))) - -(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)) - -(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))) -(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))) -(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))) - -(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))) @@ -688,4 +596,87 @@ MIT in each case. |# (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)))) + +#| +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. + +|#