From: Stephen Adams <edu/mit/csail/zurich/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)