From: Stephen Adams Date: Fri, 26 Jul 1996 00:36:11 +0000 (+0000) Subject: Added new stack frame type for preservation frames (restore-regs). X-Git-Tag: 20090517-FFI~5429 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9c1501c323df4e43d0a1e3e72611239257f86b37;p=mit-scheme.git Added new stack frame type for preservation frames (restore-regs). Added a debugging-info method. Changed the illegal-arg error handler for primitive procedures to avoid using retry restarts when the primitive signalled a type or range error when called from compiled code. This is necessary because the compiler assumes that if it calls a primitive just to raise an error then teh primitive will not return. This assumption allows type inference to eliminate furthur checks. In order to stop the debugger returning a value, the primitive should be called `indirectly' via another compiler procedure which refuses to return. I.e instead of compiling the error CAR operation as INVOKE:PRIMITIVE (#[primitive-procedure car] x) call it like this: (signal-primitive-error '#[primitive-procedure car] x) where SIGNAL-PRIMITIVE-ERROR is compiled like this: (define (signal-primitive-error primitive . arguments) (apply primitive arguments) (error "...")) --- diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index 745b49e46..8fa186360 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: uerror.scm,v 14.42 1994/12/19 21:07:34 cph Exp $ +$Id: uerror.scm,v 14.43 1996/07/26 00:34:57 adams Exp $ Copyright (c) 1988-94 Massachusetts Institute of Technology @@ -122,7 +122,7 @@ MIT in each case. |# (define (variable/use-value continuation environment name thunk) (let ((continuation (continuation/next-continuation continuation))) - (if continuation + (if (continuation-restartable? continuation) (with-restart 'USE-VALUE (lambda (port) (write-string "Specify a value to use instead of " port) @@ -140,7 +140,7 @@ MIT in each case. |# (define (inapplicable-object/use-value continuation operands thunk) (let ((continuation (continuation/next-continuation continuation))) - (if continuation + (if (continuation-restartable? continuation) (with-restart 'USE-VALUE "Specify a procedure to use in its place." (lambda (operator) (within-continuation continuation @@ -159,8 +159,9 @@ MIT in each case. |# (signal continuation (list-ref operands index) operator index)))))) (define (illegal-argument/use-value continuation operator operands index thunk) - (let ((continuation (continuation/next-continuation continuation))) - (if continuation + (let ((continuation + (continuation/next-continuation/no-compiled-code continuation))) + (if (continuation-restartable? continuation) (with-restart 'USE-VALUE "Specify an argument to use in its place." (lambda (operand) (within-continuation continuation @@ -187,7 +188,7 @@ MIT in each case. |# (define (file-operation/use-value continuation operator operands index verb noun thunk) (let ((continuation (continuation/next-continuation continuation))) - (if continuation + (if (continuation-restartable? continuation) (with-restart 'USE-VALUE (string-append "Try to " verb " a different " noun ".") (lambda (operand) @@ -206,7 +207,7 @@ MIT in each case. |# (define (file-operation/retry continuation operator operands verb noun thunk) (let ((continuation (continuation/next-continuation continuation))) - (if continuation + (if (continuation-restartable? continuation) (with-restart 'RETRY (string-append "Try to " verb " the same " noun " again.") (lambda () @@ -232,6 +233,29 @@ MIT in each case. |# (and next-subproblem (stack-frame->continuation next-subproblem)))))) + +;; With the 8.0 compiler, we do not want to restart a primitive that +;; signalled a bad argument type or range. This allows the compiler +;; to generate better code. We return #F if the continuation is an +;; apply frame of a primitive called from compiled code: + +(define (continuation/next-continuation/no-compiled-code continuation) + (let ((first-subproblem (continuation/first-subproblem continuation))) + (and first-subproblem + (let ((next-subproblem (stack-frame/next first-subproblem))) + (and next-subproblem + (if (and (apply-frame? first-subproblem) + (primitive-procedure? + (apply-frame/operator first-subproblem)) + (let ((further-subproblem + (stack-frame/next next-subproblem))) + (stack-frame/compiled-code? further-subproblem))) + #F + (stack-frame->continuation next-subproblem))))))) + +(define (continuation-restartable? continuation) + continuation) + (define-integrable (frame/type frame) (microcode-return/code->name (stack-frame/return-code frame))) diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm index 8a452b94c..bdc97c9bb 100644 --- a/v8/src/runtime/conpar.scm +++ b/v8/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: conpar.scm,v 14.36 1995/07/27 20:37:03 adams Exp $ +$Id: conpar.scm,v 14.37 1996/07/26 00:34:49 adams Exp $ Copyright (c) 1988-95 Massachusetts Institute of Technology @@ -371,6 +371,12 @@ MIT in each case. |# (define-integrable code/apply-compiled 6) (define-integrable code/continue-linking 7) +(define (parser/restore-regs type elements state) + (let ((code (vector-ref elements 1))) + (if (not (and (fix:fixnum? code) (fix:= code code/restore-regs))) + (error "Unknown special compiled frame" code)) + (parse/standard-next type elements state false false))) + (define (parser/special-compiled type elements state) (let ((code (vector-ref elements 1))) (cond ((fix:= code code/special-compiled/internal-apply) @@ -613,6 +619,20 @@ MIT in each case. |# (1+ frame-size) (stack-address->index (element-stream/ref stream 1) offset))))) +(define (length/restore-regs stream offset) + ;; return address is reflect-to-interface + offset + (let ((code (element-stream/ref stream 1))) + (if (and (fix:fixnum? code) + (fix:= code code/restore-regs)) + (let ((guess (fix:+ 3 (object-datum (element-stream/ref stream 2))))) + (let loop ((guess* guess)) + (if (compiled-return-address? (element-stream/ref stream guess*)) + (+ guess* 1) + (loop (+ guess 1))))) + (error "length/resyspecial-compiled: Unknown code" code)))) + + (define (length/special-compiled stream offset) ;; return address is reflect-to-interface offset @@ -640,11 +660,7 @@ MIT in each case. |# ((fix:= code code/interrupt-restart) (default)) ((fix:= code code/restore-regs) - (let ((guess (fix:+ 3 (object-datum (element-stream/ref stream 2))))) - (let loop ((guess* guess)) - (if (compiled-return-address? (element-stream/ref stream guess*)) - (+ guess* 1) - (loop (+ guess 1)))))) + (default)) ((fix:= code code/apply-compiled) ;; Stream[2] is code entry point, [3] is frame size (+ 3 (object-datum (element-stream/ref stream 3)))) @@ -779,6 +795,8 @@ MIT in each case. |# ((compiled-continuation/reflect-to-interface? return-address) (cond ((= (element-stream/ref stream 1) code/interrupt-restart) (interrupt-frame)) + ((= (element-stream/ref stream 1) code/restore-regs) + stack-frame-type/restore-regs) (else stack-frame-type/special-compiled))) (else @@ -806,6 +824,11 @@ MIT in each case. |# 1 parser/standard stream/standard)) + (set! stack-frame-type/restore-regs + (make-stack-frame-type false true false + length/restore-regs + parser/restore-regs + stream/standard)) (set! stack-frame-type/special-compiled (make-stack-frame-type false true false length/special-compiled @@ -838,6 +861,7 @@ MIT in each case. |# (define stack-frame-types) (define stack-frame-type/compiled-return-address) (define stack-frame-type/return-to-interpreter) +(define stack-frame-type/restore-regs) (define stack-frame-type/special-compiled) (define stack-frame-type/hardware-trap) (define stack-frame-type/stack-marker) diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm index 0fd50afce..8c8eb3729 100644 --- a/v8/src/runtime/framex.scm +++ b/v8/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: framex.scm,v 14.19 1995/07/27 20:42:20 adams Exp $ +$Id: framex.scm,v 14.20 1996/07/26 00:34:27 adams Exp $ Copyright (c) 1988-1995 Massachusetts Institute of Technology @@ -392,6 +392,9 @@ MIT in each case. |# (set-stack-frame-type/debugging-info-method! stack-frame-type/interrupt-compiled-return-address method) + (set-stack-frame-type/debugging-info-method! + stack-frame-type/restore-regs + method) ) ;;(set-stack-frame-type/debugging-info-method! diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 93c2bd1fa..9e451a284 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.273 1996/07/12 18:03:45 adams Exp $ +$Id: runtime.pkg,v 14.274 1996/07/26 00:36:11 adams Exp $ Copyright (c) 1988-96 Massachusetts Institute of Technology @@ -349,7 +349,8 @@ MIT in each case. |# (export (runtime debugging-info) stack-frame-type/interrupt-compiled-procedure stack-frame-type/interrupt-compiled-expression - stack-frame-type/interrupt-compiled-return-address) + stack-frame-type/interrupt-compiled-return-address + stack-frame-type/restore-regs) (initialization (initialize-package!))) (define-package (runtime control-point)