From: Guillermo J. Rozas Date: Tue, 21 Aug 1990 04:19:12 +0000 (+0000) Subject: Modify the stack parser and environment utilities to handle interrupt X-Git-Tag: 20090517-FFI~11233 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=283d1fd25040e07d716bdbb4788c5a100b5a1d4d;p=mit-scheme.git Modify the stack parser and environment utilities to handle interrupt frames from compiled code in which the return address is a procedure. --- diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm index 7c011c7b6..6f811794e 100644 --- a/v7/src/runtime/conpar.scm +++ b/v7/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.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 @@ -140,7 +140,8 @@ MIT in each case. |# (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) @@ -159,14 +160,16 @@ MIT in each case. |# (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) @@ -175,12 +178,13 @@ MIT in each case. |# ((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))))) -(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 @@ -195,7 +199,8 @@ MIT in each case. |# 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? @@ -227,7 +232,8 @@ MIT in each case. |# 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)) @@ -312,11 +318,16 @@ MIT in each case. |# (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) @@ -325,10 +336,9 @@ MIT in each case. |# (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) @@ -366,7 +376,8 @@ MIT in each case. |# 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))) (define (parser/restore-dynamic-state type elements state) (make-restore-frame type elements state @@ -427,12 +438,21 @@ MIT in each case. |# (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))) @@ -444,6 +464,10 @@ MIT in each case. |# 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)))) @@ -467,6 +491,19 @@ MIT in each case. |# 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)) @@ -480,6 +517,8 @@ MIT in each case. |# (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))) @@ -488,11 +527,11 @@ MIT in each case. |# 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 @@ -564,7 +603,13 @@ MIT in each case. |# (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) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 65ce1ab70..9df335c94 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.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 @@ -559,11 +559,14 @@ MIT in each case. |# (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 () diff --git a/v7/src/runtime/framex.scm b/v7/src/runtime/framex.scm index ef7e3af24..7c5449668 100644 --- a/v7/src/runtime/framex.scm +++ b/v7/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.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 @@ -108,26 +108,36 @@ MIT in each case. |# (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) @@ -289,7 +299,13 @@ MIT in each case. |# (,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 diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index af89424f8..131a8da40 100644 --- a/v7/src/runtime/infutl.scm +++ b/v7/src/runtime/infutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.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 @@ -136,10 +136,12 @@ MIT in each case. |# (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 diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index d531b339b..f7bf69949 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.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 @@ -245,8 +245,11 @@ MIT in each case. |# 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 @@ -258,7 +261,12 @@ MIT in each case. |# 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) @@ -330,7 +338,11 @@ MIT in each case. |# 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") diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm index 30ff92e77..0c7021a17 100644 --- a/v7/src/runtime/udata.scm +++ b/v7/src/runtime/udata.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.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 @@ -124,10 +124,25 @@ MIT in each case. |# (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)))) diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index b78d354af..0eadd99ca 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.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 @@ -279,26 +279,47 @@ MIT in each case. |# (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) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 2cc2afa41..b788b150d 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.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 @@ -45,7 +45,8 @@ MIT in each case. |# '())) (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!) diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm index fbc7d19d4..700a2380e 100644 --- a/v8/src/runtime/conpar.scm +++ b/v8/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.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 @@ -140,7 +140,8 @@ MIT in each case. |# (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) @@ -159,14 +160,16 @@ MIT in each case. |# (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) @@ -175,12 +178,13 @@ MIT in each case. |# ((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))))) -(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 @@ -195,7 +199,8 @@ MIT in each case. |# 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? @@ -227,7 +232,8 @@ MIT in each case. |# 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)) @@ -312,11 +318,16 @@ MIT in each case. |# (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) @@ -325,10 +336,9 @@ MIT in each case. |# (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) @@ -366,7 +376,8 @@ MIT in each case. |# 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))) (define (parser/restore-dynamic-state type elements state) (make-restore-frame type elements state @@ -427,12 +438,21 @@ MIT in each case. |# (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))) @@ -444,6 +464,10 @@ MIT in each case. |# 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)))) @@ -467,6 +491,19 @@ MIT in each case. |# 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)) @@ -480,6 +517,8 @@ MIT in each case. |# (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))) @@ -488,11 +527,11 @@ MIT in each case. |# 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 @@ -564,7 +603,13 @@ MIT in each case. |# (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) diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm index 94bf78c98..8ce3c1221 100644 --- a/v8/src/runtime/framex.scm +++ b/v8/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.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 @@ -108,26 +108,36 @@ MIT in each case. |# (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) @@ -289,7 +299,13 @@ MIT in each case. |# (,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 diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index 24826ac14..c57a73ed3 100644 --- a/v8/src/runtime/infutl.scm +++ b/v8/src/runtime/infutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.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 @@ -136,10 +136,12 @@ MIT in each case. |# (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 diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 1b67bebfd..2f5d57c63 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.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 @@ -245,8 +245,11 @@ MIT in each case. |# 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 @@ -258,7 +261,12 @@ MIT in each case. |# 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) @@ -330,7 +338,11 @@ MIT in each case. |# 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") diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index 9717e4138..98dfcc165 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.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 @@ -279,26 +279,47 @@ MIT in each case. |# (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)