From: Guillermo J. Rozas Date: Wed, 29 Mar 1989 02:45:50 +0000 (+0000) Subject: Add support for trap recovery: X-Git-Tag: 20090517-FFI~12211 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8264d010cdcd99f5423039fca756a23481e301e4;p=mit-scheme.git Add support for trap recovery: - New condition types for hardware traps have been added. - The stack parser knows how to parse (heuristically) the trap recovery information. - The debugger prints a description of the context of the trap. - hardware-trap-frame/print-registers and hardware-trap-frame/print-stack can be used on stack-frames of type hardware-trap to display more information. - The debugger's Y command (new) prints the stack frame structure corresponding to the current subproblem. --- diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm index 5fee4f91b..aa2665713 100644 --- a/v7/src/runtime/conpar.scm +++ b/v7/src/runtime/conpar.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.6 1989/01/07 00:24:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.7 1989/03/29 02:45:15 jinx Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -197,8 +197,7 @@ MIT in each case. |# (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)))) + (stack-frame-type/history-subproblem? type)) (history (parser-state/history state)) (previous-history-offset (parser-state/previous-history-offset state)) (previous-history-control-point @@ -307,7 +306,32 @@ MIT in each case. |# (if frame-size (1+ frame-size) (stack-address->index (element-stream/ref stream 1) offset))))) - ;;;; Parsers + (define (verify paranoia-index stream offset) + (or (zero? paranoia-index) + (stream-null? stream) + (let* ((type (return-address->stack-frame-type + (element-stream/head stream))) + (length + (let ((length (stack-frame-type/length type))) + (if (integer? length) + length + (length stream offset)))) + (ltail (stream-tail* stream length))) + (and ltail + (return-address? (element-stream/head ltail)) + (verify (-1+ paranoia-index) + ltail + (+ offset length)))))) + +(define (stream-tail* stream n) + (cond ((or (zero? n) (stream-null? stream)) + stream) + ((stream-pair? stream) + (stream-tail* (stream-cdr stream) (-1+ n))) + (else + (error "stream-tail*: not a proper stream" stream)))) + +;;;; Parsers (define (parser/standard-next type elements state) (make-frame type @@ -386,10 +410,13 @@ MIT in each case. |# (define-structure (stack-frame-type (constructor make-stack-frame-type - (code subproblem? length parser)) + (code subproblem? + history-subproblem? + length parser)) (conc-name stack-frame-type/)) (code false read-only true) (subproblem? false read-only true) + (history-subproblem? false read-only true) (properties (make-1d-table) read-only true) (length false read-only true) (parser false read-only true)) @@ -420,33 +447,50 @@ MIT in each case. |# (set! return-address/reenter-compiled-code (make-return-address (microcode-return 'REENTER-COMPILED-CODE))) (set! stack-frame-types (make-stack-frame-types)) + (set! stack-frame-type/hardware-trap + (vector-ref stack-frame-types (microcode-return 'HARDWARE-TRAP))) (set! stack-frame-type/compiled-return-address (make-stack-frame-type false true + false length/compiled-return-address parser/standard-next)) (set! stack-frame-type/return-to-interpreter (make-stack-frame-type false + false false 1 parser/standard-next)) + (set! word-size + (let ((initial (system-vector-length (make-bit-string 1 #f)))) + (let loop ((size 2)) + (if (= (system-vector-length (make-bit-string size #f)) + initial) + (loop (1+ size)) + (-1+ size))))) unspecific) (define stack-frame-types) (define stack-frame-type/compiled-return-address) (define stack-frame-type/return-to-interpreter) +(define stack-frame-type/hardware-trap) (define (make-stack-frame-types) (let ((types (make-vector (microcode-return/code-limit) false))) - (define (stack-frame-type name subproblem? length parser) + (define (stack-frame-type name subproblem? + history-subproblem? + length parser) (let ((code (microcode-return name))) (vector-set! types code - (make-stack-frame-type code subproblem? length parser)))) + (make-stack-frame-type code subproblem? + history-subproblem? + length parser)))) (define (standard-frame name length #!optional parser) (stack-frame-type name + false false length (if (default-object? parser) @@ -455,6 +499,7 @@ MIT in each case. |# (define (standard-subproblem name length) (stack-frame-type name + true true length parser/standard-next)) @@ -508,7 +553,7 @@ MIT in each case. |# (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) @@ -522,4 +567,156 @@ MIT in each case. |# (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 + (stack-frame-type 'HARDWARE-TRAP + true + false + length/hardware-trap + parser/standard-next) + + types)) + +;;;; Hardware trap parsing + +(define-integrable hardware-trap/frame-size 8) + +(define-integrable hardware-trap/signal-index 1) +(define-integrable hardware-trap/signal-name-index 2) +(define-integrable hardware-trap/stack-index 3) +(define-integrable hardware-trap/state-index 4) +(define-integrable hardware-trap/pc-info1-index 5) +(define-integrable hardware-trap/pc-info2-index 6) +(define-integrable hardware-trap/extra-info-index 7) + +(define (length/hardware-trap stream offset) + (let ((state (element-stream/ref stream hardware-trap/state-index)) + (stack-recovered? + (element-stream/ref stream hardware-trap/stack-index))) + (if (not stack-recovered?) + hardware-trap/frame-size + (let ((after-header (stream-tail stream hardware-trap/frame-size))) + (case state + ((1) ;primitive + (let* ((primitive + (element-stream/ref stream hardware-trap/pc-info1-index)) + (arity (primitive-procedure-arity primitive)) + (nargs + (if (negative? arity) + (element-stream/ref stream hardware-trap/pc-info2-index) + arity))) + (if (return-address? (element-stream/ref after-header nargs)) + (+ hardware-trap/frame-size nargs) + (- (heuristic (stream-tail after-header nargs) + (+ hardware-trap/frame-size nargs offset)) + offset)))) + ((0 2 3) ;unknown, cc, or probably cc + (- (heuristic after-header (+ hardware-trap/frame-size offset)) + offset)) + (else + (error "length/hardware-trap: Unknown state" state))))))) + +(define (heuristic stream offset) + (if (or (stream-null? stream) + (and (return-address? (element-stream/head stream)) + (verify 2 stream offset))) + offset + (heuristic (stream-cdr stream) (1+ offset)))) + +(define (guarantee-hardware-trap-frame frame) + (if (or (not (stack-frame? frame)) + (not (eq? (stack-frame/type frame) + stack-frame-type/hardware-trap))) + (error "guarantee-hardware-trap-frame: invalid" frame))) + +(define word-size) + +(define (print-register block index name) + (let ((value + (let ((bit-string (bit-string-allocate word-size))) + (read-bits! block (* word-size (1+ index)) bit-string) + (bit-string->unsigned-integer bit-string)))) + (newline) + (write-string " ") + (write-string name) + (write-string " = ") + (write-string (number->string value '(HEUR (RADIX X)))))) + +(define (hardware-trap-frame/print-registers frame) + (guarantee-hardware-trap-frame frame) + (let ((block (stack-frame/ref frame hardware-trap/extra-info-index))) + (if block + (let ((nregs (- (system-vector-length block) 2))) + (print-register block 0 "pc") + (print-register block 1 "sp") + (let loop ((i 0)) + (if (< i nregs) + (begin + (print-register block (+ 2 i) + (string-append "register " + (number->string i))) + (loop (1+ i))))))))) + +(define (hardware-trap-frame/print-stack frame) + (guarantee-hardware-trap-frame frame) + (let ((elements + (let ((elements (stack-frame/elements frame))) + (subvector->list elements + hardware-trap/frame-size + (vector-length elements))))) + (if (null? elements) + (begin + (newline) + (write-string ";; Empty stack")) + (begin + (newline) + (write-string ";; Bottom of the stack") + (for-each (lambda (element) + (newline) + (write-string " ") + (write element)) + (reverse elements)) + (newline) + (write-string ";; Top of the stack"))))) + +(define (hardware-trap-frame/describe frame long?) + (guarantee-hardware-trap-frame frame) + (let ((name (stack-frame/ref frame hardware-trap/signal-name-index)) + (state (stack-frame/ref frame hardware-trap/state-index))) + (if name + (begin + (write-string "Hardware trap ") + (write-string name)) + (write-string "User microcode reset")) + (if long? + (case state + ((0) ; unknown + (write-string " at an unknown location.")) + ((1) ; primitive + (write-string " within ") + (write (stack-frame/ref frame hardware-trap/pc-info1-index))) + ((2) ; compiled code + (write-string " at offset ") + (write-string + (number->string (stack-frame/ref frame + hardware-trap/pc-info2-index) + '(HEUR (RADIX X)))) (newline) + (write-string "within ") + (let ((block (stack-frame/ref frame hardware-trap/pc-info1-index))) + (write block) + (let loop ((info (compiled-code-block/debugging-info block))) + (cond ((null? info) + false) + ((string? info) + (begin + (write-string " (") + (write-string info) + (write-string ")"))) + ((not (pair? info)) + false) + ((string? (car info)) + (loop (car info))) + (else + (loop (cdr info))))))) + ((3) + (write-string " at an unknown compiled code location.")) + (else + (error "hardware-trap/describe: Unknown state" state)))))) \ No newline at end of file diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index db5b757a7..7609fd75d 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.10 1989/01/06 23:01:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.11 1989/03/29 02:45:22 jinx Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -84,6 +84,8 @@ MIT in each case. |# "Enter WHERE on the current environment") (#\X ,internal-command "Create a read eval print loop in the debugger environment") + (#\Y ,frame-command + "Display the current stack frame") (#\Z ,return-command "Return (continue with) an expression after evaluating it") ))) @@ -159,15 +161,22 @@ MIT in each case. |# (print-expression current-expression)) (begin (newline) - (write-string - (if (stack-frame/compiled-code? current-subproblem) - "Compiled code expression" - "Expression")) - (if (invalid-expression? current-expression) - (write-string " unknown") - (begin - (write-string " (from stack):") - (print-expression current-expression)))))) + (cond ((not (invalid-expression? current-expression)) + (write-string + (if (stack-frame/compiled-code? current-subproblem) + "Compiled code expression (from stack):" + "Expression (from stack):")) + (print-expression current-expression)) + ((or (not (debugging-info/undefined-expression? + current-expression)) + (not (debugging-info/noise current-expression))) + (write-string + (if (stack-frame/compiled-code? current-subproblem) + "Compiled code expression unknown" + "Expression unknown"))) + (else + (write-string + ((debugging-info/noise current-expression) true))))))) (define (stack-frame/compiled-code? frame) (compiled-return-address? (stack-frame/return-address frame))) @@ -210,14 +219,18 @@ MIT in each case. |# environment-arguments-truncation))))))))) (define (pretty-print-current-expression) - (cond ((debugging-info/undefined-expression? current-expression) - (newline) - (write-string ";undefined expression")) - ((debugging-info/compiled-code? current-expression) + (cond ((debugging-info/compiled-code? current-expression) (newline) (write-string ";compiled code")) + ((not (debugging-info/undefined-expression? current-expression)) + (print-expression current-expression)) + ((debugging-info/noise current-expression) + (newline) + (write-string ";") + (write-string ((debugging-info/noise current-expression) false))) (else - (print-expression current-expression)))) + (newline) + (write-string ";undefined expression")))) (define (pretty-print-environment-procedure) (with-current-environment @@ -294,13 +307,19 @@ MIT in each case. |# 20)) (write-string " ") (write-string - (cond ((debugging-info/undefined-expression? expression) - ";undefined expression") - ((debugging-info/compiled-code? expression) + (cond ((debugging-info/compiled-code? expression) ";compiled code") - (else + ((not (debugging-info/undefined-expression? expression)) (output-to-string 50 - (lambda () (write-sexp (unsyntax expression)))))))) + (lambda () (write-sexp (unsyntax expression))))) + ((debugging-info/noise current-expression) + (output-to-string + 50 + (lambda () + (write-string ((debugging-info/noise current-expression) + false))))) + (else + ";undefined expression")))) (define (write-sexp sexp) (fluid-let ((*unparse-primitives-by-name?* true)) @@ -505,7 +524,8 @@ MIT in each case. |# "Eval-in-env-->")) (define (eval-in-current-environment) - (with-current-environment debug/read-eval-print-1)) + (debug/read-eval-print-1 + (get-evaluation-environment interpreter-environment?))) (define (enter-where-command) (with-current-environment debug/where)) @@ -586,7 +606,14 @@ MIT in each case. |# (define (internal-command) (debug/read-eval-print (->environment '(runtime debugger)) "You are now in the debugger environment" - "Debugger-->")) + "Debugger-->")) +(define (frame-command) + (write-string "Stack frame ") + (write current-subproblem) + (write-string " :") + (newline) + (for-each pp (named-structure/description current-subproblem))) + ;;;; Reduction and subproblem motion low-level (define (set-current-subproblem! stack-frame previous-frames diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index e2ef83b5e..81f8fa25f 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.6 1989/02/28 16:49:52 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.7 1989/03/29 02:45:28 jinx Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -48,11 +48,20 @@ MIT in each case. |# condition-reporter/default))) (set-car! generalizations result) result))) + (set! condition-type:microcode-asynchronous + (make-condition-type '() "Microcode asynchronous")) + (set! condition-type:hardware-trap + (make-condition-type (list condition-type:microcode-asynchronous) + "Hardware trap")) + (set! condition-type:user-microcode-reset + (make-condition-type (list condition-type:microcode-asynchronous) + "User microcode reset")) (set! error-type:vanilla (make-condition-type (list condition-type:error) condition-reporter/default)) (set! hook/error-handler default/error-handler) (set! hook/error-decision default/error-decision) + (set! hook/hardware-trap recover/hardware-trap) (let ((fixed-objects (get-fixed-objects-vector))) (vector-set! fixed-objects (fixed-objects-vector-slot 'ERROR-PROCEDURE) @@ -72,6 +81,20 @@ MIT in each case. |# (lambda () (simple-error repl-environment message irritants)))) +(define (recover/hardware-trap name) + (call-with-current-continuation + (lambda (trap-continuation) + (signal-error + (make-condition + (if name + condition-type:hardware-trap + condition-type:user-microcode-reset) + (if name + (list (error-irritant/noise " ") + (error-irritant/noise name)) + '()) + trap-continuation))))) + ;;; (PROCEED) means retry error expression, (PROCEED value) means ;;; return VALUE as the value of the error subproblem. @@ -316,6 +339,9 @@ MIT in each case. |# (condition-type/error? object))) (define condition-type:error) +(define condition-type:microcode-asynchronous) +(define condition-type:hardware-trap) +(define condition-type:user-microcode-reset) ;;;; Condition Instances diff --git a/v7/src/runtime/framex.scm b/v7/src/runtime/framex.scm index 45adb8042..cea05e6ea 100644 --- a/v7/src/runtime/framex.scm +++ b/v7/src/runtime/framex.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.4 1989/01/06 21:00:05 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.5 1989/03/29 02:45:33 jinx Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,17 +37,16 @@ MIT in each case. |# (declare (usual-integrations)) -(define (stack-frame/debugging-info frame) - (let ((method - (1d-table/get (stack-frame-type/properties (stack-frame/type frame)) - method-tag - false))) - (if (not method) - (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)) - (method frame))) +(define (debugging-info/undefined-expression? expression) + (or (eq? expression undefined-expression) + (and (pair? expression) + (eq? (car expression) undefined-expression)))) + +(define-integrable (debugging-info/noise expression) + (cdr expression)) -(define-integrable (debugging-info/undefined-expression? expression) - (eq? expression undefined-expression)) +(define-integrable (make-debugging-info/noise noise) + (cons undefined-expression noise)) (define-integrable (debugging-info/undefined-environment? environment) (eq? environment undefined-environment)) @@ -55,6 +54,24 @@ MIT in each case. |# (define-integrable (debugging-info/compiled-code? expression) (eq? expression compiled-code)) +(define (stack-frame/debugging-info frame) + (let ((method + (1d-table/get (stack-frame-type/properties (stack-frame/type frame)) + method-tag + false))) + (if (not method) + ;; (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame) + (values (make-debugging-info/noise + (lambda (long?) + (with-output-to-string + (lambda () + (display "Unknown (methodless) ") + (write frame) + (if long? + (po frame)))))) + undefined-environment) + (method frame)))) + (define (make-evaluated-object object) (if (scode-constant? object) object @@ -160,6 +177,15 @@ MIT in each case. |# (cons (make-evaluated-object (stack-frame/ref frame index)) (loop (1+ index))) '())))) + +(define (method/hardware-trap frame) + (values (make-debugging-info/noise (hardware-trap-noise frame)) + undefined-environment)) + +(define ((hardware-trap-noise frame) long?) + (with-output-to-string + (lambda () + (hardware-trap-frame/describe frame long?)))) (define (initialize-package!) (for-each (lambda (entry) @@ -253,7 +279,10 @@ MIT in each case. |# (,method/compiler-lookup-apply-trap-restart COMPILER-LOOKUP-APPLY-TRAP-RESTART - COMPILER-OPERATOR-LOOKUP-TRAP-RESTART))) + COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) + + (,method/hardware-trap + HARDWARE-TRAP))) (1d-table/put! (stack-frame-type/properties stack-frame-type/compiled-return-address) method-tag diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm index 41cb5b98f..d965053b0 100644 --- a/v7/src/runtime/gc.scm +++ b/v7/src/runtime/gc.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.1 1988/06/13 11:45:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.2 1989/03/29 02:45:39 jinx Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -64,8 +64,9 @@ MIT in each case. |# (set-interrupt-enables! interrupt-enables)) (define (condition-handler/hardware-trap escape-code) - escape-code - (hook/hardware-trap)) + ((ucode-primitive set-trap-state!) + ((ucode-primitive set-trap-state!) 2)) ; Ask. + (hook/hardware-trap escape-code)) (define hook/gc-flip) (define hook/purify) @@ -117,7 +118,8 @@ MIT in each case. |# (define (default/stack-overflow) (abort "maximum recursion depth exceeded")) -(define (default/hardware-trap) +(define (default/hardware-trap escape-code) + escape-code (abort "the hardware trapped")) (define pure-space-queue) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 4a2a2e538..368fdd130 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.31 1989/03/14 09:33:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.32 1989/03/29 02:45:43 jinx Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -311,7 +311,11 @@ MIT in each case. |# stack-frame/skip-non-subproblems stack-frame/subproblem? stack-frame/type - stack-frame?) + stack-frame? + hardware-trap-frame/describe + hardware-trap-frame/print-stack + hardware-trap-frame/print-registers + ) (initialization (initialize-package!))) (define-package (runtime control-point) @@ -379,6 +383,7 @@ MIT in each case. |# debugging-info/evaluated-object? debugging-info/undefined-environment? debugging-info/undefined-expression? + debugging-info/noise stack-frame/debugging-info) (initialization (initialize-package!))) @@ -537,6 +542,8 @@ MIT in each case. |# (export (runtime emacs-interface) hook/gc-finish hook/gc-start) + (export (runtime error-handler) + hook/hardware-trap) (initialization (initialize-package!))) (define-package (runtime gc-daemons) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 731fa1a3c..c27fae77a 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.38 1989/03/14 02:18:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.39 1989/03/29 02:45:50 jinx Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 38)) + (add-identification! "Runtime" 14 39)) (define microcode-system) diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm index 3fe026f8a..1ad21b208 100644 --- a/v8/src/runtime/conpar.scm +++ b/v8/src/runtime/conpar.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.6 1989/01/07 00:24:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.7 1989/03/29 02:45:15 jinx Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -197,8 +197,7 @@ MIT in each case. |# (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)))) + (stack-frame-type/history-subproblem? type)) (history (parser-state/history state)) (previous-history-offset (parser-state/previous-history-offset state)) (previous-history-control-point @@ -307,7 +306,32 @@ MIT in each case. |# (if frame-size (1+ frame-size) (stack-address->index (element-stream/ref stream 1) offset))))) - ;;;; Parsers + (define (verify paranoia-index stream offset) + (or (zero? paranoia-index) + (stream-null? stream) + (let* ((type (return-address->stack-frame-type + (element-stream/head stream))) + (length + (let ((length (stack-frame-type/length type))) + (if (integer? length) + length + (length stream offset)))) + (ltail (stream-tail* stream length))) + (and ltail + (return-address? (element-stream/head ltail)) + (verify (-1+ paranoia-index) + ltail + (+ offset length)))))) + +(define (stream-tail* stream n) + (cond ((or (zero? n) (stream-null? stream)) + stream) + ((stream-pair? stream) + (stream-tail* (stream-cdr stream) (-1+ n))) + (else + (error "stream-tail*: not a proper stream" stream)))) + +;;;; Parsers (define (parser/standard-next type elements state) (make-frame type @@ -386,10 +410,13 @@ MIT in each case. |# (define-structure (stack-frame-type (constructor make-stack-frame-type - (code subproblem? length parser)) + (code subproblem? + history-subproblem? + length parser)) (conc-name stack-frame-type/)) (code false read-only true) (subproblem? false read-only true) + (history-subproblem? false read-only true) (properties (make-1d-table) read-only true) (length false read-only true) (parser false read-only true)) @@ -420,33 +447,50 @@ MIT in each case. |# (set! return-address/reenter-compiled-code (make-return-address (microcode-return 'REENTER-COMPILED-CODE))) (set! stack-frame-types (make-stack-frame-types)) + (set! stack-frame-type/hardware-trap + (vector-ref stack-frame-types (microcode-return 'HARDWARE-TRAP))) (set! stack-frame-type/compiled-return-address (make-stack-frame-type false true + false length/compiled-return-address parser/standard-next)) (set! stack-frame-type/return-to-interpreter (make-stack-frame-type false + false false 1 parser/standard-next)) + (set! word-size + (let ((initial (system-vector-length (make-bit-string 1 #f)))) + (let loop ((size 2)) + (if (= (system-vector-length (make-bit-string size #f)) + initial) + (loop (1+ size)) + (-1+ size))))) unspecific) (define stack-frame-types) (define stack-frame-type/compiled-return-address) (define stack-frame-type/return-to-interpreter) +(define stack-frame-type/hardware-trap) (define (make-stack-frame-types) (let ((types (make-vector (microcode-return/code-limit) false))) - (define (stack-frame-type name subproblem? length parser) + (define (stack-frame-type name subproblem? + history-subproblem? + length parser) (let ((code (microcode-return name))) (vector-set! types code - (make-stack-frame-type code subproblem? length parser)))) + (make-stack-frame-type code subproblem? + history-subproblem? + length parser)))) (define (standard-frame name length #!optional parser) (stack-frame-type name + false false length (if (default-object? parser) @@ -455,6 +499,7 @@ MIT in each case. |# (define (standard-subproblem name length) (stack-frame-type name + true true length parser/standard-next)) @@ -508,7 +553,7 @@ MIT in each case. |# (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) @@ -522,4 +567,156 @@ MIT in each case. |# (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 + (stack-frame-type 'HARDWARE-TRAP + true + false + length/hardware-trap + parser/standard-next) + + types)) + +;;;; Hardware trap parsing + +(define-integrable hardware-trap/frame-size 8) + +(define-integrable hardware-trap/signal-index 1) +(define-integrable hardware-trap/signal-name-index 2) +(define-integrable hardware-trap/stack-index 3) +(define-integrable hardware-trap/state-index 4) +(define-integrable hardware-trap/pc-info1-index 5) +(define-integrable hardware-trap/pc-info2-index 6) +(define-integrable hardware-trap/extra-info-index 7) + +(define (length/hardware-trap stream offset) + (let ((state (element-stream/ref stream hardware-trap/state-index)) + (stack-recovered? + (element-stream/ref stream hardware-trap/stack-index))) + (if (not stack-recovered?) + hardware-trap/frame-size + (let ((after-header (stream-tail stream hardware-trap/frame-size))) + (case state + ((1) ;primitive + (let* ((primitive + (element-stream/ref stream hardware-trap/pc-info1-index)) + (arity (primitive-procedure-arity primitive)) + (nargs + (if (negative? arity) + (element-stream/ref stream hardware-trap/pc-info2-index) + arity))) + (if (return-address? (element-stream/ref after-header nargs)) + (+ hardware-trap/frame-size nargs) + (- (heuristic (stream-tail after-header nargs) + (+ hardware-trap/frame-size nargs offset)) + offset)))) + ((0 2 3) ;unknown, cc, or probably cc + (- (heuristic after-header (+ hardware-trap/frame-size offset)) + offset)) + (else + (error "length/hardware-trap: Unknown state" state))))))) + +(define (heuristic stream offset) + (if (or (stream-null? stream) + (and (return-address? (element-stream/head stream)) + (verify 2 stream offset))) + offset + (heuristic (stream-cdr stream) (1+ offset)))) + +(define (guarantee-hardware-trap-frame frame) + (if (or (not (stack-frame? frame)) + (not (eq? (stack-frame/type frame) + stack-frame-type/hardware-trap))) + (error "guarantee-hardware-trap-frame: invalid" frame))) + +(define word-size) + +(define (print-register block index name) + (let ((value + (let ((bit-string (bit-string-allocate word-size))) + (read-bits! block (* word-size (1+ index)) bit-string) + (bit-string->unsigned-integer bit-string)))) + (newline) + (write-string " ") + (write-string name) + (write-string " = ") + (write-string (number->string value '(HEUR (RADIX X)))))) + +(define (hardware-trap-frame/print-registers frame) + (guarantee-hardware-trap-frame frame) + (let ((block (stack-frame/ref frame hardware-trap/extra-info-index))) + (if block + (let ((nregs (- (system-vector-length block) 2))) + (print-register block 0 "pc") + (print-register block 1 "sp") + (let loop ((i 0)) + (if (< i nregs) + (begin + (print-register block (+ 2 i) + (string-append "register " + (number->string i))) + (loop (1+ i))))))))) + +(define (hardware-trap-frame/print-stack frame) + (guarantee-hardware-trap-frame frame) + (let ((elements + (let ((elements (stack-frame/elements frame))) + (subvector->list elements + hardware-trap/frame-size + (vector-length elements))))) + (if (null? elements) + (begin + (newline) + (write-string ";; Empty stack")) + (begin + (newline) + (write-string ";; Bottom of the stack") + (for-each (lambda (element) + (newline) + (write-string " ") + (write element)) + (reverse elements)) + (newline) + (write-string ";; Top of the stack"))))) + +(define (hardware-trap-frame/describe frame long?) + (guarantee-hardware-trap-frame frame) + (let ((name (stack-frame/ref frame hardware-trap/signal-name-index)) + (state (stack-frame/ref frame hardware-trap/state-index))) + (if name + (begin + (write-string "Hardware trap ") + (write-string name)) + (write-string "User microcode reset")) + (if long? + (case state + ((0) ; unknown + (write-string " at an unknown location.")) + ((1) ; primitive + (write-string " within ") + (write (stack-frame/ref frame hardware-trap/pc-info1-index))) + ((2) ; compiled code + (write-string " at offset ") + (write-string + (number->string (stack-frame/ref frame + hardware-trap/pc-info2-index) + '(HEUR (RADIX X)))) (newline) + (write-string "within ") + (let ((block (stack-frame/ref frame hardware-trap/pc-info1-index))) + (write block) + (let loop ((info (compiled-code-block/debugging-info block))) + (cond ((null? info) + false) + ((string? info) + (begin + (write-string " (") + (write-string info) + (write-string ")"))) + ((not (pair? info)) + false) + ((string? (car info)) + (loop (car info))) + (else + (loop (cdr info))))))) + ((3) + (write-string " at an unknown compiled code location.")) + (else + (error "hardware-trap/describe: Unknown state" state)))))) \ No newline at end of file diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm index f9c97fece..12e61e4d8 100644 --- a/v8/src/runtime/framex.scm +++ b/v8/src/runtime/framex.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.4 1989/01/06 21:00:05 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.5 1989/03/29 02:45:33 jinx Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,17 +37,16 @@ MIT in each case. |# (declare (usual-integrations)) -(define (stack-frame/debugging-info frame) - (let ((method - (1d-table/get (stack-frame-type/properties (stack-frame/type frame)) - method-tag - false))) - (if (not method) - (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)) - (method frame))) +(define (debugging-info/undefined-expression? expression) + (or (eq? expression undefined-expression) + (and (pair? expression) + (eq? (car expression) undefined-expression)))) + +(define-integrable (debugging-info/noise expression) + (cdr expression)) -(define-integrable (debugging-info/undefined-expression? expression) - (eq? expression undefined-expression)) +(define-integrable (make-debugging-info/noise noise) + (cons undefined-expression noise)) (define-integrable (debugging-info/undefined-environment? environment) (eq? environment undefined-environment)) @@ -55,6 +54,24 @@ MIT in each case. |# (define-integrable (debugging-info/compiled-code? expression) (eq? expression compiled-code)) +(define (stack-frame/debugging-info frame) + (let ((method + (1d-table/get (stack-frame-type/properties (stack-frame/type frame)) + method-tag + false))) + (if (not method) + ;; (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame) + (values (make-debugging-info/noise + (lambda (long?) + (with-output-to-string + (lambda () + (display "Unknown (methodless) ") + (write frame) + (if long? + (po frame)))))) + undefined-environment) + (method frame)))) + (define (make-evaluated-object object) (if (scode-constant? object) object @@ -160,6 +177,15 @@ MIT in each case. |# (cons (make-evaluated-object (stack-frame/ref frame index)) (loop (1+ index))) '())))) + +(define (method/hardware-trap frame) + (values (make-debugging-info/noise (hardware-trap-noise frame)) + undefined-environment)) + +(define ((hardware-trap-noise frame) long?) + (with-output-to-string + (lambda () + (hardware-trap-frame/describe frame long?)))) (define (initialize-package!) (for-each (lambda (entry) @@ -253,7 +279,10 @@ MIT in each case. |# (,method/compiler-lookup-apply-trap-restart COMPILER-LOOKUP-APPLY-TRAP-RESTART - COMPILER-OPERATOR-LOOKUP-TRAP-RESTART))) + COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) + + (,method/hardware-trap + HARDWARE-TRAP))) (1d-table/put! (stack-frame-type/properties stack-frame-type/compiled-return-address) method-tag diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index e32318013..3c4de129a 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.31 1989/03/14 09:33:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.32 1989/03/29 02:45:43 jinx Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -311,7 +311,11 @@ MIT in each case. |# stack-frame/skip-non-subproblems stack-frame/subproblem? stack-frame/type - stack-frame?) + stack-frame? + hardware-trap-frame/describe + hardware-trap-frame/print-stack + hardware-trap-frame/print-registers + ) (initialization (initialize-package!))) (define-package (runtime control-point) @@ -379,6 +383,7 @@ MIT in each case. |# debugging-info/evaluated-object? debugging-info/undefined-environment? debugging-info/undefined-expression? + debugging-info/noise stack-frame/debugging-info) (initialization (initialize-package!))) @@ -537,6 +542,8 @@ MIT in each case. |# (export (runtime emacs-interface) hook/gc-finish hook/gc-start) + (export (runtime error-handler) + hook/hardware-trap) (initialization (initialize-package!))) (define-package (runtime gc-daemons)