#| -*-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
;;; 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
#| -*-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
(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)
(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
(let ((stack-frame (stack-frame/next stack-frame)))
(and stack-frame
(stack-frame/skip-non-subproblems stack-frame)))))
-
+\f
(define-integrable (stack-frame/length stack-frame)
(vector-length (stack-frame/elements stack-frame)))
(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))))))
\f
;;;; Parser
(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)
(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)))))
\f
-(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)))
(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))))
-\f
-(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
(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))))
\f
;;;; Unparser
(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)))))
\f
-;;;; 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)))))
+\f;;;; 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
history
previous-history-offset
previous-history-control-point)
- (parser/interpreter-next
+ (parser/standard-next
type
elements
(make-parser-state dynamic-state
previous-history-offset
previous-history-control-point
(parser-state/element-stream state)
+ (parser-state/n-elements state)
(parser-state/next-control-point state))))
-\f
-;;;; Specific Parsers
(define (parser/restore-dynamic-state type elements state)
(make-restore-frame type elements state
;; 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
(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)
(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)))
(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)))
\f
;;;; 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))
\f
- (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
#| -*-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
(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)
#| -*-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
(,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)
\f
-(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)
- (string<? (symbol->string (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)))
#| -*-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
'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
"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)
\f
;;;; Random display commands
(define (pretty-print-current-expression)
- (print-expression current-expression))
+ (cond ((debugging-info/undefined-expression? current-expression)
+ (newline)
+ (write-string "<undefined-expression>"))
+ ((debugging-info/compiled-code? current-expression)
+ (newline)
+ (write-string "<compiled-code>"))
+ (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)
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
(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)
+ "<undefined-expression>")
+ ((debugging-info/compiled-code? expression)
+ "<compiled-code>")
+ (else
+ (output-to-string 50 (lambda () (write (unsyntax expression))))))))
\f
;;;; Motion to earlier expressions
(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))
"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))
\f
;;;; Reduction and subproblem motion low-level
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)
(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 "<undefined-expression>"))
- ((debugging-info/compiled-code? expression)
- (newline)
- (write-string "<compiled-code>"))
- (else
- (pp expression))))
\ No newline at end of file
+ (write-string "Undefined environment at this subproblem/reduction level"))
\ No newline at end of file
#| -*-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
(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)
(define evaluated-object-tag "evaluated")
\f
(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)
undefined-environment))
\f
(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)))
(,method/null
COMBINATION-APPLY
GC-CHECK
- MOVE-TO-ADJACENT-POINT)
+ MOVE-TO-ADJACENT-POINT
+ REENTER-COMPILED-CODE)
(,method/expression-only
ACCESS-CONTINUE
(,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)
(,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
#| -*-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
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"))
\f
+(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))
-\f
-;;; 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))))
-\f
-(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)))))))
-\f
-;; 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))
-\f
-;;; 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)
\f
-;;;; 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<?)
- (%make-sorted-vector vector
- key=?
- (lambda (key entry if= if< if>)
- ((cond ((key=? key entry) if=)
- ((key<? key entry) if<)
- (else if>))))))
-
-(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))))))))\f
+(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))))))))
\f
-(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-name<? x y)
+ (let ((name->string
+ (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-ci<? (name->string 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
#| -*-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
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
(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))))
(define lambda-unwrap-body!)
(define lambda-body)
(define set-lambda-body!)
+(define lambda-name)
(define lambda-bound)
(define-structure (block-declaration
(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))
\f
#| -*-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
(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))
(let ((value
(let ((pathname (->pathname filename)))
(load/internal pathname
- (find-true-filename pathname
+ (find-true-pathname pathname
load/default-types)
environment
syntax-table
(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))))))\f
-(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)
#| -*-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
(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)
(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))
(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
#| -*-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
(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-name<?
+ dbg-name=?)
+ (export (runtime environment)
+ dbg-block/find-name
+ dbg-block/ic-parent-index
+ dbg-block/layout
+ dbg-block/normal-closure-index
+ dbg-block/parent
+ dbg-block/procedure
+ dbg-block/stack-link
+ dbg-block/static-link-index
+ dbg-block/type
+ dbg-continuation/block
+ dbg-continuation/offset
+ dbg-name/normal?
+ dbg-procedure/block
+ dbg-procedure/name
+ dbg-procedure/required
+ dbg-procedure/optional
+ dbg-procedure/rest)
(initialization (initialize-package!)))
(define-package (runtime console-input)
continuation/first-subproblem
microcode-return/code->type
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?
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
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
(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)
(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")
lambda-body
lambda-bound
lambda-components
+ lambda-name
make-block-declaration
make-lambda
set-lambda-body!)
stream->list
stream-car
stream-cdr
+ stream-head
stream-length
stream-map
stream-null?
#| -*-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
(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))
#| -*-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
(declare (usual-integrations))
\f
-(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)
(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)))
+\f
(define (compiled-procedure-arity object)
(let ((info ((ucode-primitive compiled-entry-kind 1) object)))
(if (not (= (system-hunk3-cxr0 info) 0))
(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)
#| -*-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
(declare (usual-integrations))
\f
-;;;; 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))))
+\f
+(define (environment-arguments environment)
+ (cond ((ic-environment? environment)
+ (ic-environment/arguments environment))
+ ((stack-ccenv? environment)
+ (stack-ccenv/arguments environment))
+ ((or (system-global-environment? environment)
+ (closure-ccenv? environment))
+ '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))))
+\f
+;;;; 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)))
+\f
+(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)))))))
-\f
-(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)
(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)))
+\f
+;;;; 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
#| -*-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
(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
;;;; 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)
(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)
#| -*-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
(*unparse-with-brackets 'PRIMITIVE-PROCEDURE false
(lambda ()
(*unparse-object (primitive-procedure-name procedure)))))
-\f
-;;;; Compiled entries
(define (unparse/compiled-entry entry)
(let* ((type (compiled-entry-type entry))
(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)))
-\f
+ (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)
#| -*-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
(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
#| -*-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
'()))
(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)
#| -*-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
"Create a read-eval-print loop in the current environment")
(#\N ,name
"Name of procedure which created current environment")
- ))))
+ )))
+ unspecific)
(define command-set)
-\f
-(define env)
-(define current-frame)
-(define current-frame-depth)
+(define frame-list)
(define (where #!optional environment)
(let ((environment
(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-->"))))
\f
-;;;; 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))))
-\f
-;;;; 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
#| -*-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
(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)
(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
(let ((stack-frame (stack-frame/next stack-frame)))
(and stack-frame
(stack-frame/skip-non-subproblems stack-frame)))))
-
+\f
(define-integrable (stack-frame/length stack-frame)
(vector-length (stack-frame/elements stack-frame)))
(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))))))
\f
;;;; Parser
(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)
(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)))))
\f
-(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)))
(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))))
-\f
-(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
(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))))
\f
;;;; Unparser
(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)))))
\f
-;;;; 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)))))
+\f;;;; 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
history
previous-history-offset
previous-history-control-point)
- (parser/interpreter-next
+ (parser/standard-next
type
elements
(make-parser-state dynamic-state
previous-history-offset
previous-history-control-point
(parser-state/element-stream state)
+ (parser-state/n-elements state)
(parser-state/next-control-point state))))
-\f
-;;;; Specific Parsers
(define (parser/restore-dynamic-state type elements state)
(make-restore-frame type elements state
;; 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
(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)
(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)))
(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)))
\f
;;;; 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))
\f
- (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
#| -*-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
(,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)
\f
-(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)
- (string<? (symbol->string (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)))
#| -*-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
(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)
(define evaluated-object-tag "evaluated")
\f
(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)
undefined-environment))
\f
(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)))
(,method/null
COMBINATION-APPLY
GC-CHECK
- MOVE-TO-ADJACENT-POINT)
+ MOVE-TO-ADJACENT-POINT
+ REENTER-COMPILED-CODE)
(,method/expression-only
ACCESS-CONTINUE
(,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)
(,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
#| -*-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
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"))
\f
+(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))
-\f
-;;; 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))))
-\f
-(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)))))))
-\f
-;; 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))
-\f
-;;; 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)
\f
-;;;; 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<?)
- (%make-sorted-vector vector
- key=?
- (lambda (key entry if= if< if>)
- ((cond ((key=? key entry) if=)
- ((key<? key entry) if<)
- (else if>))))))
-
-(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))))))))\f
+(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))))))))
\f
-(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-name<? x y)
+ (let ((name->string
+ (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-ci<? (name->string 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
#| -*-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
(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))
(let ((value
(let ((pathname (->pathname filename)))
(load/internal pathname
- (find-true-filename pathname
+ (find-true-pathname pathname
load/default-types)
environment
syntax-table
(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))))))\f
-(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)
#| -*-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
(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-name<?
+ dbg-name=?)
+ (export (runtime environment)
+ dbg-block/find-name
+ dbg-block/ic-parent-index
+ dbg-block/layout
+ dbg-block/normal-closure-index
+ dbg-block/parent
+ dbg-block/procedure
+ dbg-block/stack-link
+ dbg-block/static-link-index
+ dbg-block/type
+ dbg-continuation/block
+ dbg-continuation/offset
+ dbg-name/normal?
+ dbg-procedure/block
+ dbg-procedure/name
+ dbg-procedure/required
+ dbg-procedure/optional
+ dbg-procedure/rest)
(initialization (initialize-package!)))
(define-package (runtime console-input)
continuation/first-subproblem
microcode-return/code->type
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?
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
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
(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)
(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")
lambda-body
lambda-bound
lambda-components
+ lambda-name
make-block-declaration
make-lambda
set-lambda-body!)
stream->list
stream-car
stream-cdr
+ stream-head
stream-length
stream-map
stream-null?
#| -*-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
(declare (usual-integrations))
\f
-;;;; 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))))
+\f
+(define (environment-arguments environment)
+ (cond ((ic-environment? environment)
+ (ic-environment/arguments environment))
+ ((stack-ccenv? environment)
+ (stack-ccenv/arguments environment))
+ ((or (system-global-environment? environment)
+ (closure-ccenv? environment))
+ '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))))
+\f
+;;;; 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)))
+\f
+(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)))))))
-\f
-(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)
(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)))
+\f
+;;;; 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
projects / mit-scheme.git / commitdiff