- 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.
#| -*-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
(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
(if frame-size
(1+ frame-size)
(stack-address->index (element-stream/ref stream 1) offset)))))
-\f;;;; Parsers
+\f(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))))
+\f
+;;;; Parsers
(define (parser/standard-next type elements state)
(make-frame type
(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))
(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)
(define (standard-subproblem name length)
(stack-frame-type name
+ true
true
length
parser/standard-next))
(standard-subproblem 'COMPILER-DEFINITION-RESTART 5)
(standard-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 5)
(standard-subproblem 'MOVE-TO-ADJACENT-POINT 6)
-
+\f
(standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value)
(standard-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive)
(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))
+\f
+;;;; 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)))
+\f
+(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")))))
+\f
+(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
#| -*-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
"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")
)))
(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)))
environment-arguments-truncation)))))))))
\f
(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
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))
"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))
(define (internal-command)
(debug/read-eval-print (->environment '(runtime debugger))
"You are now in the debugger environment"
- "Debugger-->"))\f
+ "Debugger-->"))
+(define (frame-command)
+ (write-string "Stack frame ")
+ (write current-subproblem)
+ (write-string " :")
+ (newline)
+ (for-each pp (named-structure/description current-subproblem)))
+\f
;;;; Reduction and subproblem motion low-level
(define (set-current-subproblem! stack-frame previous-frames
#| -*-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
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)
(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.
(condition-type/error? object)))
(define condition-type:error)
+(define condition-type:microcode-asynchronous)
+(define condition-type:hardware-trap)
+(define condition-type:user-microcode-reset)
\f
;;;; Condition Instances
#| -*-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
(declare (usual-integrations))
\f
-(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))
(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
(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?))))
\f
(define (initialize-package!)
(for-each (lambda (entry)
(,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
#| -*-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
(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)
(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"))
\f
(define pure-space-queue)
#| -*-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
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)
debugging-info/evaluated-object?
debugging-info/undefined-environment?
debugging-info/undefined-expression?
+ debugging-info/noise
stack-frame/debugging-info)
(initialization (initialize-package!)))
(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)
#| -*-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
'()))
(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)
#| -*-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
(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
(if frame-size
(1+ frame-size)
(stack-address->index (element-stream/ref stream 1) offset)))))
-\f;;;; Parsers
+\f(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))))
+\f
+;;;; Parsers
(define (parser/standard-next type elements state)
(make-frame type
(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))
(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)
(define (standard-subproblem name length)
(stack-frame-type name
+ true
true
length
parser/standard-next))
(standard-subproblem 'COMPILER-DEFINITION-RESTART 5)
(standard-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 5)
(standard-subproblem 'MOVE-TO-ADJACENT-POINT 6)
-
+\f
(standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value)
(standard-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive)
(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))
+\f
+;;;; 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)))
+\f
+(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")))))
+\f
+(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
#| -*-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
(declare (usual-integrations))
\f
-(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))
(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
(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?))))
\f
(define (initialize-package!)
(for-each (lambda (entry)
(,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
#| -*-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
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)
debugging-info/evaluated-object?
debugging-info/undefined-environment?
debugging-info/undefined-expression?
+ debugging-info/noise
stack-frame/debugging-info)
(initialization (initialize-package!)))
(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)
projects / mit-scheme.git / commitdiff