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 "..."))
#| -*-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
(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)
(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
(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
(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)
(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 ()
(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)))
#| -*-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
(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)
(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
((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))))
((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
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
(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)
#| -*-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
(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!
#| -*-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
(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)
projects / mit-scheme.git / commitdiff