From: Chris Hanson Date: Fri, 30 Dec 1988 06:44:04 +0000 (+0000) Subject: Extensive changes to utilize compiled code debugging information: X-Git-Tag: 20090517-FFI~12315 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1ba388aa192c19f58db122b2366071064e8eb1e8;p=mit-scheme.git Extensive changes to utilize compiled code debugging information: * The stack parser now knows how to parse individual compiled code subproblem frames. * The compiler-info package has been updated to match the new compiled code info format. * The environment abstraction has been generalized to handle compiled code stack and closure frames, when debugging info is available to describe them. * The `debug' and `where' presentation formats have been adjusted somewhat to allow compiled code information to be presented reasonably. * `debug' has been extended to provide the common `A' command from `where'; there should be little need to invoke `where' from `debug'. --- diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index 93efc1e71..915a1ac1b 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.2 1988/08/05 20:46:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.3 1988/12/30 06:41:58 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -171,8 +171,8 @@ MIT in each case. |# ;;; of exit advice is equivalent to doing (PROCEED value) from it. (define (advised-procedure-wrapper environment) - (let ((procedure (environment-procedure environment)) - (arguments (environment-arguments environment))) + (let ((procedure (ic-environment/procedure environment)) + (arguments (ic-environment/arguments environment))) (lambda-wrapper-components (procedure-lambda procedure) (lambda (original-body state) (call-with-current-continuation diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm index f1d5ef2af..8321696f4 100644 --- a/v7/src/runtime/conpar.scm +++ b/v7/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.4 1988/06/22 21:24:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.5 1988/12/30 06:42:07 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -44,7 +44,8 @@ MIT in each case. |# (type elements dynamic-state fluid-bindings interrupt-mask history previous-history-offset - previous-history-control-point %next)) + previous-history-control-point + offset %next)) (conc-name stack-frame/)) (type false read-only true) (elements false read-only true) @@ -54,6 +55,7 @@ MIT in each case. |# (history false read-only true) (previous-history-offset false read-only true) (previous-history-control-point false read-only true) + (offset false read-only true) ;; %NEXT is either a parser-state object or the next frame. In the ;; former case, the parser-state is used to compute the next frame. %next @@ -92,7 +94,7 @@ MIT in each case. |# (let ((stack-frame (stack-frame/next stack-frame))) (and stack-frame (stack-frame/skip-non-subproblems stack-frame))))) - + (define-integrable (stack-frame/length stack-frame) (vector-length (stack-frame/elements stack-frame))) @@ -102,13 +104,24 @@ MIT in each case. |# (lambda () (vector-ref elements index))))) (define-integrable (stack-frame/return-address stack-frame) - (stack-frame-type/address (stack-frame/type stack-frame))) + (stack-frame/ref stack-frame 0)) -(define-integrable (stack-frame/return-code stack-frame) - (stack-frame-type/code (stack-frame/type stack-frame))) +(define (stack-frame/return-code stack-frame) + (let ((return-address (stack-frame/return-address stack-frame))) + (and (interpreter-return-address? return-address) + (return-address/code return-address)))) (define-integrable (stack-frame/subproblem? stack-frame) (stack-frame-type/subproblem? (stack-frame/type stack-frame))) + +(define (stack-frame/resolve-stack-address frame address) + (let loop + ((frame frame) + (offset (stack-address->index address (stack-frame/offset frame)))) + (let ((length (stack-frame/length frame))) + (if (< offset length) + (values frame offset) + (loop (stack-frame/next frame) (- offset length)))))) ;;;; Parser @@ -121,6 +134,7 @@ MIT in each case. |# (previous-history-offset false read-only true) (previous-history-control-point false read-only true) (element-stream false read-only true) + (n-elements false read-only true) (next-control-point false read-only true)) (define (continuation->stack-frame continuation) @@ -139,52 +153,28 @@ MIT in each case. |# (control-point/previous-history-offset control-point) (control-point/previous-history-control-point control-point) (control-point/element-stream control-point) + (control-point/n-elements control-point) (control-point/next-control-point control-point))))) (define (parse/start state) (let ((stream (parser-state/element-stream state))) (if (stream-pair? stream) - (let ((type (parse/type stream)) - (stream (stream-cdr stream))) - (let ((length (parse/length stream type))) - (with-values (lambda () (parse/elements stream length)) - (lambda (elements stream) - (parse/dispatch type - elements - (parse/next-state state length stream)))))) + (let ((type + (return-address->stack-frame-type + (element-stream/head stream)))) + (let ((length + (let ((length (stack-frame-type/length type))) + (if (integer? length) + length + (length stream (parser-state/n-elements state)))))) + ((stack-frame-type/parser type) + type + (list->vector (stream-head stream length)) + (parse/next-state state length (stream-tail stream length))))) (parse/control-point (parser-state/next-control-point state) (parser-state/dynamic-state state) (parser-state/fluid-bindings state))))) -(define (parse/type stream) - (let ((return-address (element-stream/head stream))) - (if (not (return-address? return-address)) - (error "illegal return address" return-address)) - (let ((code (return-address/code return-address))) - (let ((type (microcode-return/code->type code))) - (if (not type) - (error "return-code has no type" code)) - type)))) - -(define (parse/length stream type) - (let ((length (stack-frame-type/length type))) - (if (integer? length) - length - (length stream)))) - -(define (parse/elements stream length) - (let ((elements (make-vector length))) - (let loop ((stream stream) (index 0)) - (if (< index length) - (begin (if (not (stream-pair? stream)) - (error "stack too short" index)) - (vector-set! elements index (stream-car stream)) - (loop (stream-cdr stream) (1+ index))) - (values elements stream))))) - -(define (parse/dispatch type elements state) - ((stack-frame-type/parser type) type elements state)) - (define (parse/next-state state length stream) (let ((previous-history-control-point (parser-state/previous-history-control-point state))) @@ -195,13 +185,17 @@ MIT in each case. |# (parser-state/history state) (if previous-history-control-point (parser-state/previous-history-offset state) - (max (- (parser-state/previous-history-offset state) length) 0)) + (max (- (parser-state/previous-history-offset state) (-1+ length)) + 0)) previous-history-control-point stream + (- (parser-state/n-elements state) length) (parser-state/next-control-point state)))) - -(define (make-frame type elements state element-stream) - (let ((subproblem? (stack-frame-type/subproblem? type)) + +(define (make-frame type elements state element-stream n-elements) + (let ((history-subproblem? + (and (stack-frame-type/subproblem? type) + (not (eq? type stack-frame-type/compiled-return-address)))) (history (parser-state/history state)) (previous-history-offset (parser-state/previous-history-offset state)) (previous-history-control-point @@ -211,28 +205,29 @@ MIT in each case. |# (parser-state/dynamic-state state) (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) - (if subproblem? history undefined-history) + (if history-subproblem? history undefined-history) previous-history-offset previous-history-control-point + (+ (vector-length elements) n-elements) (make-parser-state (parser-state/dynamic-state state) (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) - (if subproblem? (history-superproblem history) history) + (if history-subproblem? + (history-superproblem history) + history) previous-history-offset previous-history-control-point element-stream + n-elements (parser-state/next-control-point state))))) (define (element-stream/head stream) (if (not (stream-pair? stream)) (error "not a stream-pair" stream)) (map-reference-trap (lambda () (stream-car stream)))) -(define (element-stream/ref stream index) - (if (not (stream-pair? stream)) (error "not a stream-pair" stream)) - (if (zero? index) - (map-reference-trap (lambda () (stream-car stream))) - (element-stream/ref (stream-cdr stream) (-1+ index)))) +(define-integrable (element-stream/ref stream index) + (map-reference-trap (lambda () (stream-ref stream index)))) ;;;; Unparser @@ -260,41 +255,49 @@ MIT in each case. |# (cond ((stack-frame? next) (with-values (lambda () (unparse/stack-frame next)) (lambda (element-stream next-control-point) - (values (let ((type (stack-frame/type stack-frame))) - ((stack-frame-type/unparser type) - type - (stack-frame/elements stack-frame) - element-stream)) - next-control-point)))) + (values + (let ((elements (stack-frame/elements stack-frame))) + (let ((length (vector-length elements))) + (let loop ((index 0)) + (if (< index length) + (cons-stream (vector-ref elements index) + (loop (1+ index))) + element-stream)))) + next-control-point)))) ((parser-state? next) (values (parser-state/element-stream next) (parser-state/next-control-point next))) - (else (values (stream) false))))) + (else + (values (stream) false))))) -;;;; Generic Parsers/Unparsers - -(define (parser/interpreter-next type elements state) - (make-frame type elements state (parser-state/element-stream state))) - -(define (unparser/interpreter-next type elements element-stream) - (cons-stream (make-return-address (stack-frame-type/code type)) - (let ((length (vector-length elements))) - (let loop ((index 0)) - (if (< index length) - (cons-stream (vector-ref elements index) - (loop (1+ index))) - element-stream))))) - -(define (parser/compiler-next type elements state) - (make-frame type elements state - (cons-stream - (ucode-return-address reenter-compiled-code) - (cons-stream - (- (vector-ref elements 0) (vector-length elements)) - (parser-state/element-stream state))))) - -(define (unparser/compiler-next type elements element-stream) - (unparser/interpreter-next type elements (stream-tail element-stream 2))) +;;;; Special Frame Lengths + +(define (length/combination-save-value stream offset) + offset + (+ 3 (system-vector-length (element-stream/ref stream 1)))) + +(define ((length/application-frame index missing) stream offset) + offset + (+ index 1 (- (object-datum (element-stream/ref stream index)) missing))) + +(define (length/repeat-primitive stream offset) + offset + (primitive-procedure-arity (element-stream/ref stream 1))) + +(define (length/compiled-return-address stream offset) + (let ((entry (element-stream/head stream))) + (let ((frame-size (compiled-continuation/next-continuation-offset entry))) + (if frame-size + (1+ frame-size) + (stack-address->index (element-stream/ref stream 1) offset))))) + ;;;; Parsers + +(define (parser/standard-next type elements state) + (make-frame type + elements + state + (parser-state/element-stream state) + (parser-state/n-elements state))) (define (make-restore-frame type elements @@ -305,7 +308,7 @@ MIT in each case. |# history previous-history-offset previous-history-control-point) - (parser/interpreter-next + (parser/standard-next type elements (make-parser-state dynamic-state @@ -315,9 +318,8 @@ MIT in each case. |# previous-history-offset previous-history-control-point (parser-state/element-stream state) + (parser-state/n-elements state) (parser-state/next-control-point state)))) - -;;;; Specific Parsers (define (parser/restore-dynamic-state type elements state) (make-restore-frame type elements state @@ -325,7 +327,7 @@ MIT in each case. |# ;; consists of all of the state spaces in ;; existence. Probably we should have some ;; mechanism for keeping track of them all. - (let ((dynamic-state (vector-ref elements 0))) + (let ((dynamic-state (vector-ref elements 1))) (if (eq? system-state-space (state-point/space dynamic-state)) dynamic-state @@ -339,7 +341,7 @@ MIT in each case. |# (define (parser/restore-fluid-bindings type elements state) (make-restore-frame type elements state (parser-state/dynamic-state state) - (vector-ref elements 0) + (vector-ref elements 1) (parser-state/interrupt-mask state) (parser-state/history state) (parser-state/previous-history-offset state) @@ -349,7 +351,7 @@ MIT in each case. |# (make-restore-frame type elements state (parser-state/dynamic-state state) (parser-state/fluid-bindings state) - (vector-ref elements 0) + (vector-ref elements 1) (parser-state/history state) (parser-state/previous-history-offset state) (parser-state/previous-history-control-point state))) @@ -359,148 +361,144 @@ MIT in each case. |# (parser-state/dynamic-state state) (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) - (history-transform (vector-ref elements 0)) - (vector-ref elements 1) - (vector-ref elements 2))) - -(define (length/combination-save-value stream) - (+ 2 (system-vector-length (element-stream/head stream)))) - -(define ((length/application-frame index missing) stream) - (+ index 1 (- (object-datum (element-stream/ref stream index)) missing))) - -(define (length/repeat-primitive stream) - (-1+ (primitive-procedure-arity (element-stream/head stream)))) - -(define (length/reenter-compiled-code stream) - (1+ (element-stream/head stream))) + (history-transform (vector-ref elements 1)) + (vector-ref elements 2) + (vector-ref elements 3))) ;;;; Stack Frame Types (define-structure (stack-frame-type (constructor make-stack-frame-type - (code subproblem? length parser unparser)) + (code subproblem? length parser)) (conc-name stack-frame-type/)) (code false read-only true) (subproblem? false read-only true) (properties (make-1d-table) read-only true) (length false read-only true) - (parser false read-only true) - (unparser false read-only true)) + (parser false read-only true)) (define (microcode-return/code->type code) (if (not (< code (vector-length stack-frame-types))) (error "return-code too large" code)) (vector-ref stack-frame-types code)) -(define-integrable (stack-frame-type/address frame-type) - (make-return-address (stack-frame-type/code frame-type))) +(define (return-address->stack-frame-type return-address) + (cond ((interpreter-return-address? return-address) + (let ((code (return-address/code return-address))) + (let ((type (microcode-return/code->type code))) + (if (not type) + (error "return-code has no type" code)) + type))) + ((compiled-return-address? return-address) + (if (compiled-continuation/return-to-interpreter? + return-address) + stack-frame-type/return-to-interpreter + stack-frame-type/compiled-return-address)) + (else + (error "illegal return address" return-address)))) (define (initialize-package!) - (set! stack-frame-types (make-stack-frame-types))) + (set! stack-frame-types (make-stack-frame-types)) + (set! stack-frame-type/compiled-return-address + (make-stack-frame-type false + true + length/compiled-return-address + parser/standard-next)) + (set! stack-frame-type/return-to-interpreter + (make-stack-frame-type false + false + 1 + parser/standard-next)) + unspecific) (define stack-frame-types) +(define stack-frame-type/compiled-return-address) +(define stack-frame-type/return-to-interpreter) (define (make-stack-frame-types) (let ((types (make-vector (microcode-return/code-limit) false))) - (define (stack-frame-type name subproblem? length parser unparser) + (define (stack-frame-type name subproblem? length parser) (let ((code (microcode-return name))) (vector-set! types code - (make-stack-frame-type code subproblem? length parser - unparser)))) - - (define (interpreter-frame name length #!optional parser) - (stack-frame-type name false length - (if (default-object? parser) - parser/interpreter-next - parser) - unparser/interpreter-next)) + (make-stack-frame-type code subproblem? length parser)))) - (define (compiler-frame name length #!optional parser) - (stack-frame-type name false length + (define (standard-frame name length #!optional parser) + (stack-frame-type name + false + length (if (default-object? parser) - parser/compiler-next - parser) - unparser/compiler-next)) - - (define (interpreter-subproblem name length) - (stack-frame-type name true length parser/interpreter-next - unparser/interpreter-next)) - - (define (compiler-subproblem name length) - (stack-frame-type name true length parser/compiler-next - unparser/compiler-next)) + parser/standard-next + parser))) + + (define (standard-subproblem name length) + (stack-frame-type name + true + length + parser/standard-next)) - (interpreter-frame 'RESTORE-TO-STATE-POINT 1 parser/restore-dynamic-state) - (interpreter-frame 'RESTORE-FLUIDS 1 parser/restore-fluid-bindings) - (interpreter-frame 'RESTORE-INTERRUPT-MASK 1 parser/restore-interrupt-mask) - (interpreter-frame 'RESTORE-HISTORY 3 parser/restore-history) - (interpreter-frame 'RESTORE-DONT-COPY-HISTORY 3 parser/restore-history) - - (interpreter-frame 'NON-EXISTENT-CONTINUATION 1) - (interpreter-frame 'HALT 1) - (interpreter-frame 'JOIN-STACKLETS 1) - (interpreter-frame 'POP-RETURN-ERROR 1) - - (interpreter-subproblem 'IN-PACKAGE-CONTINUE 1) - (interpreter-subproblem 'ACCESS-CONTINUE 1) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 1) - (interpreter-subproblem 'FORCE-SNAP-THUNK 1) - (interpreter-subproblem 'GC-CHECK 1) - (interpreter-subproblem 'RESTORE-VALUE 1) - (interpreter-subproblem 'ASSIGNMENT-CONTINUE 2) - (interpreter-subproblem 'DEFINITION-CONTINUE 2) - (interpreter-subproblem 'SEQUENCE-2-SECOND 2) - (interpreter-subproblem 'SEQUENCE-3-SECOND 2) - (interpreter-subproblem 'SEQUENCE-3-THIRD 2) - (interpreter-subproblem 'CONDITIONAL-DECIDE 2) - (interpreter-subproblem 'DISJUNCTION-DECIDE 2) - (interpreter-subproblem 'COMBINATION-1-PROCEDURE 2) - (interpreter-subproblem 'COMBINATION-2-FIRST-OPERAND 2) - (interpreter-subproblem 'EVAL-ERROR 2) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 2) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 2) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 2) - (interpreter-subproblem 'COMBINATION-2-PROCEDURE 3) - (interpreter-subproblem 'REPEAT-DISPATCH 3) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 3) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 3) - (interpreter-subproblem 'MOVE-TO-ADJACENT-POINT 5) - - (interpreter-subproblem 'COMBINATION-SAVE-VALUE - length/combination-save-value) - - (interpreter-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive) - - (let ((length (length/application-frame 1 0))) - (interpreter-subproblem 'COMBINATION-APPLY length) - (interpreter-subproblem 'INTERNAL-APPLY length)) - - (interpreter-subproblem 'REENTER-COMPILED-CODE - length/reenter-compiled-code) - - (compiler-frame 'COMPILER-INTERRUPT-RESTART 2) - (compiler-frame 'COMPILER-LINK-CACHES-RESTART 7) - - (compiler-subproblem 'COMPILER-REFERENCE-RESTART 3) - (compiler-subproblem 'COMPILER-SAFE-REFERENCE-RESTART 3) - (compiler-subproblem 'COMPILER-ACCESS-RESTART 3) - (compiler-subproblem 'COMPILER-UNASSIGNED?-RESTART 3) - (compiler-subproblem 'COMPILER-UNBOUND?-RESTART 3) - (compiler-subproblem 'COMPILER-REFERENCE-TRAP-RESTART 3) - (compiler-subproblem 'COMPILER-SAFE-REFERENCE-TRAP-RESTART 3) - (compiler-subproblem 'COMPILER-UNASSIGNED?-TRAP-RESTART 3) - (compiler-subproblem 'COMPILER-ASSIGNMENT-RESTART 4) - (compiler-subproblem 'COMPILER-DEFINITION-RESTART 4) - (compiler-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 4) - - (compiler-subproblem 'COMPILER-LOOKUP-APPLY-RESTART - (length/application-frame 3 1)) - - (let ((length (length/application-frame 3 0))) - (compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length) - (compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length)) - + (standard-frame 'RESTORE-TO-STATE-POINT 2 parser/restore-dynamic-state) + (standard-frame 'RESTORE-FLUIDS 2 parser/restore-fluid-bindings) + (standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask) + (standard-frame 'RESTORE-HISTORY 4 parser/restore-history) + (standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history) + + (standard-frame 'NON-EXISTENT-CONTINUATION 2) + (standard-frame 'HALT 2) + (standard-frame 'JOIN-STACKLETS 2) + (standard-frame 'POP-RETURN-ERROR 2) + (standard-frame 'REENTER-COMPILED-CODE 2) + (standard-frame 'COMPILER-INTERRUPT-RESTART 3) + (standard-frame 'COMPILER-LINK-CACHES-RESTART 8) + + (standard-subproblem 'IN-PACKAGE-CONTINUE 2) + (standard-subproblem 'ACCESS-CONTINUE 2) + (standard-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 2) + (standard-subproblem 'FORCE-SNAP-THUNK 2) + (standard-subproblem 'GC-CHECK 2) + (standard-subproblem 'RESTORE-VALUE 2) + (standard-subproblem 'ASSIGNMENT-CONTINUE 3) + (standard-subproblem 'DEFINITION-CONTINUE 3) + (standard-subproblem 'SEQUENCE-2-SECOND 3) + (standard-subproblem 'SEQUENCE-3-SECOND 3) + (standard-subproblem 'SEQUENCE-3-THIRD 3) + (standard-subproblem 'CONDITIONAL-DECIDE 3) + (standard-subproblem 'DISJUNCTION-DECIDE 3) + (standard-subproblem 'COMBINATION-1-PROCEDURE 3) + (standard-subproblem 'COMBINATION-2-FIRST-OPERAND 3) + (standard-subproblem 'EVAL-ERROR 3) + (standard-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 3) + (standard-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 3) + (standard-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 3) + (standard-subproblem 'COMBINATION-2-PROCEDURE 4) + (standard-subproblem 'REPEAT-DISPATCH 4) + (standard-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 4) + (standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4) + (standard-subproblem 'COMPILER-REFERENCE-RESTART 4) + (standard-subproblem 'COMPILER-SAFE-REFERENCE-RESTART 4) + (standard-subproblem 'COMPILER-ACCESS-RESTART 4) + (standard-subproblem 'COMPILER-UNASSIGNED?-RESTART 4) + (standard-subproblem 'COMPILER-UNBOUND?-RESTART 4) + (standard-subproblem 'COMPILER-REFERENCE-TRAP-RESTART 4) + (standard-subproblem 'COMPILER-SAFE-REFERENCE-TRAP-RESTART 4) + (standard-subproblem 'COMPILER-UNASSIGNED?-TRAP-RESTART 4) + (standard-subproblem 'COMPILER-ASSIGNMENT-RESTART 5) + (standard-subproblem 'COMPILER-DEFINITION-RESTART 5) + (standard-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 5) + (standard-subproblem 'MOVE-TO-ADJACENT-POINT 6) + + (standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value) + (standard-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive) + + (let ((length (length/application-frame 2 0))) + (standard-subproblem 'COMBINATION-APPLY length) + (standard-subproblem 'INTERNAL-APPLY length)) + + (standard-subproblem 'COMPILER-LOOKUP-APPLY-RESTART + (length/application-frame 4 1)) + + (let ((length (length/application-frame 4 0))) + (standard-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length) + (standard-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length)) types)) \ No newline at end of file diff --git a/v7/src/runtime/cpoint.scm b/v7/src/runtime/cpoint.scm index e450b1223..f19f69122 100644 --- a/v7/src/runtime/cpoint.scm +++ b/v7/src/runtime/cpoint.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpoint.scm,v 14.2 1988/06/13 11:42:56 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpoint.scm,v 14.3 1988/12/30 06:42:23 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -58,13 +58,22 @@ MIT in each case. |# (define-integrable (control-point/previous-history-control-point control-point) (control-point-ref control-point 5)) -(define (control-point-ref control-point index) - (system-vector-ref control-point - (+ (control-point/unused-length control-point) 2 index))) +(define-integrable (control-point-ref control-point index) + (system-vector-ref control-point (control-point-index control-point index))) + +(define-integrable (control-point-index control-point index) + (+ (control-point/unused-length control-point) (+ 2 index))) + +(define-integrable (control-point/first-element-index control-point) + (control-point-index control-point 6)) + +(define (control-point/n-elements control-point) + (- (system-vector-length control-point) + (control-point/first-element-index control-point))) (define (control-point/element-stream control-point) (let ((end (system-vector-length control-point))) - (let loop ((index (+ (control-point/unused-length control-point) 8))) + (let loop ((index (control-point/first-element-index control-point))) (cond ((= index end) '()) (((ucode-primitive primitive-object-type? 2) (ucode-type manifest-nm-vector) diff --git a/v7/src/runtime/dbgutl.scm b/v7/src/runtime/dbgutl.scm index 834ebd429..b5c2e8695 100644 --- a/v7/src/runtime/dbgutl.scm +++ b/v7/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.3 1988/08/01 23:09:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.4 1988/12/30 06:42:27 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -46,71 +46,107 @@ MIT in each case. |# (,lambda-tag:fluid-let . FLUID-LET) (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))) -(define (print-user-friendly-name frame) - (let ((name (environment-name frame))) - (let ((rename (assq name rename-list))) - (if rename - (begin (write-string "a ") - (write (cdr rename)) - (write-string " special form")) - (begin (write-string "the procedure ") - (write name)))))) - -(define (environment-name environment) - (lambda-components* (procedure-lambda (environment-procedure environment)) - (lambda (name required optional rest body) - required optional rest body - name))) - -(define (special-name? symbol) - (assq symbol rename-list)) +(define (print-user-friendly-name environment) + (let ((name (environment-procedure-name environment))) + (if name + (let ((rename (special-name? name))) + (if rename + (begin (write-string "a ") + (write (cdr rename)) + (write-string " special form")) + (begin (write-string "the procedure ") + (write-dbg-name name)))) + (write-string "an unknown procedure")))) + +(define (special-name? name) + (list-search-positive rename-list + (lambda (association) + (dbg-name=? (car association) name)))) (define rename-list) -(define (show-frame frame depth) - (if (system-global-environment? frame) - (begin - (newline) - (write-string "This frame is the system global environment")) - (begin - (newline) - (write-string "Frame created by ") - (print-user-friendly-name frame) - (if (>= depth 0) - (begin (newline) - (write-string "Depth (relative to starting frame): ") - (write depth))) - (newline) - (let ((bindings (environment-bindings frame))) - (if (null? bindings) - (write-string "Has no bindings") - (begin - (write-string "Has bindings:") - (newline) - (for-each print-binding - (sort bindings - (lambda (x y) - (stringstring (car x)) - (symbol->string (car y)))))))))))) - -(define (print-binding binding) - (let ((x-size (output-port/x-size (current-output-port))) - (write->string - (lambda (object length) - (let ((x (write-to-string object length))) - (if (and (car x) (> length 4)) - (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) - (cdr x))))) +(define (show-frame environment depth brief?) + (write-string "Environment ") + (let ((show-bindings? + (let ((package (environment->package environment))) + (if package + (begin + (write-string "named ") + (write (package/name package)) + (not brief?)) + (begin + (write-string "created by ") + (print-user-friendly-name environment) + true))))) + (if (not (negative? depth)) + (begin (newline) + (write-string "Depth (relative to starting frame): ") + (write depth))) + (if show-bindings? + (begin + (newline) + (show-environment-bindings environment brief?)))) + (newline)) + +(define (show-environment-bindings environment brief?) + (let ((names (environment-bound-names environment))) + (let ((n-bindings (length names)) + (finish + (lambda (names) + (newline) + (for-each (lambda (name) + (print-binding name + (environment-lookup environment name))) + names)))) + (cond ((zero? n-bindings) + (write-string "Has no bindings")) + ((and brief? (> n-bindings brief-bindings-limit)) + (write-string "Has ") + (write n-bindings) + (write-string " bindings (first ") + (write brief-bindings-limit) + (write-string " shown):") + (finish (list-head names brief-bindings-limit))) + (else + (write-string "Has bindings:") + (finish names)))))) + +(define brief-bindings-limit + 16) + +(define (show-frames environment depth) + (let loop ((environment environment) (depth depth)) + (show-frame environment depth true) + (if (environment-has-parent? environment) + (begin + (newline) + (loop (environment-parent environment) (1+ depth)))))) + +(define (print-binding name value) + (let ((x-size (output-port/x-size (current-output-port)))) (newline) (write-string - (let ((s (write->string (car binding) (quotient x-size 2)))) - (if (null? (cdr binding)) - (string-append s " is unassigned") - (let ((s (string-append s " = "))) - (string-append s - (write->string (cadr binding) - (max (- x-size (string-length s)) - 0))))))))) + (let ((name + (output-to-string (quotient x-size 2) + (lambda () + (write-dbg-name name))))) + (if (unassigned-reference-trap? value) + (string-append name " is unassigned") + (let ((s (string-append name " = "))) + (string-append + s + (output-to-string (max (- x-size (string-length s)) 0) + (lambda () + (write value)))))))))) + +(define (output-to-string length thunk) + (let ((x (with-output-to-truncated-string length thunk))) + (if (and (car x) (> length 4)) + (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) + (cdr x))) + +(define (write-dbg-name name) + (if (string? name) (write-string name) (write name))) (define (debug/read-eval-print-1 environment) (let ((value (debug/eval (prompt-for-expression "Eval--> ") environment))) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index c6b9892f1..f8e8c4e6b 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.5 1988/10/07 22:38:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.6 1988/12/30 06:42:33 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -43,12 +43,12 @@ MIT in each case. |# 'DEBUG-COMMANDS `((#\? ,standard-help-command "Help, list command letters") - (#\A ,debug-compiled - "Invoke compiled code debugger on the current subproblem") + (#\A ,show-all-frames + "Show bindings in current environment and its ancestors") (#\B ,earlier-reduction-command "Earlier reduction (Back in time)") (#\C ,show-current-frame - "Show Bindings of identifiers in the current environment") + "Show bindings of identifiers in the current environment") (#\D ,later-subproblem-command "Move (Down) to the next (later) subproblem") (#\E ,enter-read-eval-print-loop @@ -81,7 +81,8 @@ MIT in each case. |# "Create a read eval print loop in the debugger environment") (#\Z ,return-command "Return (continue with) an expression after evaluating it") - )))) + ))) + unspecific) (define command-set) @@ -139,50 +140,69 @@ MIT in each case. |# ;;;; Random display commands (define (pretty-print-current-expression) - (print-expression current-expression)) + (cond ((debugging-info/undefined-expression? current-expression) + (newline) + (write-string "")) + ((debugging-info/compiled-code? current-expression) + (newline) + (write-string "")) + (else + (pp current-expression)))) (define (pretty-print-reduction-function) - (if-valid-environment current-environment + (if-valid-ic-environment current-environment (lambda (environment) - (pp (environment-procedure environment))))) + (pp (ic-environment/procedure environment))))) (define (print-current-expression) (newline) - (write-string "Subproblem Level: ") + (write-string "Subproblem level: ") (write current-subproblem-number) - (if current-reduction - (begin - (write-string " Reduction Number: ") - (write current-reduction-number) - (newline) - (write-string "Expression:")) - (begin - (newline) - (write-string "Possibly Incomplete Expression:"))) - (print-expression current-expression) + (cond (current-reduction + (write-string " Reduction number: ") + (write current-reduction-number) + (newline) + (write-string "Expression (from execution history):") + (pp current-expression) + (print-current-environment false)) + ((debugging-info/undefined-expression? current-expression) + (newline) + (write-string "Unknown expression frame") + (print-current-environment true)) + ((debugging-info/compiled-code? current-expression) + (newline) + (write-string "Compiled code frame") + (print-current-environment true)) + (else + (newline) + (write-string "Expression (from stack):") + (pp current-expression) + (print-current-environment false)))) + +(define (print-current-environment continue-previous-line?) (if-valid-environment current-environment (lambda (environment) - (let ((do-it - (lambda (return?) - (if return? (newline)) - (write-string "within ") - (print-user-friendly-name environment) - (if return? (newline)) - (write-string " applied to ") - (write-string - (cdr - (write-to-string (environment-arguments environment) - environment-arguments-truncation)))))) - (let ((output (with-output-to-string (lambda () (do-it false))))) - (if (< (string-length output) - (output-port/x-size (current-output-port))) - (begin (newline) (write-string output)) - (do-it true))))))) + (if (not continue-previous-line?) + (begin + (newline) + (write-string "Frame"))) + (write-string " created by ") + (print-user-friendly-name environment) + (newline) + (let ((arguments (environment-arguments environment))) + (if (eq? arguments 'UNKNOWN) + (show-environment-bindings environment true) + (begin + (write-string "applied to ") + (write-string + (cdr + (write-to-string arguments + environment-arguments-truncation))))))))) (define (reductions-command) (let loop ((reductions current-reductions)) (cond ((pair? reductions) - (print-expression (reduction-expression (car reductions))) + (pp (reduction-expression (car reductions))) (loop (cdr reductions))) ((wrap-around-in-reductions? reductions) (newline) @@ -196,7 +216,7 @@ MIT in each case. |# current-subproblem (car (last-pair previous-subproblems))))) (newline) - (write-string "Sub Prb. Procedure Name Expression") + (write-string "SL# Procedure Name Expression") (newline) (let loop ((frame top-subproblem) (level 0)) (if frame @@ -225,24 +245,27 @@ MIT in each case. |# (define (terse-print-expression level expression environment) (newline) - (write-string (string-pad-left (number->string level) 3)) + (write-string (string-pad-right (number->string level) 4)) (write-string " ") ;;; procedure name (write-string (string-pad-right - (if (or (not (ic-environment? environment)) - (special-name? (environment-name environment))) - "" - (write-to-truncated-string (environment-name environment) 20)) + (let ((name + (and (environment? environment) + (environment-procedure-name environment)))) + (if (or (not name) + (special-name? name)) + "" + (output-to-string 20 (lambda () (write-dbg-name name))))) 20)) (write-string " ") - (write-string (write-to-truncated-string (unsyntax expression) 50))) - -(define (write-to-truncated-string object n-columns) - (let ((result (write-to-string object n-columns))) - (if (car result) - (string-append (substring (cdr result) 0 (- n-columns 4)) " ...") - (cdr result)))) + (write-string + (cond ((debugging-info/undefined-expression? expression) + "") + ((debugging-info/compiled-code? expression) + "") + (else + (output-to-string 50 (lambda () (write (unsyntax expression)))))))) ;;;; Motion to earlier expressions @@ -389,10 +412,15 @@ MIT in each case. |# (define (show-current-frame) (if-valid-environment current-environment (lambda (environment) - (show-frame environment -1)))) + (show-frame environment -1 false)))) + +(define (show-all-frames) + (if-valid-environment current-environment + (lambda (environment) + (show-frames environment 0)))) (define (enter-where-command) - (with-rep-alternative current-environment debug/where)) + (if-valid-environment current-environment debug/where)) (define (error-info-command) (let ((message (error-message)) @@ -461,17 +489,7 @@ MIT in each case. |# "You are now in the debugger environment" "Debugger-->")) (define user-debug-environment - (let () (the-environment))) - -(define (debug-compiled) - (if debug-compiled-subproblem - (debug-compiled-subproblem current-subproblem) - (begin - (beep) - (newline) - (write-string "The compiled code debugger is not installed")))) - -(define debug-compiled-subproblem false) + (the-environment)) ;;;; Reduction and subproblem motion low-level @@ -530,13 +548,13 @@ MIT in each case. |# reduction-wrap-around-tag)) (define (with-rep-alternative environment receiver) - (if (debugging-info/undefined-environment? environment) + (if (interpreter-environment? environment) + (receiver environment) (begin (print-undefined-environment) (newline) (write-string "Using the read-eval-print environment instead!") - (receiver (nearest-repl/environment))) - (receiver environment))) + (receiver (nearest-repl/environment))))) (define (if-valid-environment environment receiver) (cond ((debugging-info/undefined-environment? environment) @@ -548,16 +566,14 @@ MIT in each case. |# (else (receiver environment)))) +(define (if-valid-ic-environment environment receiver) + (if-valid-environment environment + (if (ic-environment? environment) + receiver + (lambda (environment) + environment + (print-undefined-environment))))) + (define (print-undefined-environment) (newline) - (write-string "Undefined environment at this subproblem/reduction level")) - -(define (print-expression expression) - (cond ((debugging-info/undefined-expression? expression) - (newline) - (write-string "")) - ((debugging-info/compiled-code? expression) - (newline) - (write-string "")) - (else - (pp expression)))) \ No newline at end of file + (write-string "Undefined environment at this subproblem/reduction level")) \ No newline at end of file diff --git a/v7/src/runtime/framex.scm b/v7/src/runtime/framex.scm index 839936e87..b400f0aca 100644 --- a/v7/src/runtime/framex.scm +++ b/v7/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.2 1988/06/13 11:44:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.3 1988/12/30 06:42:40 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -55,8 +55,10 @@ MIT in each case. |# (define-integrable (debugging-info/compiled-code? expression) (eq? expression compiled-code)) -(define-integrable (make-evaluated-object object) - (cons evaluated-object-tag object)) +(define (make-evaluated-object object) + (if (scode-constant? object) + object + (cons evaluated-object-tag object))) (define (debugging-info/evaluated-object? expression) (and (pair? expression) @@ -72,29 +74,28 @@ MIT in each case. |# (define evaluated-object-tag "evaluated") (define (method/standard frame) - (values (stack-frame/ref frame 0) (stack-frame/ref frame 1))) + (values (stack-frame/ref frame 1) (stack-frame/ref frame 2))) (define (method/null frame) frame (values undefined-expression undefined-environment)) (define (method/expression-only frame) - (values (stack-frame/ref frame 0) undefined-environment)) + (values (stack-frame/ref frame 1) undefined-environment)) (define (method/environment-only frame) - (values undefined-expression (stack-frame/ref frame 1))) + (values undefined-expression (stack-frame/ref frame 2))) (define (method/compiled-code frame) - frame - (values compiled-code undefined-environment)) + (values compiled-code (stack-frame/environment frame undefined-environment))) (define (method/primitive-combination-3-first-operand frame) - (values (stack-frame/ref frame 0) (stack-frame/ref frame 2))) + (values (stack-frame/ref frame 1) (stack-frame/ref frame 3))) (define (method/force-snap-thunk frame) (values (make-combination (ucode-primitive force 1) - (list (make-evaluated-object (stack-frame/ref frame 0)))) + (list (make-evaluated-object (stack-frame/ref frame 1)))) undefined-environment)) (define ((method/application-frame index) frame) @@ -104,32 +105,32 @@ MIT in each case. |# undefined-environment)) (define ((method/compiler-reference scode-maker) frame) - (values (scode-maker (stack-frame/ref frame 2)) - (stack-frame/ref frame 1))) + (values (scode-maker (stack-frame/ref frame 3)) + (stack-frame/ref frame 2))) (define ((method/compiler-assignment scode-maker) frame) - (values (scode-maker (stack-frame/ref frame 2) - (make-evaluated-object (stack-frame/ref frame 3))) - (stack-frame/ref frame 1))) + (values (scode-maker (stack-frame/ref frame 3) + (make-evaluated-object (stack-frame/ref frame 4))) + (stack-frame/ref frame 2))) (define ((method/compiler-reference-trap scode-maker) frame) - (values (scode-maker (stack-frame/ref frame 1)) - (stack-frame/ref frame 2))) + (values (scode-maker (stack-frame/ref frame 2)) + (stack-frame/ref frame 3))) (define ((method/compiler-assignment-trap scode-maker) frame) - (values (scode-maker (stack-frame/ref frame 1) - (make-evaluated-object (stack-frame/ref frame 3))) - (stack-frame/ref frame 2))) + (values (scode-maker (stack-frame/ref frame 2) + (make-evaluated-object (stack-frame/ref frame 4))) + (stack-frame/ref frame 3))) (define (method/compiler-lookup-apply-restart frame) - (values (make-combination (stack-frame/ref frame 2) - (stack-frame-list frame 4)) + (values (make-combination (stack-frame/ref frame 3) + (stack-frame-list frame 5)) undefined-environment)) (define (method/compiler-lookup-apply-trap-restart frame) - (values (make-combination (make-variable (stack-frame/ref frame 1)) - (stack-frame-list frame 5)) - (stack-frame/ref frame 2))) + (values (make-combination (make-variable (stack-frame/ref frame 2)) + (stack-frame-list frame 6)) + (stack-frame/ref frame 3))) (define (stack-frame-list frame start) (let ((end (stack-frame/length frame))) @@ -169,7 +170,8 @@ MIT in each case. |# (,method/null COMBINATION-APPLY GC-CHECK - MOVE-TO-ADJACENT-POINT) + MOVE-TO-ADJACENT-POINT + REENTER-COMPILED-CODE) (,method/expression-only ACCESS-CONTINUE @@ -181,19 +183,16 @@ MIT in each case. |# (,method/environment-only REPEAT-DISPATCH) - (,method/compiled-code - REENTER-COMPILED-CODE) - (,method/primitive-combination-3-first-operand PRIMITIVE-COMBINATION-3-FIRST-OPERAND) (,method/force-snap-thunk FORCE-SNAP-THUNK) - (,(method/application-frame 2) + (,(method/application-frame 3) INTERNAL-APPLY) - (,(method/application-frame 0) + (,(method/application-frame 1) REPEAT-PRIMITIVE) (,(method/compiler-reference identity-procedure) @@ -233,4 +232,8 @@ MIT in each case. |# (,method/compiler-lookup-apply-trap-restart COMPILER-LOOKUP-APPLY-TRAP-RESTART - COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)))) \ No newline at end of file + COMPILER-OPERATOR-LOOKUP-TRAP-RESTART))) + (1d-table/put! + (stack-frame-type/properties stack-frame-type/compiled-return-address) + method-tag + method/compiled-code)) \ No newline at end of file diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index 01820ce3f..208b9b2eb 100644 --- a/v7/src/runtime/infutl.scm +++ b/v7/src/runtime/infutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.3 1988/08/05 20:47:32 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.4 1988/12/30 06:42:46 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -32,384 +32,249 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Compiled Code Information +;;;; Compiled Code Information: Utilities ;;; package: (runtime compiler-info) (declare (usual-integrations)) +(declare (integrate-external "infstr")) +(define (compiled-code-block/dbg-info block) + (let ((old-info (compiled-code-block/debugging-info block))) + (if (and (pair? old-info) (dbg-info? (car old-info))) + (car old-info) + (let ((dbg-info (read-debugging-info old-info))) + (if dbg-info + (memoize-debugging-info! block dbg-info)) + dbg-info)))) + +(define (discard-debugging-info!) + (without-interrupts + (lambda () + (map-over-population! blocks-with-memoized-debugging-info + discard-block-debugging-info!) + (set! blocks-with-memoized-debugging-info (make-population)) + unspecific))) + +(define (read-debugging-info descriptor) + (cond ((string? descriptor) + (let ((binf (read-binf-file descriptor))) + (and binf (dbg-info? binf) binf))) ((and (pair? descriptor) + (string? (car descriptor)) + (integer? (cdr descriptor))) + (let ((binf (read-binf-file (car descriptor)))) + (and binf + (dbg-info-vector? binf) + (vector-ref (dbg-info-vector/items binf) (cdr descriptor))))) + (else + false))) + +(define (read-binf-file filename) + (and (file-exists? filename) + (fasload filename true))) +(define (memoize-debugging-info! block dbg-info) + (without-interrupts + (lambda () + (let ((old-info (compiled-code-block/debugging-info block))) + (if (not (and (pair? old-info) (dbg-info? (car old-info)))) + (begin + (set-compiled-code-block/debugging-info! block + (cons dbg-info old-info)) + (add-to-population! blocks-with-memoized-debugging-info + block))))))) + +(define (un-memoize-debugging-info! block) + (without-interrupts + (lambda () + (discard-block-debugging-info! block) + (remove-from-population! blocks-with-memoized-debugging-info block)))) + +(define (discard-block-debugging-info! block) + (let ((old-info (compiled-code-block/debugging-info block))) + (if (and (pair? old-info) (dbg-info? (car old-info))) + (set-compiled-code-block/debugging-info! block (cdr old-info))))) + +(define blocks-with-memoized-debugging-info) + (define (initialize-package!) - (make-value-cache uncached-block->compiler-info - (lambda (compute-value flush-cache) - (set! compiled-code-block->compiler-info compute-value) - (set! flush-compiler-info! flush-cache)))) - -(define-integrable compiler-info-tag - (string->symbol "#[COMPILER-INFO]")) - -(define-integrable compiler-entries-tag - (string->symbol "#[COMPILER-ENTRIES]")) - -(define-structure (compiler-info (named compiler-info-tag)) - (procedures false read-only true) - (continuations false read-only true) - (labels false read-only true)) - -(define-structure (label-info (type vector)) - (name false read-only true) - (offset false read-only true) - (external? false read-only true)) - -;;; Yes, you could be clever and do a number of integrations in this file -;;; however, I don't think speed will be the problem. - -;;; Currently, the info slot is in one of several formats: -;;; -;;; NULL -- There is no info. -;;; -;;; COMPILER-INFO -- Just the structure you see above. -;;; -;;; STRING -- The pathstring of the binf file. -;;; -;;; PAIR -- The CAR is the pathstring -;;; The CDR is either COMPILER-INFO or a NUMBER -;;; indicating the offset into the binf file that -;;; you should use to find the info. - -(define (block->info-slot-contents block if-found if-not-found) - ;; Fetches the contents of the compiler-info slot in a block. - ;; Calls if-not-found if there is no slot (block is manifest-closure). - (if (compiled-code-block/manifest-closure? block) - (if-not-found) - (if-found (compiled-code-block/debugging-info block)))) - -(define (parse-info-slot-contents slot-contents - if-no-info - if-pathstring - if-info - if-pathstring-and-info - if-pathstring-and-offset) - (cond ((null? slot-contents) (if-no-info)) - ((compiler-info? slot-contents) (if-info slot-contents)) - ((string? slot-contents) (if-pathstring slot-contents)) - ((pair? slot-contents) - (if (string? (car slot-contents)) - (cond ((compiler-info? (cdr slot-contents)) - (if-pathstring-and-info (car slot-contents) - (cdr slot-contents))) - ((number? (cdr slot-contents)) - (if-pathstring-and-offset (car slot-contents) - (cdr slot-contents))) - (else (if-no-info))) - (if-no-info))) - (else (if-no-info)))) - -(define (info-slot-contents->pathstring slot-contents if-found if-not-found) - ;; Attempts to get the string denoting the file that the compiler-info - ;; is loaded from. - (parse-info-slot-contents slot-contents - if-not-found - if-found - (lambda (info) info (if-not-found)) - (lambda (pathstring info) - info - (if-found pathstring)) - (lambda (pathstring offset) - offset - (if-found pathstring)))) - -(define (info-slot-contents->compiler-info slot-contents if-found if-not-found) - ;; Attempts to get the compiler info denoted by the contents of the - ;; info slot. - (parse-info-slot-contents slot-contents - if-not-found - (lambda (pathstring) - (on-demand-load pathstring #f if-found if-not-found)) - (lambda (info) - (if-found info)) - (lambda (pathstring info) - pathstring - (if-found info)) - (lambda (pathstring offset) - (on-demand-load pathstring offset if-found if-not-found)))) - -(define *compiler-info/load-on-demand?* #f) - -(define (compiler-info/with-on-demand-loading thunk) - (fluid-let ((*compiler-info/load-on-demand?* #t)) - (thunk))) - -(define (compiler-info/without-on-demand-loading thunk) - (fluid-let ((*compiler-info/load-on-demand?* #f)) - (thunk))) - -;;; The binf file is either a compiler-info structure, or -;;; a vector with a compiler-info structure in it. - -;;; If the binf file is a vector, the offset, obtained from the info slot -;;; in the block, will be the index of the vector slot containing the info. -;;; If there was no offset, the zeroth slot has the info in it. - -(define (on-demand-load pathstring offset if-found if-not-found) - (cond ((not *compiler-info/load-on-demand?*) (if-not-found)) - ((not (file-exists? pathstring)) (if-not-found)) - (else (let ((object (fasload pathstring))) - (if (null? offset) - (if (compiler-info? object) - (if-found object) - (if (and (vector? object) - (> (vector-length object) 0) - (compiler-info? (vector-ref object 0))) - (if-found (vector-ref object 0)) - (if-not-found))) - (if (and (vector? object) - (< offset (vector-length object))) - (let ((possible-info (vector-ref object offset))) - (if (compiler-info? possible-info) - (if-found possible-info) - (if-not-found))) - (if-not-found))))))) - -;; Uncached version will reload the binf file each time. - -(define (block->info block info-hacker if-found if-not-found) - (block->info-slot-contents block - (lambda (contents) - (info-hacker contents if-found if-not-found)) - if-not-found)) - -(define (uncached-block->compiler-info block if-found if-not-found) - (block->info block info-slot-contents->compiler-info if-found if-not-found)) - -(define (compiled-code-block->pathstring block if-found if-not-found) - (block->info block info-slot-contents->pathstring if-found if-not-found)) - -(define flush-compiler-info!) -(define compiled-code-block->compiler-info) - -(define (make-value-cache function receiver) - (let ((cache (make-1d-table))) - - (define (flush-cache!) - (set! cache (make-1d-table)) - 'flushed) - - (define (compute-value argument if-found if-not-found) - (1d-table/lookup cache argument - if-found - (lambda () - (function argument - (lambda (value) - (1d-table/put! cache argument value) - (if-found value)) - if-not-found)))) - - (receiver compute-value flush-cache!))) - -(define (entry->info entry block-info-hacker if-found if-not-found) - (compiled-entry->block-and-offset-indirect entry - (lambda (block offset) - offset - (block-info-hacker block if-found if-not-found)) - if-not-found)) - -(define (compiled-entry->pathstring entry if-found if-not-found) - (entry->info entry compiled-code-block->pathstring if-found if-not-found)) - -(define (compiled-entry->pathname entry if-found if-not-found) - (compiled-entry->pathstring entry - (lambda (pathstring) - (if-found (string->pathname pathstring))) - if-not-found)) - -(define (info-file object) - (and (compiled-code-address? object) - (pathname-name (compiled-entry->pathname object - identity-procedure - false-procedure)))) - -(define (compiled-entry->compiler-info entry if-found if-not-found) - (entry->info entry compiled-code-block->compiler-info if-found if-not-found)) - -;;; This switch gets turned on when the implementation for -;;; INDIRECT-THROUGH-MANIFEST-CLOSURE is present. -;;; The mechanism for indirecting through a manifest closure -;;; is highly machine dependent. - -(define *indirect-through-manifest-closure? #f) -(define indirect-through-manifest-closure) - -(define (compiled-entry->block-and-offset entry - if-block - if-manifest-closure - if-failed) - (let ((block (compiled-code-address->block entry)) - (offset (compiled-code-address->offset entry))) - (if (compiled-code-block/manifest-closure? block) - (if *indirect-through-manifest-closure? - (indirect-through-manifest-closure entry - (lambda (indirect-block indirect-offset) - (if-manifest-closure - block offset indirect-block indirect-offset)) - (lambda () (if-failed))) - (if-failed)) - (if-block block offset)))) - -(define (compiled-entry->block-and-offset-indirect - entry if-found if-not-found) - (compiled-entry->block-and-offset entry - if-found - (lambda (closure-block closure-offset block offset) - closure-block closure-offset - (if-found block offset)) - if-not-found)) - -(define (block-symbol-table block if-found if-not-found) - (compiled-code-block->compiler-info block - (lambda (info) - (if-found (compiler-info/symbol-table info))) - if-not-found)) - -(define (compiled-entry->name compiled-entry if-found if-not-found) - (define (block-and-offset->name block offset) - (block-symbol-table block - (lambda (symbol-table) - (sorted-vector/lookup symbol-table offset - (lambda (label-info) - (if-found (label-info-name label-info))) - if-not-found)) - if-not-found)) - - (compiled-entry->block-and-offset compiled-entry - block-and-offset->name - (lambda (manifest-block manifest-offset block offset) - manifest-block manifest-offset - (block-and-offset->name block offset)) - if-not-found)) - -(define (compiler-info/symbol-table compiler-info) - (make-sorted-vector (compiler-info-labels compiler-info) - (lambda (offset label-info) - (= offset (label-info-offset label-info))) - (lambda (offset label-info) - (< offset (label-info-offset label-info))))) - -(define (lookup-label labels label-name if-found if-not-found) - (let ((limit (vector-length labels))) - (let loop ((index 0)) - (if (= index limit) - (if-not-found) - (let ((this-label (vector-ref labels index))) - (if (string-ci=? label-name (label-info-name this-label)) - (if-found index this-label) - (loop (1+ index)))))))) - -(define (label->offset labels name if-found if-not-found) - (lookup-label labels name - (lambda (vector-index label-info) - vector-index - (if-found (label-info-offset label-info))) - if-not-found)) + (set! blocks-with-memoized-debugging-info (make-population)) + unspecific) -;;;; Binary Search - -(define-structure (sorted-vector - (conc-name sorted-vector/) - (constructor %make-sorted-vector)) - (vector false read-only true) - (key=? false read-only true) - (key-compare false read-only true)) - -(define (make-sorted-vector vector key=? key) - ((cond ((key=? key entry) if=) - ((key)))))) - -(define (sorted-vector/find-element sorted-vector key) - (let ((vector (sorted-vector/vector sorted-vector))) - (vector-binary-search vector - key - (sorted-vector/key-compare sorted-vector) - (lambda (index) (vector-ref vector index)) - (lambda () false)))) - -(define (sorted-vector/lookup sorted-vector key if-found if-not-found) - (let ((vector (sorted-vector/vector sorted-vector))) - (vector-binary-search vector - key - (sorted-vector/key-compare sorted-vector) - (lambda (index) (if-found (vector-ref vector index))) - (lambda () (if-not-found))))) - -(define (sorted-vector/find-indices sorted-vector key if-found if-not-found) - (vector-binary-search-range (sorted-vector/vector sorted-vector) - key - (sorted-vector/key=? sorted-vector) - (sorted-vector/key-compare sorted-vector) - if-found - if-not-found)) - -(define (sorted-vector/there-exists? sorted-vector key predicate) - (sorted-vector/find-indices sorted-vector key - (lambda (low high) - (let ((vector (sorted-vector/vector sorted-vector))) - (let loop ((index low)) - (if (predicate (vector-ref vector index)) - true - (and (< index high) - (loop (1+ index))))))) - (lambda () false))) - -(define (sorted-vector/for-each sorted-vector key procedure) - (sorted-vector/find-indices sorted-vector key - (lambda (low high) - (let ((vector (sorted-vector/vector sorted-vector))) - (let loop ((index low)) - (procedure (vector-ref vector index)) - (if (< index high) - (loop (1+ index)))))) - (lambda () unspecific))) +(define (compiled-entry/dbg-object entry) + (let ((block (compiled-entry/block entry)) + (offset (compiled-entry/offset entry))) + (let ((dbg-info (compiled-code-block/dbg-info block))) + (discriminate-compiled-entry entry + (lambda () + (vector-binary-search (dbg-info/procedures dbg-info) + < + dbg-procedure/label-offset + offset)) + (lambda () + (vector-binary-search (dbg-info/continuations dbg-info) + < + dbg-continuation/label-offset + offset)) + (lambda () + (let ((expression (dbg-info/expression dbg-info))) + (and (= offset (dbg-expression/label-offset expression)) + expression))) + (lambda () + false))))) + +(define (compiled-entry/block entry) + (if (compiled-closure? entry) + (compiled-entry/block (compiled-closure->entry entry)) + (compiled-code-address->block entry))) + +(define (compiled-entry/offset entry) + (if (compiled-closure? entry) + (compiled-entry/offset (compiled-closure->entry entry)) + (compiled-code-address->offset entry))) + +(define (compiled-entry/filename entry) + (let loop + ((info + (compiled-code-block/debugging-info (compiled-entry/block entry)))) + (cond ((string? info) + info) + ((pair? info) + (cond ((string? (car info)) (car info)) + ((dbg-info? (car info)) (loop (cdr info))) + (else false))) + (else + false)))) + +(define (compiled-procedure/name entry) + (and *compiler-info/load-on-demand?* + (let ((procedure (compiled-entry/dbg-object entry))) + (and procedure + (dbg-procedure/name procedure))))) + +(define *compiler-info/load-on-demand?* + false) + +(define (dbg-labels/find-offset labels offset) + (vector-binary-search labels < dbg-label/offset offset)) + +(define (vector-binary-search vector < unwrap-key key) + (let loop ((start 0) (end (vector-length vector))) + (and (< start end) + (let ((midpoint (quotient (+ start end) 2))) + (let ((item (vector-ref vector midpoint))) + (let ((key* (unwrap-key item))) + (cond ((< key key*) (loop start midpoint)) + ((< key* key) (loop (1+ midpoint) end)) + (else item)))))))) +(define (fasload/update-debugging-info! value com-pathname) + (let ((process-filename + (lambda (binf-filename) + (let ((binf-pathname (string->pathname binf-filename))) + (if (and (equal? (pathname-name binf-pathname) + (pathname-name com-pathname)) + (not (equal? (pathname-type binf-pathname) + (pathname-type com-pathname))) + (equal? (pathname-version binf-pathname) + (pathname-version com-pathname))) + (pathname->string + (pathname-new-type com-pathname + (pathname-type binf-pathname))) + binf-filename))))) + (let ((process-entry + (lambda (entry) + (let ((block (compiled-code-address->block entry))) + (let ((info (compiled-code-block/debugging-info block))) + (cond ((string? info) + (set-compiled-code-block/debugging-info! + block + (process-filename info))) + ((and (pair? info) (string? (car info))) + (set-car! info (process-filename (car info)))))))))) + (cond ((compiled-code-address? value) + (process-entry value)) + ((comment? value) + (let ((text (comment-text value))) + (if (dbg-info-vector? text) + (for-each + process-entry + (vector->list (dbg-info-vector/items text)))))))))) + +(define (dbg-block/dynamic-link-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/dynamic-link)) + +(define (dbg-block/ic-parent-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/ic-parent)) + +(define (dbg-block/normal-closure-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/normal-closure)) + +(define (dbg-block/return-address-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/return-address)) + +(define (dbg-block/static-link-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/static-link)) + +(define (dbg-block/find-name block name) + (let ((layout (dbg-block/layout block))) + (let ((end (vector-length layout))) + (let loop ((index 0)) + (and (< index end) + (if (dbg-name=? name (vector-ref layout index)) + index + (loop (1+ index)))))))) -(define (vector-binary-search-range vector key key=? compare if-found - if-not-found) - (vector-binary-search vector key compare - (lambda (index) - (if-found (let loop ((index index)) - (if (zero? index) - index - (let ((index* (-1+ index))) - (if (key=? key (vector-ref vector index*)) - (loop index*) - index)))) - (let ((end (-1+ (vector-length vector)))) - (let loop ((index index)) - (if (= index end) - index - (let ((index* (1+ index))) - (if (key=? key (vector-ref vector index*)) - (loop index*) - index))))))) - if-not-found)) - -(define (vector-binary-search vector key compare if-found if-not-found) - (let loop ((low 0) (high (-1+ (vector-length vector)))) - (if (< high low) - (if-not-found) - (let ((index (quotient (+ high low) 2))) - (compare key - (vector-ref vector index) - (lambda () (if-found index)) - (lambda () (loop low (-1+ index))) - (lambda () (loop (1+ index) high))))))) - -(define (vector-linear-search vector key compare if-found if-not-found) - (let ((limit (length vector))) - (let loop ((index 0)) - (if (> index limit) - (if-not-found) - (compare key - (vector-ref vector index) - (lambda () (if-found index)) - (lambda () (loop (1+ index)))))))) \ No newline at end of file +(define-integrable (symbol->dbg-name symbol) + (cond ((object-type? (ucode-type interned-symbol) symbol) + (system-pair-car symbol)) + ((object-type? (ucode-type uninterned-symbol) symbol) + symbol) + (else + (error "SYMBOL->DBG-NAME: not a symbol" symbol)))) + +(define (dbg-name? object) + (or (string? object) + (object-type? (ucode-type interned-symbol) object) + (object-type? (ucode-type uninterned-symbol) object))) + +(define (dbg-name/normal? object) + (or (string? object) + (object-type? (ucode-type uninterned-symbol) object))) + +(define (dbg-name=? x y) + (or (eq? x y) + (let ((name->string + (lambda (name) + (cond ((string? name) + name) + ((object-type? (ucode-type interned-symbol) name) + (system-pair-car name)) + (else + false))))) + (let ((x (name->string x)) (y (name->string y))) + (and x y (string-ci=? x y)))))) + +(define (dbg-namestring + (lambda (name) + (cond ((string? name) + name) + ((or (object-type? (ucode-type interned-symbol) name) + (object-type? (ucode-type uninterned-symbol) name)) + (system-pair-car name)) + (else + (error "Illegal dbg-name" name)))))) + (string-cistring x) (name->string y)))) + +(define (dbg-name/string name) + (cond ((string? name) + name) + ((object-type? (ucode-type interned-symbol) name) + (system-pair-car name)) + ((object-type? (ucode-type uninterned-symbol) name) + (write-to-string name)) + (else + (error "Illegal dbg-name" name)))) \ No newline at end of file diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm index 0d6e32c35..730ae3fda 100644 --- a/v7/src/runtime/lambda.scm +++ b/v7/src/runtime/lambda.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.3 1988/10/29 00:12:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.4 1988/12/30 06:42:58 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -97,6 +97,11 @@ MIT in each case. |# set-clambda-unwrapped-body! set-clexpr-unwrapped-body! set-xlambda-unwrapped-body!)) + (set! lambda-name + (dispatch-0 'LAMBDA-NAME + slambda-name + slexpr-name + xlambda-name)) (set! lambda-bound (dispatch-0 'LAMBDA-BOUND clambda-bound @@ -333,6 +338,9 @@ MIT in each case. |# (vector-length bound)) (xlambda-unwrapped-body xlambda)))))))) +(define (xlambda-name xlambda) + (vector-ref (&triple-second xlambda) 0)) + (define (xlambda-bound xlambda) (let ((names (&triple-second xlambda))) (subvector->list names 1 (vector-length names)))) @@ -405,6 +413,7 @@ MIT in each case. |# (define lambda-unwrap-body!) (define lambda-body) (define set-lambda-body!) +(define lambda-name) (define lambda-bound) (define-structure (block-declaration @@ -452,6 +461,9 @@ MIT in each case. |# (subvector->list bound 1 (vector-length bound)) (&pair-car slexpr)))) +(define-integrable (slexpr-name slexpr) + (vector-ref (&pair-cdr slexpr) 0)) + (define-integrable (slexpr-body slexpr) (&pair-car slexpr)) diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 713aad527..cac8985a1 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.4 1988/08/05 20:47:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.5 1988/12/30 06:43:04 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -53,18 +53,28 @@ MIT in each case. |# (lambda (port) (stream->list (read-stream port))))) -(define (fasload filename) +(define (fasload filename #!optional quiet?) (fasload/internal - (find-true-filename (->pathname filename) fasload/default-types))) - -(define (fasload/internal true-filename) - (let ((port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "FASLoading " port) - (write true-filename port) - (let ((value ((ucode-primitive binary-fasload) true-filename))) - (write-string " -- done" port) - value))) + (find-true-pathname (->pathname filename) fasload/default-types) + (if (default-object? quiet?) false quiet?))) + +(define (fasload/internal true-pathname quiet?) + (let ((value + (let ((true-filename (pathname->string true-pathname))) + (let ((do-it + (lambda () + ((ucode-primitive binary-fasload) true-filename)))) + (if quiet? + (do-it) + (let ((port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "FASLoading " port) + (write true-filename port) + (let ((value (do-it))) + (write-string " -- done" port) + value))))))) + (fasload/update-debugging-info! value true-pathname) + value)) (define (load-noisily filename #!optional environment syntax-table purify?) (fluid-let ((load-noisily? true)) @@ -108,7 +118,7 @@ MIT in each case. |# (let ((value (let ((pathname (->pathname filename))) (load/internal pathname - (find-true-filename pathname + (find-true-pathname pathname load/default-types) environment syntax-table @@ -127,37 +137,37 @@ MIT in each case. |# (define default-object "default-object") -(define (load/internal pathname true-filename environment syntax-table +(define (load/internal pathname true-pathname environment syntax-table purify? load-noisily?) - (let ((port (open-input-file/internal pathname true-filename))) + (let ((port + (open-input-file/internal pathname (pathname->string true-pathname)))) (if (= 250 (char->ascii (peek-char port))) (begin (close-input-port port) - (scode-eval (let ((scode (fasload/internal true-filename))) - (if purify? (purify scode)) - scode) - (if (eq? environment default-object) - (nearest-repl/environment) - environment))) + (scode-eval + (let ((scode (fasload/internal true-pathname false))) + (if purify? (purify scode)) + scode) + (if (eq? environment default-object) + (nearest-repl/environment) + environment))) (write-stream (eval-stream (read-stream port) environment syntax-table) (if load-noisily? (lambda (value) (hook/repl-write (nearest-repl) value)) (lambda (value) value false)))))) -(define (find-true-filename pathname default-types) - (pathname->string - (or (let ((try - (lambda (pathname) - (pathname->input-truename - (pathname-default-version pathname 'NEWEST))))) - (if (pathname-type pathname) - (try pathname) - (or (pathname->input-truename pathname) - (let loop ((types default-types)) - (and (not (null? types)) - (or (try (pathname-new-type pathname (car types))) - (loop (cdr types)))))))) - (error "No such file" pathname)))) - +(define (find-true-pathname pathname default-types) + (or (let ((try + (lambda (pathname) + (pathname->input-truename + (pathname-default-version pathname 'NEWEST))))) + (if (pathname-type pathname) + (try pathname) + (or (pathname->input-truename pathname) + (let loop ((types default-types)) + (and (not (null? types)) + (or (try (pathname-new-type pathname (car types))) + (loop (cdr types)))))))) + (error "No such file" pathname))) (define (read-stream port) (parse-objects port (current-parser-table) diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index 7d5f50c0b..f072ef0bb 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.5 1988/10/29 00:12:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.6 1988/12/30 06:43:09 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -68,6 +68,10 @@ MIT in each case. |# (loop (cdr path) child)))))) (define (environment->package environment) + (and (interpreter-environment? environment) + (interpreter-environment->package environment))) + +(define (interpreter-environment->package environment) (and (not (lexical-unreferenceable? environment package-name-tag)) (let ((package (lexical-reference environment package-name-tag))) (and (package? package) @@ -97,7 +101,7 @@ MIT in each case. |# (error "Package already has child of given name" package name)) (let ((child (make-package package name environment))) (set-package/children! package (cons child (package/children package))) - (if (not (environment->package environment)) + (if (not (interpreter-environment->package environment)) (local-assignment environment package-name-tag child)) child)) @@ -124,7 +128,10 @@ MIT in each case. |# (define (initialize-package!) (set! system-global-package - (make-package false false system-global-environment))) + (make-package false false system-global-environment)) + (local-assignment system-global-environment + package-name-tag + system-global-package)) (define (initialize-unparser!) (unparser/set-tagged-vector-method! package diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index d2efc32d6..146923908 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.22 1988/10/29 00:12:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.23 1988/12/30 06:43:14 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -207,45 +207,38 @@ MIT in each case. |# (initialization (initialize-package!))) (define-package (runtime compiler-info) - (files "infutl") + (files "infstr" "infutl") (parent ()) (export () - compiler-info? - make-compiler-info - compiler-info-procedures - compiler-info-continuations - compiler-info-labels - - make-label-info - label-info-name - label-info-offset - label-info-external? - *compiler-info/load-on-demand?* - compiler-info/with-on-demand-loading - compiler-info/without-on-demand-loading - flush-compiler-info! - - make-sorted-vector - sorted-vector/vector - sorted-vector/find-element - sorted-vector/lookup - sorted-vector/find-indices - sorted-vector/there-exists? - sorted-vector/for-each - - compiler-info/symbol-table - block-symbol-table - compiled-code-block->pathstring - compiled-code-block->compiler-info - - compiled-entry->name - compiled-entry->pathname - compiled-entry->compiler-info - compiled-entry->block-and-offset - compiled-entry->block-and-offset-indirect - info-file - ) + compiled-entry/block + compiled-entry/dbg-object + compiled-entry/filename + compiled-entry/offset + compiled-procedure/name + discard-debugging-info!) + (export (runtime load) fasload/update-debugging-info!) + (export (runtime debugger-utilities) + dbg-nametype stack-frame->continuation - stack-frame-type/address stack-frame-type/code + stack-frame-type/compiled-return-address stack-frame-type/properties stack-frame-type/subproblem? stack-frame-type? @@ -301,9 +294,11 @@ MIT in each case. |# stack-frame/length stack-frame/next stack-frame/next-subproblem + stack-frame/offset stack-frame/properties stack-frame/reductions stack-frame/ref + stack-frame/resolve-stack-address stack-frame/return-address stack-frame/return-code stack-frame/skip-non-subproblems @@ -319,6 +314,7 @@ MIT in each case. |# control-point/element-stream control-point/history control-point/interrupt-mask + control-point/n-elements control-point/next-control-point control-point/previous-history-control-point control-point/previous-history-offset @@ -358,10 +354,13 @@ MIT in each case. |# (parent (runtime debugger-command-loop)) (export (runtime debugger-command-loop) debug/read-eval-print-1 - environment-name + output-to-string print-user-friendly-name + show-environment-bindings show-frame - special-name?) + show-frames + special-name? + write-dbg-name) (initialization (initialize-package!))) (define-package (runtime debugging-info) @@ -404,15 +403,23 @@ MIT in each case. |# (parent ()) (export () environment-arguments - environment-bindings + environment-bound-names + environment-bound? environment-has-parent? + environment-lookup environment-parent - environment-procedure + environment-procedure-name environment? ic-environment? - remove-environment-parent! - set-environment-parent! - system-global-environment?)) + interpreter-environment? + system-global-environment?) + (export (runtime advice) + ic-environment/arguments + ic-environment/procedure) + (export (runtime debugger) + ic-environment/procedure) + (export (runtime debugging-info) + stack-frame/environment)) (define-package (runtime environment-inspector) (files "where") @@ -672,6 +679,7 @@ MIT in each case. |# lambda-body lambda-bound lambda-components + lambda-name make-block-declaration make-lambda set-lambda-body!) @@ -1506,6 +1514,7 @@ MIT in each case. |# stream->list stream-car stream-cdr + stream-head stream-length stream-map stream-null? diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm index 948dd2e5f..6d2f8600c 100644 --- a/v7/src/runtime/stream.scm +++ b/v7/src/runtime/stream.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 14.1 1988/06/13 11:51:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 14.2 1988/12/30 06:43:22 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -77,6 +77,17 @@ MIT in each case. |# (error "STREAM-REF: index too large" index)) (stream-car tail))) +(define (stream-head stream index) + (if (not (and (integer? index) (not (negative? index)))) + (error "STREAM-HEAD: index must be nonnegative integer" index)) + (let loop ((stream stream) (index index)) + (if (zero? index) + '() + (begin + (if (not (stream-pair? stream)) + (error "STREAM-HEAD: stream has too few elements" stream index)) + (cons (stream-car stream) (loop (stream-cdr stream) (-1+ index))))))) + (define (stream-tail stream index) (if (not (and (integer? index) (not (negative? index)))) (error "STREAM-TAIL: index must be nonnegative integer" index)) (let loop ((stream stream) (index index)) diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm index bcc7f4dd0..106b5b875 100644 --- a/v7/src/runtime/udata.scm +++ b/v7/src/runtime/udata.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.5 1988/11/08 06:55:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.6 1988/12/30 06:43:27 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -37,7 +37,11 @@ MIT in each case. |# (declare (usual-integrations)) -(define-integrable (return-address? object) +(define (return-address? object) + (or (interpreter-return-address? object) + (compiled-return-address? object))) + +(define-integrable (interpreter-return-address? object) (object-type? (ucode-type return-address) object)) (define-integrable (make-return-address code) @@ -72,34 +76,46 @@ MIT in each case. |# (define-integrable (compiled-code-address? object) (object-type? (ucode-type compiled-entry) object)) -(define (discriminate-compiled-entry object +(define-integrable (stack-address? object) + (object-type? (ucode-type stack-environment) object)) + +(define (compiled-procedure? object) + (and (compiled-code-address? object) + (eq? (compiled-entry-type object) 'COMPILED-PROCEDURE))) + +(define (compiled-return-address? object) + (and (compiled-code-address? object) + (eq? (compiled-entry-type object) 'COMPILED-RETURN-ADDRESS))) + +(define (compiled-closure? object) + (and (compiled-procedure? object) + (compiled-code-block/manifest-closure? + (compiled-code-address->block object)))) + +(define-primitives + (compiled-closure->entry 1) + (stack-address-offset 1) + (compiled-code-address->block 1) + (compiled-code-address->offset 1)) + +(define (discriminate-compiled-entry entry if-procedure if-return-address if-expression if-other) - (case (system-hunk3-cxr0 ((ucode-primitive compiled-entry-kind 1) object)) + (case (system-hunk3-cxr0 ((ucode-primitive compiled-entry-kind 1) entry)) ((0) (if-procedure)) ((1) (if-return-address)) ((2) (if-expression)) (else (if-other)))) -(define (compiled-entry-type object) - (discriminate-compiled-entry object - (lambda () 'COMPILED-PROCEDURE) - (lambda () 'COMPILED-RETURN-ADDRESS) - (lambda () 'COMPILED-EXPRESSION) - (lambda () 'COMPILED-ENTRY))) - -(define-integrable compiled-code-address->block - (ucode-primitive compiled-code-address->block)) - -(define-integrable compiled-code-address->offset - (ucode-primitive compiled-code-address->offset)) - -(define (compiled-procedure? object) - (and (compiled-code-address? object) - (eq? (compiled-entry-type object) 'COMPILED-PROCEDURE))) - +(define (compiled-entry-type entry) + (case (system-hunk3-cxr0 ((ucode-primitive compiled-entry-kind 1) entry)) + ((0) 'COMPILED-PROCEDURE) + ((1) 'COMPILED-RETURN-ADDRESS) + ((2) 'COMPILED-EXPRESSION) + (else 'COMPILED-ENTRY))) + (define (compiled-procedure-arity object) (let ((info ((ucode-primitive compiled-entry-kind 1) object))) (if (not (= (system-hunk3-cxr0 info) 0)) @@ -108,13 +124,26 @@ MIT in each case. |# (let ((max (system-hunk3-cxr2 info))) (and (not (negative? max)) (-1+ max)))))) -(define (compiled-closure? object) - (and (compiled-procedure? object) - (compiled-code-block/manifest-closure? - (compiled-code-address->block object)))) - -(define-primitives (compiled-closure->entry 1)) - +(define (compiled-continuation/next-continuation-offset entry) + (let ((offset + (system-hunk3-cxr2 ((ucode-primitive compiled-entry-kind 1) entry)))) + (and (not (negative? offset)) + offset))) + +(define-integrable (compiled-continuation/return-to-interpreter? entry) + (= 2 (system-hunk3-cxr1 ((ucode-primitive compiled-entry-kind 1) entry)))) + +(define (stack-address->index address start-offset) + (if (not (stack-address? address)) + (error "Not a stack address" address)) + (let ((index (- start-offset (stack-address-offset address)))) + (if (negative? index) + (error "Stack address out of range" address start-offset)) + index)) + +(define-integrable (compiled-closure/ref closure index) + ;; 68020 specific -- must be rewritten in compiler interface. + ((ucode-primitive primitive-object-ref 2) closure (+ 2 index))) ;;; These are now pretty useless. (define (compiled-procedure-entry procedure) diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 7f1fcf9cf..844f9261e 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.3 1988/08/01 23:08:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.4 1988/12/30 06:43:34 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -37,91 +37,190 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Environment - (define (environment? object) - (if (system-global-environment? object) - true + (or (system-global-environment? object) + (ic-environment? object) + (stack-ccenv? object) + (closure-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)))) + +(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)))) + +(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)))) + +(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)) + 'UNKNOWN) + (else (error "Illegal environment" environment)))) + +(define (environment-procedure-name environment) + (cond ((system-global-environment? environment) + false) + ((ic-environment? environment) + (ic-environment/procedure-name environment)) + ((stack-ccenv? environment) + (stack-ccenv/procedure-name environment)) + ((closure-ccenv? environment) + (closure-ccenv/procedure-name environment)) + (else (error "Illegal environment" environment)))) + +(define (environment-bound? environment name) + (cond ((system-global-environment? environment) + (system-global-environment/bound? environment name)) + ((ic-environment? environment) + (ic-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)))) + +(define (environment-lookup environment name) + (cond ((system-global-environment? environment) + (system-global-environment/lookup environment name)) + ((ic-environment? environment) + (ic-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)))) + +;;;; Interpreter Environments + +(define (interpreter-environment? object) + (or (system-global-environment? object) (ic-environment? object))) (define-integrable (system-global-environment? object) (eq? system-global-environment object)) +(define (system-global-environment/bound? environment name) + (not (lexical-unbound? environment name))) + +(define (system-global-environment/lookup environment name) + (if (lexical-unassigned? environment name) + (make-unassigned-reference-trap) + (lexical-reference environment name))) + +(define (system-global-environment/bound-names environment) + (let ((table (fixed-objects-item 'OBARRAY))) + (let per-bucket ((index (-1+ (vector-length table))) (accumulator '())) + (if (< index 0) + accumulator + (let per-symbol + ((bucket (vector-ref table index)) + (accumulator accumulator)) + (if (null? bucket) + (per-bucket (-1+ index) accumulator) + (per-symbol + (cdr bucket) + (if (not (lexical-unbound? environment (car bucket))) + (cons (car bucket) accumulator) + accumulator)))))))) + (define-integrable (ic-environment? object) (object-type? (ucode-type environment) object)) -(define (environment-procedure environment) - (select-procedure (environment->external environment))) +(define (guarantee-ic-environment object) + (if (not (ic-environment? object)) + (error "Bad IC environment" object)) + object) -(define (environment-has-parent? environment) - (and (ic-environment? environment) - (not (eq? (select-parent (environment->external environment)) - null-environment)))) +(define (ic-environment/procedure-name environment) + (lambda-name (procedure-lambda (ic-environment/procedure environment)))) -(define (environment-parent environment) - (select-parent (environment->external environment))) - -(define (environment-bindings environment) - (environment-split environment - (lambda (external internal) - (map (lambda (name) - (cons name - (if (lexical-unassigned? internal name) - '() - `(,(lexical-reference internal name))))) - (list-transform-negative - (map* (lambda-bound (select-lambda external)) - car - (let ((extension (environment-extension internal))) - (if (environment-extension? extension) - (environment-extension-aux-list extension) - '()))) - (lambda (name) - (lexical-unbound? internal name))))))) +(define (ic-environment/has-parent? environment) + (not (eq? (ic-environment/parent environment) null-environment))) -(define (environment-arguments environment) - (environment-split environment - (lambda (external internal) +(define (ic-environment/parent environment) + (select-parent (ic-environment->external environment))) + +(define (ic-environment/bound-names environment) + (list-transform-negative + (map* (lambda-bound + (select-lambda (ic-environment->external environment))) + car + (let ((extension (ic-environment/extension environment))) + (if (environment-extension? extension) + (environment-extension-aux-list extension) + '()))) + (lambda (name) + (lexical-unbound? environment name)))) + +(define (ic-environment/bound? environment name) + (not (lexical-unbound? environment name))) + +(define (ic-environment/lookup environment name) + (if (lexical-unassigned? environment name) + (make-unassigned-reference-trap) + (lexical-reference environment name))) + +(define (ic-environment/arguments environment) + (lambda-components* (select-lambda (ic-environment->external environment)) + (lambda (name required optional rest body) + name body (let ((lookup (lambda (name) - (if (lexical-unassigned? internal name) - (make-unassigned-reference-trap) - (lexical-reference internal name))))) - (lambda-components* (select-lambda external) - (lambda (name required optional rest body) - name body - (map* (let loop ((names optional)) - (cond ((null? names) (if rest (lookup rest) '())) - ((lexical-unassigned? internal (car names)) '()) - (else - (cons (lookup (car names)) (loop (cdr names)))))) - lookup - required))))))) - -(define (set-environment-parent! environment parent) + (ic-environment/lookup environment name)))) + (map* (map* (if rest (lookup rest) '()) + lookup + optional) + lookup + required))))) + +(define (ic-environment/procedure environment) + (select-procedure (ic-environment->external environment))) + +(define (ic-environment/set-parent! environment parent) (system-pair-set-cdr! - (let ((extension (environment-extension environment))) + (let ((extension (ic-environment/extension environment))) (if (environment-extension? extension) (begin (set-environment-extension-parent! extension parent) (environment-extension-procedure extension)) extension)) parent)) -(define (remove-environment-parent! environment) - (set-environment-parent! environment null-environment)) +(define (ic-environment/remove-parent! environment) + (ic-environment/set-parent! environment null-environment)) (define null-environment (object-new-type (ucode-type null) 1)) -(define (environment-split environment receiver) - (let ((procedure (select-procedure environment))) - (let ((lambda (compound-procedure-lambda procedure))) - (receiver (if (internal-lambda? lambda) - (compound-procedure-environment procedure) - environment) - environment)))) - -(define (environment->external environment) +(define (ic-environment->external environment) (let ((procedure (select-procedure environment))) (if (internal-lambda? (compound-procedure-lambda procedure)) (compound-procedure-environment procedure) @@ -142,5 +241,35 @@ MIT in each case. |# (define (select-lambda environment) (compound-procedure-lambda (select-procedure environment))) -(define (environment-extension environment) - (select-extension (environment->external environment))) \ No newline at end of file +(define (ic-environment/extension environment) + (select-extension (ic-environment->external environment))) + +;;;; Compiled Code Environments + +(define-structure (stack-ccenv + (named + (string->symbol "#[(runtime environment)stack-ccenv]")) + (conc-name stack-ccenv/)) + (block false read-only true) + (frame false read-only true) + (start-index false read-only true)) + +(define (stack-frame/environment frame default) + (let ((continuation + (compiled-entry/dbg-object (stack-frame/return-address frame)))) + (if continuation + (let ((block (dbg-continuation/block continuation))) + (let ((parent (dbg-block/parent block))) + (case (dbg-block/type parent) + ((STACK) + (make-stack-ccenv parent + frame + (1+ (dbg-continuation/offset continuation)))) + ((IC) + (let ((index (dbg-block/ic-parent-index block))) + (if index + (guarantee-ic-environment (stack-frame/ref frame index)) + default))) + (else + (error "Illegal continuation parent" parent))))) + default))) \ No newline at end of file diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index 1bb4a2143..af13c1724 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.5 1988/08/11 03:13:57 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.6 1988/12/30 06:43:40 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -81,14 +81,16 @@ MIT in each case. |# (continuation/first-subproblem (current-proceed-continuation)))) (let ((translator - (let ((entry (assv (stack-frame/return-code frame) alist))) - (and entry - (let loop ((translators (cdr entry))) - (and (not (null? translators)) - (if (or (eq? (caar translators) true) - ((caar translators) frame)) - (cdar translators) - (loop (cdr translators))))))))) + (let ((return-code (stack-frame/return-code frame))) + (and return-code + (let ((entry (assv return-code alist))) + (and entry + (let loop ((translators (cdr entry))) + (and (not (null? translators)) + (if (or (eq? (caar translators) true) + ((caar translators) frame)) + (cdar translators) + (loop (cdr translators))))))))))) (if translator (translator error-type frame) (make-error-condition error-type:missing-handler @@ -108,25 +110,25 @@ MIT in each case. |# ;;;; Frame Decomposition (define-integrable (standard-frame/expression frame) - (stack-frame/ref frame 0)) + (stack-frame/ref frame 1)) (define-integrable (standard-frame/environment frame) - (stack-frame/ref frame 1)) + (stack-frame/ref frame 2)) (define (standard-frame/variable? frame) (variable? (standard-frame/expression frame))) (define-integrable (expression-only-frame/expression frame) - (stack-frame/ref frame 0)) + (stack-frame/ref frame 1)) (define-integrable (internal-apply-frame/operator frame) - (stack-frame/ref frame 2)) + (stack-frame/ref frame 3)) (define-integrable (internal-apply-frame/operand frame index) - (stack-frame/ref frame (+ 3 index))) + (stack-frame/ref frame (+ 4 index))) (define-integrable (internal-apply-frame/n-operands frame) - (- (stack-frame/length frame) 3)) + (- (stack-frame/length frame) 4)) (define (internal-apply-frame/select frame selector) (if (integer? selector) (internal-apply-frame/operand frame selector) @@ -441,8 +443,8 @@ MIT in each case. |# (lambda (condition-type frame) (make-error-condition condition-type - (list (stack-frame/ref frame 1)) - (stack-frame/ref frame 2))))) + (list (stack-frame/ref frame 2)) + (stack-frame/ref frame 3))))) (define-standard-frame-handler 'UNBOUND-VARIABLE 'EVAL-ERROR standard-frame/variable? variable-name) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index 106fff7cc..2ab2b0c8d 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.9 1988/11/08 06:55:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.10 1988/12/30 06:43:48 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -442,8 +442,6 @@ MIT in each case. |# (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false (lambda () (*unparse-object (primitive-procedure-name procedure))))) - -;;;; Compiled entries (define (unparse/compiled-entry entry) (let* ((type (compiled-entry-type entry)) @@ -455,47 +453,27 @@ MIT in each case. |# (if closure? 'COMPILED-CLOSURE type) entry (lambda () - (let ((entry* (if closure? (compiled-closure->entry entry) entry))) - (*unparse-object - (or (and (eq? type 'COMPILED-PROCEDURE) - (compiled-procedure/name entry*)) - (compiled-entry/filename entry*) - '())) - (*unparse-char #\Space) - (*unparse-hex (compiled-code-address->offset entry*)) - (*unparse-char #\Space) - (*unparse-datum entry*) - (if closure? - (begin (*unparse-char #\Space) - (*unparse-datum entry)))))))) - -(define (compiled-procedure/name entry) - (compiled-entry->name entry - (lambda (string) (string->symbol (detach-suffix-number string))) - (lambda () false))) - -;;; Names in the symbol table are of the form "FOOBAR-127". The 127 -;;; is added by the compiler. This procedure detaches the suffix -;;; number from the prefix name. It does nothing if there is no -;;; numeric suffix. - -(define (detach-suffix-number string) - (let loop ((index (-1+ (string-length string)))) - (cond ((zero? index) string) - ((char=? (string-ref string index) #\-) - (string-append - (substring string 0 index) - " " - (substring string (1+ index) (string-length string)))) - ((char-numeric? (string-ref string index)) - (loop (-1+ index))) - (else string)))) - -(define (compiled-entry/filename entry) - (compiled-entry->pathname entry - (lambda (pathname) (list 'FILE (pathname-name pathname))) - (lambda () false))) - + (let ((unparse-name + (lambda () + (*unparse-object + (let ((filename (compiled-entry/filename entry))) + (if filename + (list 'FILE (pathname-name (->pathname filename))) + '())))))) + (if (eq? type 'COMPILED-PROCEDURE) + (let ((name (compiled-procedure/name entry))) + (if name + (*unparse-string name) + (unparse-name))) + (unparse-name))) + (*unparse-char #\Space) + (*unparse-hex (compiled-entry/offset entry)) + (*unparse-char #\Space) + (if closure? + (begin (*unparse-datum (compiled-closure->entry entry)) + (*unparse-char #\Space))) + (*unparse-datum entry))))) + ;;;; Miscellaneous (define (unparse/environment environment) diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm index 31e758e1d..c351b5108 100644 --- a/v7/src/runtime/vector.scm +++ b/v7/src/runtime/vector.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 14.1 1988/06/13 12:00:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 14.2 1988/12/30 06:43:54 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -158,4 +158,24 @@ MIT in each case. |# (define-integrable (vector-fifth vector) (vector-ref vector 4)) (define-integrable (vector-sixth vector) (vector-ref vector 5)) (define-integrable (vector-seventh vector) (vector-ref vector 6)) -(define-integrable (vector-eighth vector) (vector-ref vector 7)) \ No newline at end of file +(define-integrable (vector-eighth vector) (vector-ref vector 7)) + +(define (subvector-find-next-element vector start end item) + (let loop ((index start)) + (and (< index end) + (if (eqv? (vector-ref vector index) item) + index + (loop (1+ index)))))) + +(define (subvector-find-previous-element vector start end item) + (let loop ((index (-1+ end))) + (and (<= start index) + (if (eqv? (vector-ref vector index) item) + index + (loop (-1+ index)))))) + +(define-integrable (vector-find-next-element vector item) + (subvector-find-next-element vector 0 (vector-length vector) item)) + +(define-integrable (vector-find-previous-element vector item) + (subvector-find-previous-element vector 0 (vector-length vector) item)) \ No newline at end of file diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 96cf0fe8f..301bdc6f9 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.30 1988/12/13 13:10:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.31 1988/12/30 06:43:59 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 30)) + (add-identification! "Runtime" 14 31)) (define microcode-system) diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm index 407a1c385..5ae0acb97 100644 --- a/v7/src/runtime/where.scm +++ b/v7/src/runtime/where.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.4 1988/08/05 20:49:51 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.5 1988/12/30 06:44:04 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -61,13 +61,11 @@ MIT in each case. |# "Create a read-eval-print loop in the current environment") (#\N ,name "Name of procedure which created current environment") - )))) + ))) + unspecific) (define command-set) - -(define env) -(define current-frame) -(define current-frame-depth) +(define frame-list) (define (where #!optional environment) (let ((environment @@ -75,73 +73,66 @@ MIT in each case. |# (nearest-repl/environment) (->environment environment)))) (hook/repl-environment (nearest-repl) environment) - (fluid-let ((env environment) - (current-frame environment) - (current-frame-depth 0)) + (fluid-let ((frame-list (list environment))) (letter-commands command-set (cmdl-message/standard "Environment Inspector") "Where-->")))) -;;;; Display Commands - (define (show) - (show-frame current-frame current-frame-depth)) + (show-current-frame false)) -(define (show-all) - (let s1 ((env env) (depth 0)) - (if (not (system-global-environment? env)) - (begin (show-frame env depth) - (if (environment-has-parent? env) - (s1 (environment-parent env) (1+ depth)))))) - unspecific) +(define (show-current-frame brief?) + (show-frame (car frame-list) (length (cdr frame-list)) brief?)) -;;;; Motion Commands +(define (show-all) + (show-frames (car (last-pair frame-list)) 0)) (define (parent) - (cond ((environment-has-parent? current-frame) - (set! current-frame (environment-parent current-frame)) - (set! current-frame-depth (1+ current-frame-depth)) - (show)) - (else - (newline) - (write-string "The current frame has no parent.")))) - + (if (environment-has-parent? (car frame-list)) + (begin + (set! frame-list + (cons (environment-parent (car frame-list)) frame-list)) + (show-current-frame true)) + (begin + (newline) + (write-string "The current frame has no parent.")))) (define (son) - (cond ((eq? current-frame env) - (newline) - (write-string - "This is the original frame. Its children cannot be found.")) - (else - (let son-1 ((prev env) - (prev-depth 0) - (next (environment-parent env))) - (if (eq? next current-frame) - (begin (set! current-frame prev) - (set! current-frame-depth prev-depth)) - (son-1 next - (1+ prev-depth) - (environment-parent next)))) - (show)))) + (let ((frames frame-list)) + (if (null? (cdr frames)) + (begin + (newline) + (write-string + "This is the original frame. Its children cannot be found.")) + (begin + (set! frame-list (cdr frames)) + (show-current-frame true))))) + +(define (name) + (newline) + (write-string "This frame was created by ") + (print-user-friendly-name (car frame-list))) (define (recursive-where) - (let ((inp (prompt-for-expression "Object to eval and examine-> "))) - (write-string "New where!") - (debug/where (debug/eval inp current-frame)))) - -;;;; Relative Evaluation Commands + (if-interpreter-environment (car frame-list) + (lambda (environment) + (let ((inp (prompt-for-expression "Object to eval and examine-> "))) + (write-string "New where!") + (debug/where (debug/eval inp environment)))))) (define (enter) - (debug/read-eval-print current-frame - "You are now in the desired environment" - "Eval-in-env-->")) + (if-interpreter-environment (car frame-list) + (lambda (environment) + (debug/read-eval-print environment + "You are now in the desired environment" + "Eval-in-env-->")))) (define (show-object) - (debug/read-eval-print-1 current-frame)) - -;;;; Miscellaneous Commands - -(define (name) - (newline) - (write-string "This frame was created by ") - (print-user-friendly-name current-frame)) \ No newline at end of file + (if-interpreter-environment (car frame-list) debug/read-eval-print-1)) + +(define (if-interpreter-environment environment receiver) + (if (interpreter-environment? environment) + (receiver environment) + (begin + (newline) + (write-string "This frame is not an interpreter environment")))) \ No newline at end of file diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm index 6c574caa6..dac43ad47 100644 --- a/v8/src/runtime/conpar.scm +++ b/v8/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.4 1988/06/22 21:24:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.5 1988/12/30 06:42:07 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -44,7 +44,8 @@ MIT in each case. |# (type elements dynamic-state fluid-bindings interrupt-mask history previous-history-offset - previous-history-control-point %next)) + previous-history-control-point + offset %next)) (conc-name stack-frame/)) (type false read-only true) (elements false read-only true) @@ -54,6 +55,7 @@ MIT in each case. |# (history false read-only true) (previous-history-offset false read-only true) (previous-history-control-point false read-only true) + (offset false read-only true) ;; %NEXT is either a parser-state object or the next frame. In the ;; former case, the parser-state is used to compute the next frame. %next @@ -92,7 +94,7 @@ MIT in each case. |# (let ((stack-frame (stack-frame/next stack-frame))) (and stack-frame (stack-frame/skip-non-subproblems stack-frame))))) - + (define-integrable (stack-frame/length stack-frame) (vector-length (stack-frame/elements stack-frame))) @@ -102,13 +104,24 @@ MIT in each case. |# (lambda () (vector-ref elements index))))) (define-integrable (stack-frame/return-address stack-frame) - (stack-frame-type/address (stack-frame/type stack-frame))) + (stack-frame/ref stack-frame 0)) -(define-integrable (stack-frame/return-code stack-frame) - (stack-frame-type/code (stack-frame/type stack-frame))) +(define (stack-frame/return-code stack-frame) + (let ((return-address (stack-frame/return-address stack-frame))) + (and (interpreter-return-address? return-address) + (return-address/code return-address)))) (define-integrable (stack-frame/subproblem? stack-frame) (stack-frame-type/subproblem? (stack-frame/type stack-frame))) + +(define (stack-frame/resolve-stack-address frame address) + (let loop + ((frame frame) + (offset (stack-address->index address (stack-frame/offset frame)))) + (let ((length (stack-frame/length frame))) + (if (< offset length) + (values frame offset) + (loop (stack-frame/next frame) (- offset length)))))) ;;;; Parser @@ -121,6 +134,7 @@ MIT in each case. |# (previous-history-offset false read-only true) (previous-history-control-point false read-only true) (element-stream false read-only true) + (n-elements false read-only true) (next-control-point false read-only true)) (define (continuation->stack-frame continuation) @@ -139,52 +153,28 @@ MIT in each case. |# (control-point/previous-history-offset control-point) (control-point/previous-history-control-point control-point) (control-point/element-stream control-point) + (control-point/n-elements control-point) (control-point/next-control-point control-point))))) (define (parse/start state) (let ((stream (parser-state/element-stream state))) (if (stream-pair? stream) - (let ((type (parse/type stream)) - (stream (stream-cdr stream))) - (let ((length (parse/length stream type))) - (with-values (lambda () (parse/elements stream length)) - (lambda (elements stream) - (parse/dispatch type - elements - (parse/next-state state length stream)))))) + (let ((type + (return-address->stack-frame-type + (element-stream/head stream)))) + (let ((length + (let ((length (stack-frame-type/length type))) + (if (integer? length) + length + (length stream (parser-state/n-elements state)))))) + ((stack-frame-type/parser type) + type + (list->vector (stream-head stream length)) + (parse/next-state state length (stream-tail stream length))))) (parse/control-point (parser-state/next-control-point state) (parser-state/dynamic-state state) (parser-state/fluid-bindings state))))) -(define (parse/type stream) - (let ((return-address (element-stream/head stream))) - (if (not (return-address? return-address)) - (error "illegal return address" return-address)) - (let ((code (return-address/code return-address))) - (let ((type (microcode-return/code->type code))) - (if (not type) - (error "return-code has no type" code)) - type)))) - -(define (parse/length stream type) - (let ((length (stack-frame-type/length type))) - (if (integer? length) - length - (length stream)))) - -(define (parse/elements stream length) - (let ((elements (make-vector length))) - (let loop ((stream stream) (index 0)) - (if (< index length) - (begin (if (not (stream-pair? stream)) - (error "stack too short" index)) - (vector-set! elements index (stream-car stream)) - (loop (stream-cdr stream) (1+ index))) - (values elements stream))))) - -(define (parse/dispatch type elements state) - ((stack-frame-type/parser type) type elements state)) - (define (parse/next-state state length stream) (let ((previous-history-control-point (parser-state/previous-history-control-point state))) @@ -195,13 +185,17 @@ MIT in each case. |# (parser-state/history state) (if previous-history-control-point (parser-state/previous-history-offset state) - (max (- (parser-state/previous-history-offset state) length) 0)) + (max (- (parser-state/previous-history-offset state) (-1+ length)) + 0)) previous-history-control-point stream + (- (parser-state/n-elements state) length) (parser-state/next-control-point state)))) - -(define (make-frame type elements state element-stream) - (let ((subproblem? (stack-frame-type/subproblem? type)) + +(define (make-frame type elements state element-stream n-elements) + (let ((history-subproblem? + (and (stack-frame-type/subproblem? type) + (not (eq? type stack-frame-type/compiled-return-address)))) (history (parser-state/history state)) (previous-history-offset (parser-state/previous-history-offset state)) (previous-history-control-point @@ -211,28 +205,29 @@ MIT in each case. |# (parser-state/dynamic-state state) (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) - (if subproblem? history undefined-history) + (if history-subproblem? history undefined-history) previous-history-offset previous-history-control-point + (+ (vector-length elements) n-elements) (make-parser-state (parser-state/dynamic-state state) (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) - (if subproblem? (history-superproblem history) history) + (if history-subproblem? + (history-superproblem history) + history) previous-history-offset previous-history-control-point element-stream + n-elements (parser-state/next-control-point state))))) (define (element-stream/head stream) (if (not (stream-pair? stream)) (error "not a stream-pair" stream)) (map-reference-trap (lambda () (stream-car stream)))) -(define (element-stream/ref stream index) - (if (not (stream-pair? stream)) (error "not a stream-pair" stream)) - (if (zero? index) - (map-reference-trap (lambda () (stream-car stream))) - (element-stream/ref (stream-cdr stream) (-1+ index)))) +(define-integrable (element-stream/ref stream index) + (map-reference-trap (lambda () (stream-ref stream index)))) ;;;; Unparser @@ -260,41 +255,49 @@ MIT in each case. |# (cond ((stack-frame? next) (with-values (lambda () (unparse/stack-frame next)) (lambda (element-stream next-control-point) - (values (let ((type (stack-frame/type stack-frame))) - ((stack-frame-type/unparser type) - type - (stack-frame/elements stack-frame) - element-stream)) - next-control-point)))) + (values + (let ((elements (stack-frame/elements stack-frame))) + (let ((length (vector-length elements))) + (let loop ((index 0)) + (if (< index length) + (cons-stream (vector-ref elements index) + (loop (1+ index))) + element-stream)))) + next-control-point)))) ((parser-state? next) (values (parser-state/element-stream next) (parser-state/next-control-point next))) - (else (values (stream) false))))) + (else + (values (stream) false))))) -;;;; Generic Parsers/Unparsers - -(define (parser/interpreter-next type elements state) - (make-frame type elements state (parser-state/element-stream state))) - -(define (unparser/interpreter-next type elements element-stream) - (cons-stream (make-return-address (stack-frame-type/code type)) - (let ((length (vector-length elements))) - (let loop ((index 0)) - (if (< index length) - (cons-stream (vector-ref elements index) - (loop (1+ index))) - element-stream))))) - -(define (parser/compiler-next type elements state) - (make-frame type elements state - (cons-stream - (ucode-return-address reenter-compiled-code) - (cons-stream - (- (vector-ref elements 0) (vector-length elements)) - (parser-state/element-stream state))))) - -(define (unparser/compiler-next type elements element-stream) - (unparser/interpreter-next type elements (stream-tail element-stream 2))) +;;;; Special Frame Lengths + +(define (length/combination-save-value stream offset) + offset + (+ 3 (system-vector-length (element-stream/ref stream 1)))) + +(define ((length/application-frame index missing) stream offset) + offset + (+ index 1 (- (object-datum (element-stream/ref stream index)) missing))) + +(define (length/repeat-primitive stream offset) + offset + (primitive-procedure-arity (element-stream/ref stream 1))) + +(define (length/compiled-return-address stream offset) + (let ((entry (element-stream/head stream))) + (let ((frame-size (compiled-continuation/next-continuation-offset entry))) + (if frame-size + (1+ frame-size) + (stack-address->index (element-stream/ref stream 1) offset))))) + ;;;; Parsers + +(define (parser/standard-next type elements state) + (make-frame type + elements + state + (parser-state/element-stream state) + (parser-state/n-elements state))) (define (make-restore-frame type elements @@ -305,7 +308,7 @@ MIT in each case. |# history previous-history-offset previous-history-control-point) - (parser/interpreter-next + (parser/standard-next type elements (make-parser-state dynamic-state @@ -315,9 +318,8 @@ MIT in each case. |# previous-history-offset previous-history-control-point (parser-state/element-stream state) + (parser-state/n-elements state) (parser-state/next-control-point state)))) - -;;;; Specific Parsers (define (parser/restore-dynamic-state type elements state) (make-restore-frame type elements state @@ -325,7 +327,7 @@ MIT in each case. |# ;; consists of all of the state spaces in ;; existence. Probably we should have some ;; mechanism for keeping track of them all. - (let ((dynamic-state (vector-ref elements 0))) + (let ((dynamic-state (vector-ref elements 1))) (if (eq? system-state-space (state-point/space dynamic-state)) dynamic-state @@ -339,7 +341,7 @@ MIT in each case. |# (define (parser/restore-fluid-bindings type elements state) (make-restore-frame type elements state (parser-state/dynamic-state state) - (vector-ref elements 0) + (vector-ref elements 1) (parser-state/interrupt-mask state) (parser-state/history state) (parser-state/previous-history-offset state) @@ -349,7 +351,7 @@ MIT in each case. |# (make-restore-frame type elements state (parser-state/dynamic-state state) (parser-state/fluid-bindings state) - (vector-ref elements 0) + (vector-ref elements 1) (parser-state/history state) (parser-state/previous-history-offset state) (parser-state/previous-history-control-point state))) @@ -359,148 +361,144 @@ MIT in each case. |# (parser-state/dynamic-state state) (parser-state/fluid-bindings state) (parser-state/interrupt-mask state) - (history-transform (vector-ref elements 0)) - (vector-ref elements 1) - (vector-ref elements 2))) - -(define (length/combination-save-value stream) - (+ 2 (system-vector-length (element-stream/head stream)))) - -(define ((length/application-frame index missing) stream) - (+ index 1 (- (object-datum (element-stream/ref stream index)) missing))) - -(define (length/repeat-primitive stream) - (-1+ (primitive-procedure-arity (element-stream/head stream)))) - -(define (length/reenter-compiled-code stream) - (1+ (element-stream/head stream))) + (history-transform (vector-ref elements 1)) + (vector-ref elements 2) + (vector-ref elements 3))) ;;;; Stack Frame Types (define-structure (stack-frame-type (constructor make-stack-frame-type - (code subproblem? length parser unparser)) + (code subproblem? length parser)) (conc-name stack-frame-type/)) (code false read-only true) (subproblem? false read-only true) (properties (make-1d-table) read-only true) (length false read-only true) - (parser false read-only true) - (unparser false read-only true)) + (parser false read-only true)) (define (microcode-return/code->type code) (if (not (< code (vector-length stack-frame-types))) (error "return-code too large" code)) (vector-ref stack-frame-types code)) -(define-integrable (stack-frame-type/address frame-type) - (make-return-address (stack-frame-type/code frame-type))) +(define (return-address->stack-frame-type return-address) + (cond ((interpreter-return-address? return-address) + (let ((code (return-address/code return-address))) + (let ((type (microcode-return/code->type code))) + (if (not type) + (error "return-code has no type" code)) + type))) + ((compiled-return-address? return-address) + (if (compiled-continuation/return-to-interpreter? + return-address) + stack-frame-type/return-to-interpreter + stack-frame-type/compiled-return-address)) + (else + (error "illegal return address" return-address)))) (define (initialize-package!) - (set! stack-frame-types (make-stack-frame-types))) + (set! stack-frame-types (make-stack-frame-types)) + (set! stack-frame-type/compiled-return-address + (make-stack-frame-type false + true + length/compiled-return-address + parser/standard-next)) + (set! stack-frame-type/return-to-interpreter + (make-stack-frame-type false + false + 1 + parser/standard-next)) + unspecific) (define stack-frame-types) +(define stack-frame-type/compiled-return-address) +(define stack-frame-type/return-to-interpreter) (define (make-stack-frame-types) (let ((types (make-vector (microcode-return/code-limit) false))) - (define (stack-frame-type name subproblem? length parser unparser) + (define (stack-frame-type name subproblem? length parser) (let ((code (microcode-return name))) (vector-set! types code - (make-stack-frame-type code subproblem? length parser - unparser)))) - - (define (interpreter-frame name length #!optional parser) - (stack-frame-type name false length - (if (default-object? parser) - parser/interpreter-next - parser) - unparser/interpreter-next)) + (make-stack-frame-type code subproblem? length parser)))) - (define (compiler-frame name length #!optional parser) - (stack-frame-type name false length + (define (standard-frame name length #!optional parser) + (stack-frame-type name + false + length (if (default-object? parser) - parser/compiler-next - parser) - unparser/compiler-next)) - - (define (interpreter-subproblem name length) - (stack-frame-type name true length parser/interpreter-next - unparser/interpreter-next)) - - (define (compiler-subproblem name length) - (stack-frame-type name true length parser/compiler-next - unparser/compiler-next)) + parser/standard-next + parser))) + + (define (standard-subproblem name length) + (stack-frame-type name + true + length + parser/standard-next)) - (interpreter-frame 'RESTORE-TO-STATE-POINT 1 parser/restore-dynamic-state) - (interpreter-frame 'RESTORE-FLUIDS 1 parser/restore-fluid-bindings) - (interpreter-frame 'RESTORE-INTERRUPT-MASK 1 parser/restore-interrupt-mask) - (interpreter-frame 'RESTORE-HISTORY 3 parser/restore-history) - (interpreter-frame 'RESTORE-DONT-COPY-HISTORY 3 parser/restore-history) - - (interpreter-frame 'NON-EXISTENT-CONTINUATION 1) - (interpreter-frame 'HALT 1) - (interpreter-frame 'JOIN-STACKLETS 1) - (interpreter-frame 'POP-RETURN-ERROR 1) - - (interpreter-subproblem 'IN-PACKAGE-CONTINUE 1) - (interpreter-subproblem 'ACCESS-CONTINUE 1) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 1) - (interpreter-subproblem 'FORCE-SNAP-THUNK 1) - (interpreter-subproblem 'GC-CHECK 1) - (interpreter-subproblem 'RESTORE-VALUE 1) - (interpreter-subproblem 'ASSIGNMENT-CONTINUE 2) - (interpreter-subproblem 'DEFINITION-CONTINUE 2) - (interpreter-subproblem 'SEQUENCE-2-SECOND 2) - (interpreter-subproblem 'SEQUENCE-3-SECOND 2) - (interpreter-subproblem 'SEQUENCE-3-THIRD 2) - (interpreter-subproblem 'CONDITIONAL-DECIDE 2) - (interpreter-subproblem 'DISJUNCTION-DECIDE 2) - (interpreter-subproblem 'COMBINATION-1-PROCEDURE 2) - (interpreter-subproblem 'COMBINATION-2-FIRST-OPERAND 2) - (interpreter-subproblem 'EVAL-ERROR 2) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 2) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 2) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 2) - (interpreter-subproblem 'COMBINATION-2-PROCEDURE 3) - (interpreter-subproblem 'REPEAT-DISPATCH 3) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 3) - (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 3) - (interpreter-subproblem 'MOVE-TO-ADJACENT-POINT 5) - - (interpreter-subproblem 'COMBINATION-SAVE-VALUE - length/combination-save-value) - - (interpreter-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive) - - (let ((length (length/application-frame 1 0))) - (interpreter-subproblem 'COMBINATION-APPLY length) - (interpreter-subproblem 'INTERNAL-APPLY length)) - - (interpreter-subproblem 'REENTER-COMPILED-CODE - length/reenter-compiled-code) - - (compiler-frame 'COMPILER-INTERRUPT-RESTART 2) - (compiler-frame 'COMPILER-LINK-CACHES-RESTART 7) - - (compiler-subproblem 'COMPILER-REFERENCE-RESTART 3) - (compiler-subproblem 'COMPILER-SAFE-REFERENCE-RESTART 3) - (compiler-subproblem 'COMPILER-ACCESS-RESTART 3) - (compiler-subproblem 'COMPILER-UNASSIGNED?-RESTART 3) - (compiler-subproblem 'COMPILER-UNBOUND?-RESTART 3) - (compiler-subproblem 'COMPILER-REFERENCE-TRAP-RESTART 3) - (compiler-subproblem 'COMPILER-SAFE-REFERENCE-TRAP-RESTART 3) - (compiler-subproblem 'COMPILER-UNASSIGNED?-TRAP-RESTART 3) - (compiler-subproblem 'COMPILER-ASSIGNMENT-RESTART 4) - (compiler-subproblem 'COMPILER-DEFINITION-RESTART 4) - (compiler-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 4) - - (compiler-subproblem 'COMPILER-LOOKUP-APPLY-RESTART - (length/application-frame 3 1)) - - (let ((length (length/application-frame 3 0))) - (compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length) - (compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length)) - + (standard-frame 'RESTORE-TO-STATE-POINT 2 parser/restore-dynamic-state) + (standard-frame 'RESTORE-FLUIDS 2 parser/restore-fluid-bindings) + (standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask) + (standard-frame 'RESTORE-HISTORY 4 parser/restore-history) + (standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history) + + (standard-frame 'NON-EXISTENT-CONTINUATION 2) + (standard-frame 'HALT 2) + (standard-frame 'JOIN-STACKLETS 2) + (standard-frame 'POP-RETURN-ERROR 2) + (standard-frame 'REENTER-COMPILED-CODE 2) + (standard-frame 'COMPILER-INTERRUPT-RESTART 3) + (standard-frame 'COMPILER-LINK-CACHES-RESTART 8) + + (standard-subproblem 'IN-PACKAGE-CONTINUE 2) + (standard-subproblem 'ACCESS-CONTINUE 2) + (standard-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 2) + (standard-subproblem 'FORCE-SNAP-THUNK 2) + (standard-subproblem 'GC-CHECK 2) + (standard-subproblem 'RESTORE-VALUE 2) + (standard-subproblem 'ASSIGNMENT-CONTINUE 3) + (standard-subproblem 'DEFINITION-CONTINUE 3) + (standard-subproblem 'SEQUENCE-2-SECOND 3) + (standard-subproblem 'SEQUENCE-3-SECOND 3) + (standard-subproblem 'SEQUENCE-3-THIRD 3) + (standard-subproblem 'CONDITIONAL-DECIDE 3) + (standard-subproblem 'DISJUNCTION-DECIDE 3) + (standard-subproblem 'COMBINATION-1-PROCEDURE 3) + (standard-subproblem 'COMBINATION-2-FIRST-OPERAND 3) + (standard-subproblem 'EVAL-ERROR 3) + (standard-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 3) + (standard-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 3) + (standard-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 3) + (standard-subproblem 'COMBINATION-2-PROCEDURE 4) + (standard-subproblem 'REPEAT-DISPATCH 4) + (standard-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 4) + (standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4) + (standard-subproblem 'COMPILER-REFERENCE-RESTART 4) + (standard-subproblem 'COMPILER-SAFE-REFERENCE-RESTART 4) + (standard-subproblem 'COMPILER-ACCESS-RESTART 4) + (standard-subproblem 'COMPILER-UNASSIGNED?-RESTART 4) + (standard-subproblem 'COMPILER-UNBOUND?-RESTART 4) + (standard-subproblem 'COMPILER-REFERENCE-TRAP-RESTART 4) + (standard-subproblem 'COMPILER-SAFE-REFERENCE-TRAP-RESTART 4) + (standard-subproblem 'COMPILER-UNASSIGNED?-TRAP-RESTART 4) + (standard-subproblem 'COMPILER-ASSIGNMENT-RESTART 5) + (standard-subproblem 'COMPILER-DEFINITION-RESTART 5) + (standard-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 5) + (standard-subproblem 'MOVE-TO-ADJACENT-POINT 6) + + (standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value) + (standard-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive) + + (let ((length (length/application-frame 2 0))) + (standard-subproblem 'COMBINATION-APPLY length) + (standard-subproblem 'INTERNAL-APPLY length)) + + (standard-subproblem 'COMPILER-LOOKUP-APPLY-RESTART + (length/application-frame 4 1)) + + (let ((length (length/application-frame 4 0))) + (standard-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length) + (standard-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length)) types)) \ No newline at end of file diff --git a/v8/src/runtime/dbgutl.scm b/v8/src/runtime/dbgutl.scm index 6c1b8fe0e..43cbfad78 100644 --- a/v8/src/runtime/dbgutl.scm +++ b/v8/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.3 1988/08/01 23:09:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.4 1988/12/30 06:42:27 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -46,71 +46,107 @@ MIT in each case. |# (,lambda-tag:fluid-let . FLUID-LET) (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))) -(define (print-user-friendly-name frame) - (let ((name (environment-name frame))) - (let ((rename (assq name rename-list))) - (if rename - (begin (write-string "a ") - (write (cdr rename)) - (write-string " special form")) - (begin (write-string "the procedure ") - (write name)))))) - -(define (environment-name environment) - (lambda-components* (procedure-lambda (environment-procedure environment)) - (lambda (name required optional rest body) - required optional rest body - name))) - -(define (special-name? symbol) - (assq symbol rename-list)) +(define (print-user-friendly-name environment) + (let ((name (environment-procedure-name environment))) + (if name + (let ((rename (special-name? name))) + (if rename + (begin (write-string "a ") + (write (cdr rename)) + (write-string " special form")) + (begin (write-string "the procedure ") + (write-dbg-name name)))) + (write-string "an unknown procedure")))) + +(define (special-name? name) + (list-search-positive rename-list + (lambda (association) + (dbg-name=? (car association) name)))) (define rename-list) -(define (show-frame frame depth) - (if (system-global-environment? frame) - (begin - (newline) - (write-string "This frame is the system global environment")) - (begin - (newline) - (write-string "Frame created by ") - (print-user-friendly-name frame) - (if (>= depth 0) - (begin (newline) - (write-string "Depth (relative to starting frame): ") - (write depth))) - (newline) - (let ((bindings (environment-bindings frame))) - (if (null? bindings) - (write-string "Has no bindings") - (begin - (write-string "Has bindings:") - (newline) - (for-each print-binding - (sort bindings - (lambda (x y) - (stringstring (car x)) - (symbol->string (car y)))))))))))) - -(define (print-binding binding) - (let ((x-size (output-port/x-size (current-output-port))) - (write->string - (lambda (object length) - (let ((x (write-to-string object length))) - (if (and (car x) (> length 4)) - (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) - (cdr x))))) +(define (show-frame environment depth brief?) + (write-string "Environment ") + (let ((show-bindings? + (let ((package (environment->package environment))) + (if package + (begin + (write-string "named ") + (write (package/name package)) + (not brief?)) + (begin + (write-string "created by ") + (print-user-friendly-name environment) + true))))) + (if (not (negative? depth)) + (begin (newline) + (write-string "Depth (relative to starting frame): ") + (write depth))) + (if show-bindings? + (begin + (newline) + (show-environment-bindings environment brief?)))) + (newline)) + +(define (show-environment-bindings environment brief?) + (let ((names (environment-bound-names environment))) + (let ((n-bindings (length names)) + (finish + (lambda (names) + (newline) + (for-each (lambda (name) + (print-binding name + (environment-lookup environment name))) + names)))) + (cond ((zero? n-bindings) + (write-string "Has no bindings")) + ((and brief? (> n-bindings brief-bindings-limit)) + (write-string "Has ") + (write n-bindings) + (write-string " bindings (first ") + (write brief-bindings-limit) + (write-string " shown):") + (finish (list-head names brief-bindings-limit))) + (else + (write-string "Has bindings:") + (finish names)))))) + +(define brief-bindings-limit + 16) + +(define (show-frames environment depth) + (let loop ((environment environment) (depth depth)) + (show-frame environment depth true) + (if (environment-has-parent? environment) + (begin + (newline) + (loop (environment-parent environment) (1+ depth)))))) + +(define (print-binding name value) + (let ((x-size (output-port/x-size (current-output-port)))) (newline) (write-string - (let ((s (write->string (car binding) (quotient x-size 2)))) - (if (null? (cdr binding)) - (string-append s " is unassigned") - (let ((s (string-append s " = "))) - (string-append s - (write->string (cadr binding) - (max (- x-size (string-length s)) - 0))))))))) + (let ((name + (output-to-string (quotient x-size 2) + (lambda () + (write-dbg-name name))))) + (if (unassigned-reference-trap? value) + (string-append name " is unassigned") + (let ((s (string-append name " = "))) + (string-append + s + (output-to-string (max (- x-size (string-length s)) 0) + (lambda () + (write value)))))))))) + +(define (output-to-string length thunk) + (let ((x (with-output-to-truncated-string length thunk))) + (if (and (car x) (> length 4)) + (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) + (cdr x))) + +(define (write-dbg-name name) + (if (string? name) (write-string name) (write name))) (define (debug/read-eval-print-1 environment) (let ((value (debug/eval (prompt-for-expression "Eval--> ") environment))) diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm index 19e35e9b7..2a15be58a 100644 --- a/v8/src/runtime/framex.scm +++ b/v8/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.2 1988/06/13 11:44:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.3 1988/12/30 06:42:40 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -55,8 +55,10 @@ MIT in each case. |# (define-integrable (debugging-info/compiled-code? expression) (eq? expression compiled-code)) -(define-integrable (make-evaluated-object object) - (cons evaluated-object-tag object)) +(define (make-evaluated-object object) + (if (scode-constant? object) + object + (cons evaluated-object-tag object))) (define (debugging-info/evaluated-object? expression) (and (pair? expression) @@ -72,29 +74,28 @@ MIT in each case. |# (define evaluated-object-tag "evaluated") (define (method/standard frame) - (values (stack-frame/ref frame 0) (stack-frame/ref frame 1))) + (values (stack-frame/ref frame 1) (stack-frame/ref frame 2))) (define (method/null frame) frame (values undefined-expression undefined-environment)) (define (method/expression-only frame) - (values (stack-frame/ref frame 0) undefined-environment)) + (values (stack-frame/ref frame 1) undefined-environment)) (define (method/environment-only frame) - (values undefined-expression (stack-frame/ref frame 1))) + (values undefined-expression (stack-frame/ref frame 2))) (define (method/compiled-code frame) - frame - (values compiled-code undefined-environment)) + (values compiled-code (stack-frame/environment frame undefined-environment))) (define (method/primitive-combination-3-first-operand frame) - (values (stack-frame/ref frame 0) (stack-frame/ref frame 2))) + (values (stack-frame/ref frame 1) (stack-frame/ref frame 3))) (define (method/force-snap-thunk frame) (values (make-combination (ucode-primitive force 1) - (list (make-evaluated-object (stack-frame/ref frame 0)))) + (list (make-evaluated-object (stack-frame/ref frame 1)))) undefined-environment)) (define ((method/application-frame index) frame) @@ -104,32 +105,32 @@ MIT in each case. |# undefined-environment)) (define ((method/compiler-reference scode-maker) frame) - (values (scode-maker (stack-frame/ref frame 2)) - (stack-frame/ref frame 1))) + (values (scode-maker (stack-frame/ref frame 3)) + (stack-frame/ref frame 2))) (define ((method/compiler-assignment scode-maker) frame) - (values (scode-maker (stack-frame/ref frame 2) - (make-evaluated-object (stack-frame/ref frame 3))) - (stack-frame/ref frame 1))) + (values (scode-maker (stack-frame/ref frame 3) + (make-evaluated-object (stack-frame/ref frame 4))) + (stack-frame/ref frame 2))) (define ((method/compiler-reference-trap scode-maker) frame) - (values (scode-maker (stack-frame/ref frame 1)) - (stack-frame/ref frame 2))) + (values (scode-maker (stack-frame/ref frame 2)) + (stack-frame/ref frame 3))) (define ((method/compiler-assignment-trap scode-maker) frame) - (values (scode-maker (stack-frame/ref frame 1) - (make-evaluated-object (stack-frame/ref frame 3))) - (stack-frame/ref frame 2))) + (values (scode-maker (stack-frame/ref frame 2) + (make-evaluated-object (stack-frame/ref frame 4))) + (stack-frame/ref frame 3))) (define (method/compiler-lookup-apply-restart frame) - (values (make-combination (stack-frame/ref frame 2) - (stack-frame-list frame 4)) + (values (make-combination (stack-frame/ref frame 3) + (stack-frame-list frame 5)) undefined-environment)) (define (method/compiler-lookup-apply-trap-restart frame) - (values (make-combination (make-variable (stack-frame/ref frame 1)) - (stack-frame-list frame 5)) - (stack-frame/ref frame 2))) + (values (make-combination (make-variable (stack-frame/ref frame 2)) + (stack-frame-list frame 6)) + (stack-frame/ref frame 3))) (define (stack-frame-list frame start) (let ((end (stack-frame/length frame))) @@ -169,7 +170,8 @@ MIT in each case. |# (,method/null COMBINATION-APPLY GC-CHECK - MOVE-TO-ADJACENT-POINT) + MOVE-TO-ADJACENT-POINT + REENTER-COMPILED-CODE) (,method/expression-only ACCESS-CONTINUE @@ -181,19 +183,16 @@ MIT in each case. |# (,method/environment-only REPEAT-DISPATCH) - (,method/compiled-code - REENTER-COMPILED-CODE) - (,method/primitive-combination-3-first-operand PRIMITIVE-COMBINATION-3-FIRST-OPERAND) (,method/force-snap-thunk FORCE-SNAP-THUNK) - (,(method/application-frame 2) + (,(method/application-frame 3) INTERNAL-APPLY) - (,(method/application-frame 0) + (,(method/application-frame 1) REPEAT-PRIMITIVE) (,(method/compiler-reference identity-procedure) @@ -233,4 +232,8 @@ MIT in each case. |# (,method/compiler-lookup-apply-trap-restart COMPILER-LOOKUP-APPLY-TRAP-RESTART - COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)))) \ No newline at end of file + COMPILER-OPERATOR-LOOKUP-TRAP-RESTART))) + (1d-table/put! + (stack-frame-type/properties stack-frame-type/compiled-return-address) + method-tag + method/compiled-code)) \ No newline at end of file diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index da5deddfa..75ca621ef 100644 --- a/v8/src/runtime/infutl.scm +++ b/v8/src/runtime/infutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.3 1988/08/05 20:47:32 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.4 1988/12/30 06:42:46 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -32,384 +32,249 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Compiled Code Information +;;;; Compiled Code Information: Utilities ;;; package: (runtime compiler-info) (declare (usual-integrations)) +(declare (integrate-external "infstr")) +(define (compiled-code-block/dbg-info block) + (let ((old-info (compiled-code-block/debugging-info block))) + (if (and (pair? old-info) (dbg-info? (car old-info))) + (car old-info) + (let ((dbg-info (read-debugging-info old-info))) + (if dbg-info + (memoize-debugging-info! block dbg-info)) + dbg-info)))) + +(define (discard-debugging-info!) + (without-interrupts + (lambda () + (map-over-population! blocks-with-memoized-debugging-info + discard-block-debugging-info!) + (set! blocks-with-memoized-debugging-info (make-population)) + unspecific))) + +(define (read-debugging-info descriptor) + (cond ((string? descriptor) + (let ((binf (read-binf-file descriptor))) + (and binf (dbg-info? binf) binf))) ((and (pair? descriptor) + (string? (car descriptor)) + (integer? (cdr descriptor))) + (let ((binf (read-binf-file (car descriptor)))) + (and binf + (dbg-info-vector? binf) + (vector-ref (dbg-info-vector/items binf) (cdr descriptor))))) + (else + false))) + +(define (read-binf-file filename) + (and (file-exists? filename) + (fasload filename true))) +(define (memoize-debugging-info! block dbg-info) + (without-interrupts + (lambda () + (let ((old-info (compiled-code-block/debugging-info block))) + (if (not (and (pair? old-info) (dbg-info? (car old-info)))) + (begin + (set-compiled-code-block/debugging-info! block + (cons dbg-info old-info)) + (add-to-population! blocks-with-memoized-debugging-info + block))))))) + +(define (un-memoize-debugging-info! block) + (without-interrupts + (lambda () + (discard-block-debugging-info! block) + (remove-from-population! blocks-with-memoized-debugging-info block)))) + +(define (discard-block-debugging-info! block) + (let ((old-info (compiled-code-block/debugging-info block))) + (if (and (pair? old-info) (dbg-info? (car old-info))) + (set-compiled-code-block/debugging-info! block (cdr old-info))))) + +(define blocks-with-memoized-debugging-info) + (define (initialize-package!) - (make-value-cache uncached-block->compiler-info - (lambda (compute-value flush-cache) - (set! compiled-code-block->compiler-info compute-value) - (set! flush-compiler-info! flush-cache)))) - -(define-integrable compiler-info-tag - (string->symbol "#[COMPILER-INFO]")) - -(define-integrable compiler-entries-tag - (string->symbol "#[COMPILER-ENTRIES]")) - -(define-structure (compiler-info (named compiler-info-tag)) - (procedures false read-only true) - (continuations false read-only true) - (labels false read-only true)) - -(define-structure (label-info (type vector)) - (name false read-only true) - (offset false read-only true) - (external? false read-only true)) - -;;; Yes, you could be clever and do a number of integrations in this file -;;; however, I don't think speed will be the problem. - -;;; Currently, the info slot is in one of several formats: -;;; -;;; NULL -- There is no info. -;;; -;;; COMPILER-INFO -- Just the structure you see above. -;;; -;;; STRING -- The pathstring of the binf file. -;;; -;;; PAIR -- The CAR is the pathstring -;;; The CDR is either COMPILER-INFO or a NUMBER -;;; indicating the offset into the binf file that -;;; you should use to find the info. - -(define (block->info-slot-contents block if-found if-not-found) - ;; Fetches the contents of the compiler-info slot in a block. - ;; Calls if-not-found if there is no slot (block is manifest-closure). - (if (compiled-code-block/manifest-closure? block) - (if-not-found) - (if-found (compiled-code-block/debugging-info block)))) - -(define (parse-info-slot-contents slot-contents - if-no-info - if-pathstring - if-info - if-pathstring-and-info - if-pathstring-and-offset) - (cond ((null? slot-contents) (if-no-info)) - ((compiler-info? slot-contents) (if-info slot-contents)) - ((string? slot-contents) (if-pathstring slot-contents)) - ((pair? slot-contents) - (if (string? (car slot-contents)) - (cond ((compiler-info? (cdr slot-contents)) - (if-pathstring-and-info (car slot-contents) - (cdr slot-contents))) - ((number? (cdr slot-contents)) - (if-pathstring-and-offset (car slot-contents) - (cdr slot-contents))) - (else (if-no-info))) - (if-no-info))) - (else (if-no-info)))) - -(define (info-slot-contents->pathstring slot-contents if-found if-not-found) - ;; Attempts to get the string denoting the file that the compiler-info - ;; is loaded from. - (parse-info-slot-contents slot-contents - if-not-found - if-found - (lambda (info) info (if-not-found)) - (lambda (pathstring info) - info - (if-found pathstring)) - (lambda (pathstring offset) - offset - (if-found pathstring)))) - -(define (info-slot-contents->compiler-info slot-contents if-found if-not-found) - ;; Attempts to get the compiler info denoted by the contents of the - ;; info slot. - (parse-info-slot-contents slot-contents - if-not-found - (lambda (pathstring) - (on-demand-load pathstring #f if-found if-not-found)) - (lambda (info) - (if-found info)) - (lambda (pathstring info) - pathstring - (if-found info)) - (lambda (pathstring offset) - (on-demand-load pathstring offset if-found if-not-found)))) - -(define *compiler-info/load-on-demand?* #f) - -(define (compiler-info/with-on-demand-loading thunk) - (fluid-let ((*compiler-info/load-on-demand?* #t)) - (thunk))) - -(define (compiler-info/without-on-demand-loading thunk) - (fluid-let ((*compiler-info/load-on-demand?* #f)) - (thunk))) - -;;; The binf file is either a compiler-info structure, or -;;; a vector with a compiler-info structure in it. - -;;; If the binf file is a vector, the offset, obtained from the info slot -;;; in the block, will be the index of the vector slot containing the info. -;;; If there was no offset, the zeroth slot has the info in it. - -(define (on-demand-load pathstring offset if-found if-not-found) - (cond ((not *compiler-info/load-on-demand?*) (if-not-found)) - ((not (file-exists? pathstring)) (if-not-found)) - (else (let ((object (fasload pathstring))) - (if (null? offset) - (if (compiler-info? object) - (if-found object) - (if (and (vector? object) - (> (vector-length object) 0) - (compiler-info? (vector-ref object 0))) - (if-found (vector-ref object 0)) - (if-not-found))) - (if (and (vector? object) - (< offset (vector-length object))) - (let ((possible-info (vector-ref object offset))) - (if (compiler-info? possible-info) - (if-found possible-info) - (if-not-found))) - (if-not-found))))))) - -;; Uncached version will reload the binf file each time. - -(define (block->info block info-hacker if-found if-not-found) - (block->info-slot-contents block - (lambda (contents) - (info-hacker contents if-found if-not-found)) - if-not-found)) - -(define (uncached-block->compiler-info block if-found if-not-found) - (block->info block info-slot-contents->compiler-info if-found if-not-found)) - -(define (compiled-code-block->pathstring block if-found if-not-found) - (block->info block info-slot-contents->pathstring if-found if-not-found)) - -(define flush-compiler-info!) -(define compiled-code-block->compiler-info) - -(define (make-value-cache function receiver) - (let ((cache (make-1d-table))) - - (define (flush-cache!) - (set! cache (make-1d-table)) - 'flushed) - - (define (compute-value argument if-found if-not-found) - (1d-table/lookup cache argument - if-found - (lambda () - (function argument - (lambda (value) - (1d-table/put! cache argument value) - (if-found value)) - if-not-found)))) - - (receiver compute-value flush-cache!))) - -(define (entry->info entry block-info-hacker if-found if-not-found) - (compiled-entry->block-and-offset-indirect entry - (lambda (block offset) - offset - (block-info-hacker block if-found if-not-found)) - if-not-found)) - -(define (compiled-entry->pathstring entry if-found if-not-found) - (entry->info entry compiled-code-block->pathstring if-found if-not-found)) - -(define (compiled-entry->pathname entry if-found if-not-found) - (compiled-entry->pathstring entry - (lambda (pathstring) - (if-found (string->pathname pathstring))) - if-not-found)) - -(define (info-file object) - (and (compiled-code-address? object) - (pathname-name (compiled-entry->pathname object - identity-procedure - false-procedure)))) - -(define (compiled-entry->compiler-info entry if-found if-not-found) - (entry->info entry compiled-code-block->compiler-info if-found if-not-found)) - -;;; This switch gets turned on when the implementation for -;;; INDIRECT-THROUGH-MANIFEST-CLOSURE is present. -;;; The mechanism for indirecting through a manifest closure -;;; is highly machine dependent. - -(define *indirect-through-manifest-closure? #f) -(define indirect-through-manifest-closure) - -(define (compiled-entry->block-and-offset entry - if-block - if-manifest-closure - if-failed) - (let ((block (compiled-code-address->block entry)) - (offset (compiled-code-address->offset entry))) - (if (compiled-code-block/manifest-closure? block) - (if *indirect-through-manifest-closure? - (indirect-through-manifest-closure entry - (lambda (indirect-block indirect-offset) - (if-manifest-closure - block offset indirect-block indirect-offset)) - (lambda () (if-failed))) - (if-failed)) - (if-block block offset)))) - -(define (compiled-entry->block-and-offset-indirect - entry if-found if-not-found) - (compiled-entry->block-and-offset entry - if-found - (lambda (closure-block closure-offset block offset) - closure-block closure-offset - (if-found block offset)) - if-not-found)) - -(define (block-symbol-table block if-found if-not-found) - (compiled-code-block->compiler-info block - (lambda (info) - (if-found (compiler-info/symbol-table info))) - if-not-found)) - -(define (compiled-entry->name compiled-entry if-found if-not-found) - (define (block-and-offset->name block offset) - (block-symbol-table block - (lambda (symbol-table) - (sorted-vector/lookup symbol-table offset - (lambda (label-info) - (if-found (label-info-name label-info))) - if-not-found)) - if-not-found)) - - (compiled-entry->block-and-offset compiled-entry - block-and-offset->name - (lambda (manifest-block manifest-offset block offset) - manifest-block manifest-offset - (block-and-offset->name block offset)) - if-not-found)) - -(define (compiler-info/symbol-table compiler-info) - (make-sorted-vector (compiler-info-labels compiler-info) - (lambda (offset label-info) - (= offset (label-info-offset label-info))) - (lambda (offset label-info) - (< offset (label-info-offset label-info))))) - -(define (lookup-label labels label-name if-found if-not-found) - (let ((limit (vector-length labels))) - (let loop ((index 0)) - (if (= index limit) - (if-not-found) - (let ((this-label (vector-ref labels index))) - (if (string-ci=? label-name (label-info-name this-label)) - (if-found index this-label) - (loop (1+ index)))))))) - -(define (label->offset labels name if-found if-not-found) - (lookup-label labels name - (lambda (vector-index label-info) - vector-index - (if-found (label-info-offset label-info))) - if-not-found)) + (set! blocks-with-memoized-debugging-info (make-population)) + unspecific) -;;;; Binary Search - -(define-structure (sorted-vector - (conc-name sorted-vector/) - (constructor %make-sorted-vector)) - (vector false read-only true) - (key=? false read-only true) - (key-compare false read-only true)) - -(define (make-sorted-vector vector key=? key) - ((cond ((key=? key entry) if=) - ((key)))))) - -(define (sorted-vector/find-element sorted-vector key) - (let ((vector (sorted-vector/vector sorted-vector))) - (vector-binary-search vector - key - (sorted-vector/key-compare sorted-vector) - (lambda (index) (vector-ref vector index)) - (lambda () false)))) - -(define (sorted-vector/lookup sorted-vector key if-found if-not-found) - (let ((vector (sorted-vector/vector sorted-vector))) - (vector-binary-search vector - key - (sorted-vector/key-compare sorted-vector) - (lambda (index) (if-found (vector-ref vector index))) - (lambda () (if-not-found))))) - -(define (sorted-vector/find-indices sorted-vector key if-found if-not-found) - (vector-binary-search-range (sorted-vector/vector sorted-vector) - key - (sorted-vector/key=? sorted-vector) - (sorted-vector/key-compare sorted-vector) - if-found - if-not-found)) - -(define (sorted-vector/there-exists? sorted-vector key predicate) - (sorted-vector/find-indices sorted-vector key - (lambda (low high) - (let ((vector (sorted-vector/vector sorted-vector))) - (let loop ((index low)) - (if (predicate (vector-ref vector index)) - true - (and (< index high) - (loop (1+ index))))))) - (lambda () false))) - -(define (sorted-vector/for-each sorted-vector key procedure) - (sorted-vector/find-indices sorted-vector key - (lambda (low high) - (let ((vector (sorted-vector/vector sorted-vector))) - (let loop ((index low)) - (procedure (vector-ref vector index)) - (if (< index high) - (loop (1+ index)))))) - (lambda () unspecific))) +(define (compiled-entry/dbg-object entry) + (let ((block (compiled-entry/block entry)) + (offset (compiled-entry/offset entry))) + (let ((dbg-info (compiled-code-block/dbg-info block))) + (discriminate-compiled-entry entry + (lambda () + (vector-binary-search (dbg-info/procedures dbg-info) + < + dbg-procedure/label-offset + offset)) + (lambda () + (vector-binary-search (dbg-info/continuations dbg-info) + < + dbg-continuation/label-offset + offset)) + (lambda () + (let ((expression (dbg-info/expression dbg-info))) + (and (= offset (dbg-expression/label-offset expression)) + expression))) + (lambda () + false))))) + +(define (compiled-entry/block entry) + (if (compiled-closure? entry) + (compiled-entry/block (compiled-closure->entry entry)) + (compiled-code-address->block entry))) + +(define (compiled-entry/offset entry) + (if (compiled-closure? entry) + (compiled-entry/offset (compiled-closure->entry entry)) + (compiled-code-address->offset entry))) + +(define (compiled-entry/filename entry) + (let loop + ((info + (compiled-code-block/debugging-info (compiled-entry/block entry)))) + (cond ((string? info) + info) + ((pair? info) + (cond ((string? (car info)) (car info)) + ((dbg-info? (car info)) (loop (cdr info))) + (else false))) + (else + false)))) + +(define (compiled-procedure/name entry) + (and *compiler-info/load-on-demand?* + (let ((procedure (compiled-entry/dbg-object entry))) + (and procedure + (dbg-procedure/name procedure))))) + +(define *compiler-info/load-on-demand?* + false) + +(define (dbg-labels/find-offset labels offset) + (vector-binary-search labels < dbg-label/offset offset)) + +(define (vector-binary-search vector < unwrap-key key) + (let loop ((start 0) (end (vector-length vector))) + (and (< start end) + (let ((midpoint (quotient (+ start end) 2))) + (let ((item (vector-ref vector midpoint))) + (let ((key* (unwrap-key item))) + (cond ((< key key*) (loop start midpoint)) + ((< key* key) (loop (1+ midpoint) end)) + (else item)))))))) +(define (fasload/update-debugging-info! value com-pathname) + (let ((process-filename + (lambda (binf-filename) + (let ((binf-pathname (string->pathname binf-filename))) + (if (and (equal? (pathname-name binf-pathname) + (pathname-name com-pathname)) + (not (equal? (pathname-type binf-pathname) + (pathname-type com-pathname))) + (equal? (pathname-version binf-pathname) + (pathname-version com-pathname))) + (pathname->string + (pathname-new-type com-pathname + (pathname-type binf-pathname))) + binf-filename))))) + (let ((process-entry + (lambda (entry) + (let ((block (compiled-code-address->block entry))) + (let ((info (compiled-code-block/debugging-info block))) + (cond ((string? info) + (set-compiled-code-block/debugging-info! + block + (process-filename info))) + ((and (pair? info) (string? (car info))) + (set-car! info (process-filename (car info)))))))))) + (cond ((compiled-code-address? value) + (process-entry value)) + ((comment? value) + (let ((text (comment-text value))) + (if (dbg-info-vector? text) + (for-each + process-entry + (vector->list (dbg-info-vector/items text)))))))))) + +(define (dbg-block/dynamic-link-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/dynamic-link)) + +(define (dbg-block/ic-parent-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/ic-parent)) + +(define (dbg-block/normal-closure-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/normal-closure)) + +(define (dbg-block/return-address-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/return-address)) + +(define (dbg-block/static-link-index block) + (vector-find-next-element (dbg-block/layout block) + dbg-block-name/static-link)) + +(define (dbg-block/find-name block name) + (let ((layout (dbg-block/layout block))) + (let ((end (vector-length layout))) + (let loop ((index 0)) + (and (< index end) + (if (dbg-name=? name (vector-ref layout index)) + index + (loop (1+ index)))))))) -(define (vector-binary-search-range vector key key=? compare if-found - if-not-found) - (vector-binary-search vector key compare - (lambda (index) - (if-found (let loop ((index index)) - (if (zero? index) - index - (let ((index* (-1+ index))) - (if (key=? key (vector-ref vector index*)) - (loop index*) - index)))) - (let ((end (-1+ (vector-length vector)))) - (let loop ((index index)) - (if (= index end) - index - (let ((index* (1+ index))) - (if (key=? key (vector-ref vector index*)) - (loop index*) - index))))))) - if-not-found)) - -(define (vector-binary-search vector key compare if-found if-not-found) - (let loop ((low 0) (high (-1+ (vector-length vector)))) - (if (< high low) - (if-not-found) - (let ((index (quotient (+ high low) 2))) - (compare key - (vector-ref vector index) - (lambda () (if-found index)) - (lambda () (loop low (-1+ index))) - (lambda () (loop (1+ index) high))))))) - -(define (vector-linear-search vector key compare if-found if-not-found) - (let ((limit (length vector))) - (let loop ((index 0)) - (if (> index limit) - (if-not-found) - (compare key - (vector-ref vector index) - (lambda () (if-found index)) - (lambda () (loop (1+ index)))))))) \ No newline at end of file +(define-integrable (symbol->dbg-name symbol) + (cond ((object-type? (ucode-type interned-symbol) symbol) + (system-pair-car symbol)) + ((object-type? (ucode-type uninterned-symbol) symbol) + symbol) + (else + (error "SYMBOL->DBG-NAME: not a symbol" symbol)))) + +(define (dbg-name? object) + (or (string? object) + (object-type? (ucode-type interned-symbol) object) + (object-type? (ucode-type uninterned-symbol) object))) + +(define (dbg-name/normal? object) + (or (string? object) + (object-type? (ucode-type uninterned-symbol) object))) + +(define (dbg-name=? x y) + (or (eq? x y) + (let ((name->string + (lambda (name) + (cond ((string? name) + name) + ((object-type? (ucode-type interned-symbol) name) + (system-pair-car name)) + (else + false))))) + (let ((x (name->string x)) (y (name->string y))) + (and x y (string-ci=? x y)))))) + +(define (dbg-namestring + (lambda (name) + (cond ((string? name) + name) + ((or (object-type? (ucode-type interned-symbol) name) + (object-type? (ucode-type uninterned-symbol) name)) + (system-pair-car name)) + (else + (error "Illegal dbg-name" name)))))) + (string-cistring x) (name->string y)))) + +(define (dbg-name/string name) + (cond ((string? name) + name) + ((object-type? (ucode-type interned-symbol) name) + (system-pair-car name)) + ((object-type? (ucode-type uninterned-symbol) name) + (write-to-string name)) + (else + (error "Illegal dbg-name" name)))) \ No newline at end of file diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index 0cd85c806..0d10a9d87 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.4 1988/08/05 20:47:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.5 1988/12/30 06:43:04 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -53,18 +53,28 @@ MIT in each case. |# (lambda (port) (stream->list (read-stream port))))) -(define (fasload filename) +(define (fasload filename #!optional quiet?) (fasload/internal - (find-true-filename (->pathname filename) fasload/default-types))) - -(define (fasload/internal true-filename) - (let ((port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "FASLoading " port) - (write true-filename port) - (let ((value ((ucode-primitive binary-fasload) true-filename))) - (write-string " -- done" port) - value))) + (find-true-pathname (->pathname filename) fasload/default-types) + (if (default-object? quiet?) false quiet?))) + +(define (fasload/internal true-pathname quiet?) + (let ((value + (let ((true-filename (pathname->string true-pathname))) + (let ((do-it + (lambda () + ((ucode-primitive binary-fasload) true-filename)))) + (if quiet? + (do-it) + (let ((port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "FASLoading " port) + (write true-filename port) + (let ((value (do-it))) + (write-string " -- done" port) + value))))))) + (fasload/update-debugging-info! value true-pathname) + value)) (define (load-noisily filename #!optional environment syntax-table purify?) (fluid-let ((load-noisily? true)) @@ -108,7 +118,7 @@ MIT in each case. |# (let ((value (let ((pathname (->pathname filename))) (load/internal pathname - (find-true-filename pathname + (find-true-pathname pathname load/default-types) environment syntax-table @@ -127,37 +137,37 @@ MIT in each case. |# (define default-object "default-object") -(define (load/internal pathname true-filename environment syntax-table +(define (load/internal pathname true-pathname environment syntax-table purify? load-noisily?) - (let ((port (open-input-file/internal pathname true-filename))) + (let ((port + (open-input-file/internal pathname (pathname->string true-pathname)))) (if (= 250 (char->ascii (peek-char port))) (begin (close-input-port port) - (scode-eval (let ((scode (fasload/internal true-filename))) - (if purify? (purify scode)) - scode) - (if (eq? environment default-object) - (nearest-repl/environment) - environment))) + (scode-eval + (let ((scode (fasload/internal true-pathname false))) + (if purify? (purify scode)) + scode) + (if (eq? environment default-object) + (nearest-repl/environment) + environment))) (write-stream (eval-stream (read-stream port) environment syntax-table) (if load-noisily? (lambda (value) (hook/repl-write (nearest-repl) value)) (lambda (value) value false)))))) -(define (find-true-filename pathname default-types) - (pathname->string - (or (let ((try - (lambda (pathname) - (pathname->input-truename - (pathname-default-version pathname 'NEWEST))))) - (if (pathname-type pathname) - (try pathname) - (or (pathname->input-truename pathname) - (let loop ((types default-types)) - (and (not (null? types)) - (or (try (pathname-new-type pathname (car types))) - (loop (cdr types)))))))) - (error "No such file" pathname)))) - +(define (find-true-pathname pathname default-types) + (or (let ((try + (lambda (pathname) + (pathname->input-truename + (pathname-default-version pathname 'NEWEST))))) + (if (pathname-type pathname) + (try pathname) + (or (pathname->input-truename pathname) + (let loop ((types default-types)) + (and (not (null? types)) + (or (try (pathname-new-type pathname (car types))) + (loop (cdr types)))))))) + (error "No such file" pathname))) (define (read-stream port) (parse-objects port (current-parser-table) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index fe759a9eb..8afcbf5c1 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.22 1988/10/29 00:12:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.23 1988/12/30 06:43:14 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -207,45 +207,38 @@ MIT in each case. |# (initialization (initialize-package!))) (define-package (runtime compiler-info) - (files "infutl") + (files "infstr" "infutl") (parent ()) (export () - compiler-info? - make-compiler-info - compiler-info-procedures - compiler-info-continuations - compiler-info-labels - - make-label-info - label-info-name - label-info-offset - label-info-external? - *compiler-info/load-on-demand?* - compiler-info/with-on-demand-loading - compiler-info/without-on-demand-loading - flush-compiler-info! - - make-sorted-vector - sorted-vector/vector - sorted-vector/find-element - sorted-vector/lookup - sorted-vector/find-indices - sorted-vector/there-exists? - sorted-vector/for-each - - compiler-info/symbol-table - block-symbol-table - compiled-code-block->pathstring - compiled-code-block->compiler-info - - compiled-entry->name - compiled-entry->pathname - compiled-entry->compiler-info - compiled-entry->block-and-offset - compiled-entry->block-and-offset-indirect - info-file - ) + compiled-entry/block + compiled-entry/dbg-object + compiled-entry/filename + compiled-entry/offset + compiled-procedure/name + discard-debugging-info!) + (export (runtime load) fasload/update-debugging-info!) + (export (runtime debugger-utilities) + dbg-nametype stack-frame->continuation - stack-frame-type/address stack-frame-type/code + stack-frame-type/compiled-return-address stack-frame-type/properties stack-frame-type/subproblem? stack-frame-type? @@ -301,9 +294,11 @@ MIT in each case. |# stack-frame/length stack-frame/next stack-frame/next-subproblem + stack-frame/offset stack-frame/properties stack-frame/reductions stack-frame/ref + stack-frame/resolve-stack-address stack-frame/return-address stack-frame/return-code stack-frame/skip-non-subproblems @@ -319,6 +314,7 @@ MIT in each case. |# control-point/element-stream control-point/history control-point/interrupt-mask + control-point/n-elements control-point/next-control-point control-point/previous-history-control-point control-point/previous-history-offset @@ -358,10 +354,13 @@ MIT in each case. |# (parent (runtime debugger-command-loop)) (export (runtime debugger-command-loop) debug/read-eval-print-1 - environment-name + output-to-string print-user-friendly-name + show-environment-bindings show-frame - special-name?) + show-frames + special-name? + write-dbg-name) (initialization (initialize-package!))) (define-package (runtime debugging-info) @@ -404,15 +403,23 @@ MIT in each case. |# (parent ()) (export () environment-arguments - environment-bindings + environment-bound-names + environment-bound? environment-has-parent? + environment-lookup environment-parent - environment-procedure + environment-procedure-name environment? ic-environment? - remove-environment-parent! - set-environment-parent! - system-global-environment?)) + interpreter-environment? + system-global-environment?) + (export (runtime advice) + ic-environment/arguments + ic-environment/procedure) + (export (runtime debugger) + ic-environment/procedure) + (export (runtime debugging-info) + stack-frame/environment)) (define-package (runtime environment-inspector) (files "where") @@ -672,6 +679,7 @@ MIT in each case. |# lambda-body lambda-bound lambda-components + lambda-name make-block-declaration make-lambda set-lambda-body!) @@ -1506,6 +1514,7 @@ MIT in each case. |# stream->list stream-car stream-cdr + stream-head stream-length stream-map stream-null? diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index 10ea3895e..be4a412d8 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.3 1988/08/01 23:08:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.4 1988/12/30 06:43:34 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -37,91 +37,190 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Environment - (define (environment? object) - (if (system-global-environment? object) - true + (or (system-global-environment? object) + (ic-environment? object) + (stack-ccenv? object) + (closure-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)))) + +(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)))) + +(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)))) + +(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)) + 'UNKNOWN) + (else (error "Illegal environment" environment)))) + +(define (environment-procedure-name environment) + (cond ((system-global-environment? environment) + false) + ((ic-environment? environment) + (ic-environment/procedure-name environment)) + ((stack-ccenv? environment) + (stack-ccenv/procedure-name environment)) + ((closure-ccenv? environment) + (closure-ccenv/procedure-name environment)) + (else (error "Illegal environment" environment)))) + +(define (environment-bound? environment name) + (cond ((system-global-environment? environment) + (system-global-environment/bound? environment name)) + ((ic-environment? environment) + (ic-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)))) + +(define (environment-lookup environment name) + (cond ((system-global-environment? environment) + (system-global-environment/lookup environment name)) + ((ic-environment? environment) + (ic-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)))) + +;;;; Interpreter Environments + +(define (interpreter-environment? object) + (or (system-global-environment? object) (ic-environment? object))) (define-integrable (system-global-environment? object) (eq? system-global-environment object)) +(define (system-global-environment/bound? environment name) + (not (lexical-unbound? environment name))) + +(define (system-global-environment/lookup environment name) + (if (lexical-unassigned? environment name) + (make-unassigned-reference-trap) + (lexical-reference environment name))) + +(define (system-global-environment/bound-names environment) + (let ((table (fixed-objects-item 'OBARRAY))) + (let per-bucket ((index (-1+ (vector-length table))) (accumulator '())) + (if (< index 0) + accumulator + (let per-symbol + ((bucket (vector-ref table index)) + (accumulator accumulator)) + (if (null? bucket) + (per-bucket (-1+ index) accumulator) + (per-symbol + (cdr bucket) + (if (not (lexical-unbound? environment (car bucket))) + (cons (car bucket) accumulator) + accumulator)))))))) + (define-integrable (ic-environment? object) (object-type? (ucode-type environment) object)) -(define (environment-procedure environment) - (select-procedure (environment->external environment))) +(define (guarantee-ic-environment object) + (if (not (ic-environment? object)) + (error "Bad IC environment" object)) + object) -(define (environment-has-parent? environment) - (and (ic-environment? environment) - (not (eq? (select-parent (environment->external environment)) - null-environment)))) +(define (ic-environment/procedure-name environment) + (lambda-name (procedure-lambda (ic-environment/procedure environment)))) -(define (environment-parent environment) - (select-parent (environment->external environment))) - -(define (environment-bindings environment) - (environment-split environment - (lambda (external internal) - (map (lambda (name) - (cons name - (if (lexical-unassigned? internal name) - '() - `(,(lexical-reference internal name))))) - (list-transform-negative - (map* (lambda-bound (select-lambda external)) - car - (let ((extension (environment-extension internal))) - (if (environment-extension? extension) - (environment-extension-aux-list extension) - '()))) - (lambda (name) - (lexical-unbound? internal name))))))) +(define (ic-environment/has-parent? environment) + (not (eq? (ic-environment/parent environment) null-environment))) -(define (environment-arguments environment) - (environment-split environment - (lambda (external internal) +(define (ic-environment/parent environment) + (select-parent (ic-environment->external environment))) + +(define (ic-environment/bound-names environment) + (list-transform-negative + (map* (lambda-bound + (select-lambda (ic-environment->external environment))) + car + (let ((extension (ic-environment/extension environment))) + (if (environment-extension? extension) + (environment-extension-aux-list extension) + '()))) + (lambda (name) + (lexical-unbound? environment name)))) + +(define (ic-environment/bound? environment name) + (not (lexical-unbound? environment name))) + +(define (ic-environment/lookup environment name) + (if (lexical-unassigned? environment name) + (make-unassigned-reference-trap) + (lexical-reference environment name))) + +(define (ic-environment/arguments environment) + (lambda-components* (select-lambda (ic-environment->external environment)) + (lambda (name required optional rest body) + name body (let ((lookup (lambda (name) - (if (lexical-unassigned? internal name) - (make-unassigned-reference-trap) - (lexical-reference internal name))))) - (lambda-components* (select-lambda external) - (lambda (name required optional rest body) - name body - (map* (let loop ((names optional)) - (cond ((null? names) (if rest (lookup rest) '())) - ((lexical-unassigned? internal (car names)) '()) - (else - (cons (lookup (car names)) (loop (cdr names)))))) - lookup - required))))))) - -(define (set-environment-parent! environment parent) + (ic-environment/lookup environment name)))) + (map* (map* (if rest (lookup rest) '()) + lookup + optional) + lookup + required))))) + +(define (ic-environment/procedure environment) + (select-procedure (ic-environment->external environment))) + +(define (ic-environment/set-parent! environment parent) (system-pair-set-cdr! - (let ((extension (environment-extension environment))) + (let ((extension (ic-environment/extension environment))) (if (environment-extension? extension) (begin (set-environment-extension-parent! extension parent) (environment-extension-procedure extension)) extension)) parent)) -(define (remove-environment-parent! environment) - (set-environment-parent! environment null-environment)) +(define (ic-environment/remove-parent! environment) + (ic-environment/set-parent! environment null-environment)) (define null-environment (object-new-type (ucode-type null) 1)) -(define (environment-split environment receiver) - (let ((procedure (select-procedure environment))) - (let ((lambda (compound-procedure-lambda procedure))) - (receiver (if (internal-lambda? lambda) - (compound-procedure-environment procedure) - environment) - environment)))) - -(define (environment->external environment) +(define (ic-environment->external environment) (let ((procedure (select-procedure environment))) (if (internal-lambda? (compound-procedure-lambda procedure)) (compound-procedure-environment procedure) @@ -142,5 +241,35 @@ MIT in each case. |# (define (select-lambda environment) (compound-procedure-lambda (select-procedure environment))) -(define (environment-extension environment) - (select-extension (environment->external environment))) \ No newline at end of file +(define (ic-environment/extension environment) + (select-extension (ic-environment->external environment))) + +;;;; Compiled Code Environments + +(define-structure (stack-ccenv + (named + (string->symbol "#[(runtime environment)stack-ccenv]")) + (conc-name stack-ccenv/)) + (block false read-only true) + (frame false read-only true) + (start-index false read-only true)) + +(define (stack-frame/environment frame default) + (let ((continuation + (compiled-entry/dbg-object (stack-frame/return-address frame)))) + (if continuation + (let ((block (dbg-continuation/block continuation))) + (let ((parent (dbg-block/parent block))) + (case (dbg-block/type parent) + ((STACK) + (make-stack-ccenv parent + frame + (1+ (dbg-continuation/offset continuation)))) + ((IC) + (let ((index (dbg-block/ic-parent-index block))) + (if index + (guarantee-ic-environment (stack-frame/ref frame index)) + default))) + (else + (error "Illegal continuation parent" parent))))) + default))) \ No newline at end of file