frames from compiled code in which the return address is a procedure.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.16 1990/08/08 00:57:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.17 1990/08/21 04:18:26 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(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))
+ (next-control-point false read-only true)
+ (allow-next-extended? false read-only true))
(define (continuation->stack-frame continuation)
(parse/control-point (continuation/control-point continuation)
(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)))))
+ (control-point/next-control-point control-point)
+ false))))
(define (parse/start state)
(let ((stream (parser-state/element-stream state)))
(if (stream-pair? stream)
(let ((type
(return-address->stack-frame-type
- (element-stream/head stream))))
+ (element-stream/head stream)
+ (parser-state/allow-next-extended? state))))
(let ((length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
((stack-frame-type/parser type)
type
(list->vector (stream-head stream length))
- (parse/next-state state length (stream-tail stream length)))))
+ (parse/next-state state length (stream-tail stream length)
+ (stack-frame-type/allow-extended? type)))))
(parse/control-point (parser-state/next-control-point state)
(parser-state/dynamic-state state)
(parser-state/fluid-bindings state)))))
\f
-(define (parse/next-state state length stream)
+(define (parse/next-state state length stream allow-extended?)
(let ((previous-history-control-point
(parser-state/previous-history-control-point state)))
(make-parser-state
previous-history-control-point
stream
(- (parser-state/n-elements state) length)
- (parser-state/next-control-point state))))
+ (parser-state/next-control-point state)
+ allow-extended?)))
(define (make-frame type elements state element-stream n-elements)
(let ((history-subproblem?
previous-history-control-point
element-stream
n-elements
- (parser-state/next-control-point state)))))
+ (parser-state/next-control-point state)
+ (stack-frame-type/allow-extended? type)))))
(define (element-stream/head stream)
(if (not (stream-pair? stream)) (error "not a stream-pair" stream))
(1+ frame-size)
(stack-address->index (element-stream/ref stream 1) offset)))))
+(define (length/interrupt-compiled-procedure stream offset)
+ offset ; ignored
+ (1+ (compiled-procedure-frame-size (element-stream/head stream))))
+
(define (verify paranoia-index stream offset)
(or (zero? paranoia-index)
(stream-null? stream)
(let* ((type (return-address->stack-frame-type
- (element-stream/head stream)))
+ (element-stream/head stream)
+ false))
(length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
(ltail (stream-tail* stream length)))
(and ltail
(return-address? (element-stream/head ltail))
- (verify (-1+ paranoia-index)
- ltail
- (+ offset length))))))
-
+ (loop (-1+ paranoia-index)
+ ltail
+ (+ offset length))))))
(define (stream-tail* stream n)
(cond ((or (zero? n) (stream-null? stream))
stream)
previous-history-control-point
(parser-state/element-stream state)
(parser-state/n-elements state)
- (parser-state/next-control-point state))))
+ (parser-state/next-control-point state)
+ false)))
\f
(define (parser/restore-dynamic-state type elements state)
(make-restore-frame type elements state
(length false read-only true)
(parser false read-only true))
+(define allow-extended-return-addresses?-tag
+ "stack-frame-type/allow-extended")
+
+(define (stack-frame-type/allow-extended? type)
+ (1d-table/get
+ (stack-frame-type/properties type)
+ allow-extended-return-addresses?-tag
+ false))
+
(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 (return-address->stack-frame-type return-address)
+(define (return-address->stack-frame-type return-address allow-extended?)
(cond ((interpreter-return-address? return-address)
(let ((code (return-address/code return-address)))
(let ((type (microcode-return/code->type code)))
return-address)
stack-frame-type/return-to-interpreter
stack-frame-type/compiled-return-address))
+ ((and allow-extended? (compiled-procedure? return-address))
+ stack-frame-type/interrupt-compiled-procedure)
+ ((and allow-extended? (compiled-expression? return-address))
+ stack-frame-type/interrupt-compiled-expression)
(else
(error "illegal return address" return-address))))
true
1
parser/standard-next))
+ (set! stack-frame-type/interrupt-compiled-procedure
+ (make-stack-frame-type false
+ true
+ false
+ length/interrupt-compiled-procedure
+ parser/standard-next))
+ (set! stack-frame-type/interrupt-compiled-expression
+ (make-stack-frame-type false
+ true
+ false
+ 1
+ parser/standard-next))
+
(set! word-size
(let ((initial (system-vector-length (make-bit-string 1 #f))))
(let loop ((size 2))
(define stack-frame-type/compiled-return-address)
(define stack-frame-type/return-to-interpreter)
(define stack-frame-type/hardware-trap)
+(define stack-frame-type/interrupt-compiled-procedure)
+(define stack-frame-type/interrupt-compiled-expression)
(define (make-stack-frame-types)
(let ((types (make-vector (microcode-return/code-limit) false)))
history-subproblem?
length parser)
(let ((code (microcode-return name)))
- (vector-set! types
- code
- (make-stack-frame-type code subproblem?
- history-subproblem?
- length parser))))
+ (let ((type (make-stack-frame-type code subproblem?
+ history-subproblem?
+ length parser)))
+ (vector-set! types code type)
+ type)))
(define (standard-frame name length #!optional parser)
(stack-frame-type name
(compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length)
(compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length))
- (compiler-frame 'COMPILER-INTERRUPT-RESTART 3) (compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
+ (let ((type
+ (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
+ (1d-table/put! (stack-frame-type/properties type)
+ allow-extended-return-addresses?-tag
+ true))
+
+ (compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
(compiler-frame 'REENTER-COMPILED-CODE 2)
(compiler-subproblem 'COMPILER-ACCESS-RESTART 4)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.17 1989/12/19 15:37:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.18 1990/08/21 04:18:33 jinx Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(return value))))
(debugger-failure "Can't continue!!!"))))
+(define *dstate*)
+
(define (command/internal dstate)
- dstate ;ignore
- (debug/read-eval-print (->environment '(RUNTIME DEBUGGER))
- "You are now in the debugger environment"
- "Debugger-->"))
+ (fluid-let ((*dstate* dstate))
+ (debug/read-eval-print (->environment '(RUNTIME DEBUGGER))
+ "You are now in the debugger environment"
+ "Debugger-->")))
+
(define (command/frame dstate)
(presentation
(lambda ()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.10 1990/01/29 22:34:56 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.11 1990/08/21 04:18:40 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define (method/compiled-code frame)
(values
- (let ((continuation
+ (let ((object
(compiled-entry/dbg-object (stack-frame/return-address frame)))
(lose (lambda () compiled-code)))
- (if continuation
- (let ((source-code (dbg-continuation/source-code continuation)))
- (if (and (vector? source-code)
- (not (zero? (vector-length source-code))))
- (case (vector-ref source-code 0)
- ((SEQUENCE-2-SECOND
- SEQUENCE-3-SECOND
- SEQUENCE-3-THIRD
- CONDITIONAL-DECIDE
- ASSIGNMENT-CONTINUE
- DEFINITION-CONTINUE
- COMBINATION-OPERAND)
- (vector-ref source-code 1))
- (else
- (lose)))
- (lose)))
- (lose)))
+ (cond ((not object)
+ (lose))
+ ((dbg-continuation? object)
+ (let ((source-code (dbg-continuation/source-code object)))
+ (if (and (vector? source-code)
+ (not (zero? (vector-length source-code))))
+ (case (vector-ref source-code 0)
+ ((SEQUENCE-2-SECOND
+ SEQUENCE-3-SECOND
+ SEQUENCE-3-THIRD
+ CONDITIONAL-DECIDE
+ ASSIGNMENT-CONTINUE
+ DEFINITION-CONTINUE
+ COMBINATION-OPERAND)
+ (vector-ref source-code 1))
+ (else
+ (lose)))
+ (lose))))
+ ((dbg-procedure? object)
+ (lambda-body (dbg-procedure/source-code object)))
+ #|
+ ((dbg-expression? object)
+ ;; no expression!
+ (lose))
+ |#
+ (else
+ (lose))))
(stack-frame/environment frame undefined-environment)))
(define (method/primitive-combination-3-first-operand frame)
(,method/hardware-trap
HARDWARE-TRAP)))
- (1d-table/put!
- (stack-frame-type/properties stack-frame-type/compiled-return-address)
- method-tag
- method/compiled-code))
\ No newline at end of file
+ (for-each
+ (lambda (type)
+ (1d-table/put!
+ (stack-frame-type/properties type)
+ method-tag
+ method/compiled-code))
+ (list
+ stack-frame-type/compiled-return-address
+ stack-frame-type/interrupt-compiled-procedure
+ stack-frame-type/interrupt-compiled-expression)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.17 1990/06/28 16:35:56 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.18 1990/08/21 04:18:47 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(discriminate-compiled-entry entry
find-procedure
(lambda ()
- (vector-binary-search (dbg-info/continuations dbg-info)
- <
- dbg-continuation/label-offset
- offset)) (lambda ()
+ (or (vector-binary-search (dbg-info/continuations dbg-info)
+ <
+ dbg-continuation/label-offset
+ offset)
+ (find-procedure)))
+ (lambda ()
(let ((expression (dbg-info/expression dbg-info)))
(if (= offset (dbg-expression/label-offset expression))
expression
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.72 1990/07/20 01:21:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.73 1990/08/21 04:18:57 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
dbg-block/stack-link
dbg-block/static-link-index
dbg-block/type
+ dbg-continuation?
dbg-continuation/block
dbg-continuation/offset
+ dbg-expression?
+ dbg-procedure?
dbg-procedure/block
dbg-procedure/name
dbg-procedure/required
dbg-variable/value
dbg-variable?)
(export (runtime debugging-info)
- dbg-continuation/source-code)
+ dbg-continuation?
+ dbg-continuation/source-code
+ dbg-procedure?
+ dbg-procedure/source-code
+ dbg-expression?
+ )
(initialization (initialize-package!)))
(define-package (runtime console-input)
stack-frame/type
stack-frame?)
(export (runtime debugger)
- stack-frame/compiled-code?) (initialization (initialize-package!)))
+ stack-frame/compiled-code?)
+ (export (runtime debugging-info)
+ stack-frame-type/interrupt-compiled-procedure
+ stack-frame-type/interrupt-compiled-expression)
+ (initialization (initialize-package!)))
(define-package (runtime control-point)
(files "cpoint")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.13 1990/06/07 19:55:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.14 1990/08/21 04:19:05 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(let ((info ((ucode-primitive compiled-entry-kind 1) object)))
(if (not (= (system-hunk3-cxr0 info) 0))
(error "COMPILED-PROCEDURE-ARITY: bad compiled procedure" object))
+ ;; max = (-1)^tail? * (1 + req + opt + tail?)
+ ;; min = (1 + req)
(cons (-1+ (system-hunk3-cxr1 info))
(let ((max (system-hunk3-cxr2 info)))
(and (not (negative? max))
(-1+ max))))))
+
+(define (compiled-procedure-frame-size procedure)
+ (let ((info ((ucode-primitive compiled-entry-kind 1) procedure)))
+ (if (not (= (system-hunk3-cxr0 info) 0))
+ (error "COMPILED-PROCEDURE-FRAME-SIZE: bad compiled procedure"
+ procedure))
+ (let ((max (system-hunk3-cxr2 info)))
+ ;; max = (-1)^tail? * (1 + req + opt + tail?)
+ ;; frame = req + opt + tail?
+ (if (negative? max)
+ (- -1 max)
+ (-1+ max)))))
+
(define (compiled-continuation/next-continuation-offset entry)
(let ((offset
(system-hunk3-cxr2 ((ucode-primitive compiled-entry-kind 1) entry))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.18 1990/08/07 20:11:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.19 1990/08/21 04:19:12 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(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
- (+ (dbg-continuation/offset continuation)
- (vector-length (dbg-block/layout-vector block)))))
- ((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 block" parent)))))
- default)))
+ (let* ((ret-add (stack-frame/return-address frame))
+ (object (compiled-entry/dbg-object ret-add)))
+ (cond ((not object)
+ default)
+ ((dbg-continuation? object)
+ (let ((block (dbg-continuation/block object)))
+ (let ((parent (dbg-block/parent block)))
+ (case (dbg-block/type parent)
+ ((STACK)
+ (make-stack-ccenv
+ parent
+ frame
+ (+ (dbg-continuation/offset object)
+ (vector-length (dbg-block/layout-vector block)))))
+ ((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 block" parent))))))
+ ((dbg-procedure? object)
+ (let ((block (dbg-procedure/block object)))
+ (case (dbg-block/type block)
+ ((STACK)
+ (make-stack-ccenv
+ block
+ frame
+ (if (compiled-closure? ret-add)
+ 0
+ 1)))
+ (else
+ (error "Illegal procedure block" block)))))
+ #|
+ ((dbg-expression? object)
+ ;; for now
+ default)
+ |#
+ (else
+ default))))
+
(define (compiled-procedure/environment entry)
(let ((procedure (compiled-entry/dbg-object entry)))
(if (not procedure)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.92 1990/08/16 20:13:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.93 1990/08/21 04:17:42 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
'()))
(add-system! microcode-system)
(add-event-receiver! event:after-restore snarf-microcode-version!)
- (add-identification! "Runtime" 14 92))
+ (add-identification! "Runtime" 14 93))
+
(define microcode-system)
(define (snarf-microcode-version!)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.16 1990/08/08 00:57:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.17 1990/08/21 04:18:26 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(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))
+ (next-control-point false read-only true)
+ (allow-next-extended? false read-only true))
(define (continuation->stack-frame continuation)
(parse/control-point (continuation/control-point continuation)
(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)))))
+ (control-point/next-control-point control-point)
+ false))))
(define (parse/start state)
(let ((stream (parser-state/element-stream state)))
(if (stream-pair? stream)
(let ((type
(return-address->stack-frame-type
- (element-stream/head stream))))
+ (element-stream/head stream)
+ (parser-state/allow-next-extended? state))))
(let ((length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
((stack-frame-type/parser type)
type
(list->vector (stream-head stream length))
- (parse/next-state state length (stream-tail stream length)))))
+ (parse/next-state state length (stream-tail stream length)
+ (stack-frame-type/allow-extended? type)))))
(parse/control-point (parser-state/next-control-point state)
(parser-state/dynamic-state state)
(parser-state/fluid-bindings state)))))
\f
-(define (parse/next-state state length stream)
+(define (parse/next-state state length stream allow-extended?)
(let ((previous-history-control-point
(parser-state/previous-history-control-point state)))
(make-parser-state
previous-history-control-point
stream
(- (parser-state/n-elements state) length)
- (parser-state/next-control-point state))))
+ (parser-state/next-control-point state)
+ allow-extended?)))
(define (make-frame type elements state element-stream n-elements)
(let ((history-subproblem?
previous-history-control-point
element-stream
n-elements
- (parser-state/next-control-point state)))))
+ (parser-state/next-control-point state)
+ (stack-frame-type/allow-extended? type)))))
(define (element-stream/head stream)
(if (not (stream-pair? stream)) (error "not a stream-pair" stream))
(1+ frame-size)
(stack-address->index (element-stream/ref stream 1) offset)))))
+(define (length/interrupt-compiled-procedure stream offset)
+ offset ; ignored
+ (1+ (compiled-procedure-frame-size (element-stream/head stream))))
+
(define (verify paranoia-index stream offset)
(or (zero? paranoia-index)
(stream-null? stream)
(let* ((type (return-address->stack-frame-type
- (element-stream/head stream)))
+ (element-stream/head stream)
+ false))
(length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
(ltail (stream-tail* stream length)))
(and ltail
(return-address? (element-stream/head ltail))
- (verify (-1+ paranoia-index)
- ltail
- (+ offset length))))))
-
+ (loop (-1+ paranoia-index)
+ ltail
+ (+ offset length))))))
(define (stream-tail* stream n)
(cond ((or (zero? n) (stream-null? stream))
stream)
previous-history-control-point
(parser-state/element-stream state)
(parser-state/n-elements state)
- (parser-state/next-control-point state))))
+ (parser-state/next-control-point state)
+ false)))
\f
(define (parser/restore-dynamic-state type elements state)
(make-restore-frame type elements state
(length false read-only true)
(parser false read-only true))
+(define allow-extended-return-addresses?-tag
+ "stack-frame-type/allow-extended")
+
+(define (stack-frame-type/allow-extended? type)
+ (1d-table/get
+ (stack-frame-type/properties type)
+ allow-extended-return-addresses?-tag
+ false))
+
(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 (return-address->stack-frame-type return-address)
+(define (return-address->stack-frame-type return-address allow-extended?)
(cond ((interpreter-return-address? return-address)
(let ((code (return-address/code return-address)))
(let ((type (microcode-return/code->type code)))
return-address)
stack-frame-type/return-to-interpreter
stack-frame-type/compiled-return-address))
+ ((and allow-extended? (compiled-procedure? return-address))
+ stack-frame-type/interrupt-compiled-procedure)
+ ((and allow-extended? (compiled-expression? return-address))
+ stack-frame-type/interrupt-compiled-expression)
(else
(error "illegal return address" return-address))))
true
1
parser/standard-next))
+ (set! stack-frame-type/interrupt-compiled-procedure
+ (make-stack-frame-type false
+ true
+ false
+ length/interrupt-compiled-procedure
+ parser/standard-next))
+ (set! stack-frame-type/interrupt-compiled-expression
+ (make-stack-frame-type false
+ true
+ false
+ 1
+ parser/standard-next))
+
(set! word-size
(let ((initial (system-vector-length (make-bit-string 1 #f))))
(let loop ((size 2))
(define stack-frame-type/compiled-return-address)
(define stack-frame-type/return-to-interpreter)
(define stack-frame-type/hardware-trap)
+(define stack-frame-type/interrupt-compiled-procedure)
+(define stack-frame-type/interrupt-compiled-expression)
(define (make-stack-frame-types)
(let ((types (make-vector (microcode-return/code-limit) false)))
history-subproblem?
length parser)
(let ((code (microcode-return name)))
- (vector-set! types
- code
- (make-stack-frame-type code subproblem?
- history-subproblem?
- length parser))))
+ (let ((type (make-stack-frame-type code subproblem?
+ history-subproblem?
+ length parser)))
+ (vector-set! types code type)
+ type)))
(define (standard-frame name length #!optional parser)
(stack-frame-type name
(compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length)
(compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length))
- (compiler-frame 'COMPILER-INTERRUPT-RESTART 3) (compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
+ (let ((type
+ (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
+ (1d-table/put! (stack-frame-type/properties type)
+ allow-extended-return-addresses?-tag
+ true))
+
+ (compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
(compiler-frame 'REENTER-COMPILED-CODE 2)
(compiler-subproblem 'COMPILER-ACCESS-RESTART 4)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.10 1990/01/29 22:34:56 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.11 1990/08/21 04:18:40 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define (method/compiled-code frame)
(values
- (let ((continuation
+ (let ((object
(compiled-entry/dbg-object (stack-frame/return-address frame)))
(lose (lambda () compiled-code)))
- (if continuation
- (let ((source-code (dbg-continuation/source-code continuation)))
- (if (and (vector? source-code)
- (not (zero? (vector-length source-code))))
- (case (vector-ref source-code 0)
- ((SEQUENCE-2-SECOND
- SEQUENCE-3-SECOND
- SEQUENCE-3-THIRD
- CONDITIONAL-DECIDE
- ASSIGNMENT-CONTINUE
- DEFINITION-CONTINUE
- COMBINATION-OPERAND)
- (vector-ref source-code 1))
- (else
- (lose)))
- (lose)))
- (lose)))
+ (cond ((not object)
+ (lose))
+ ((dbg-continuation? object)
+ (let ((source-code (dbg-continuation/source-code object)))
+ (if (and (vector? source-code)
+ (not (zero? (vector-length source-code))))
+ (case (vector-ref source-code 0)
+ ((SEQUENCE-2-SECOND
+ SEQUENCE-3-SECOND
+ SEQUENCE-3-THIRD
+ CONDITIONAL-DECIDE
+ ASSIGNMENT-CONTINUE
+ DEFINITION-CONTINUE
+ COMBINATION-OPERAND)
+ (vector-ref source-code 1))
+ (else
+ (lose)))
+ (lose))))
+ ((dbg-procedure? object)
+ (lambda-body (dbg-procedure/source-code object)))
+ #|
+ ((dbg-expression? object)
+ ;; no expression!
+ (lose))
+ |#
+ (else
+ (lose))))
(stack-frame/environment frame undefined-environment)))
(define (method/primitive-combination-3-first-operand frame)
(,method/hardware-trap
HARDWARE-TRAP)))
- (1d-table/put!
- (stack-frame-type/properties stack-frame-type/compiled-return-address)
- method-tag
- method/compiled-code))
\ No newline at end of file
+ (for-each
+ (lambda (type)
+ (1d-table/put!
+ (stack-frame-type/properties type)
+ method-tag
+ method/compiled-code))
+ (list
+ stack-frame-type/compiled-return-address
+ stack-frame-type/interrupt-compiled-procedure
+ stack-frame-type/interrupt-compiled-expression)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.17 1990/06/28 16:35:56 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.18 1990/08/21 04:18:47 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(discriminate-compiled-entry entry
find-procedure
(lambda ()
- (vector-binary-search (dbg-info/continuations dbg-info)
- <
- dbg-continuation/label-offset
- offset)) (lambda ()
+ (or (vector-binary-search (dbg-info/continuations dbg-info)
+ <
+ dbg-continuation/label-offset
+ offset)
+ (find-procedure)))
+ (lambda ()
(let ((expression (dbg-info/expression dbg-info)))
(if (= offset (dbg-expression/label-offset expression))
expression
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.72 1990/07/20 01:21:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.73 1990/08/21 04:18:57 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
dbg-block/stack-link
dbg-block/static-link-index
dbg-block/type
+ dbg-continuation?
dbg-continuation/block
dbg-continuation/offset
+ dbg-expression?
+ dbg-procedure?
dbg-procedure/block
dbg-procedure/name
dbg-procedure/required
dbg-variable/value
dbg-variable?)
(export (runtime debugging-info)
- dbg-continuation/source-code)
+ dbg-continuation?
+ dbg-continuation/source-code
+ dbg-procedure?
+ dbg-procedure/source-code
+ dbg-expression?
+ )
(initialization (initialize-package!)))
(define-package (runtime console-input)
stack-frame/type
stack-frame?)
(export (runtime debugger)
- stack-frame/compiled-code?) (initialization (initialize-package!)))
+ stack-frame/compiled-code?)
+ (export (runtime debugging-info)
+ stack-frame-type/interrupt-compiled-procedure
+ stack-frame-type/interrupt-compiled-expression)
+ (initialization (initialize-package!)))
(define-package (runtime control-point)
(files "cpoint")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.18 1990/08/07 20:11:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.19 1990/08/21 04:19:12 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(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
- (+ (dbg-continuation/offset continuation)
- (vector-length (dbg-block/layout-vector block)))))
- ((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 block" parent)))))
- default)))
+ (let* ((ret-add (stack-frame/return-address frame))
+ (object (compiled-entry/dbg-object ret-add)))
+ (cond ((not object)
+ default)
+ ((dbg-continuation? object)
+ (let ((block (dbg-continuation/block object)))
+ (let ((parent (dbg-block/parent block)))
+ (case (dbg-block/type parent)
+ ((STACK)
+ (make-stack-ccenv
+ parent
+ frame
+ (+ (dbg-continuation/offset object)
+ (vector-length (dbg-block/layout-vector block)))))
+ ((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 block" parent))))))
+ ((dbg-procedure? object)
+ (let ((block (dbg-procedure/block object)))
+ (case (dbg-block/type block)
+ ((STACK)
+ (make-stack-ccenv
+ block
+ frame
+ (if (compiled-closure? ret-add)
+ 0
+ 1)))
+ (else
+ (error "Illegal procedure block" block)))))
+ #|
+ ((dbg-expression? object)
+ ;; for now
+ default)
+ |#
+ (else
+ default))))
+
(define (compiled-procedure/environment entry)
(let ((procedure (compiled-entry/dbg-object entry)))
(if (not procedure)
projects / mit-scheme.git / commitdiff