X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=232f1a6e21a1d257b2d166f5da788acfc317d73e;hb=de0a47a2f2b165f34177669bd9499135847b4897;hp=5bb783fb20a3eadf49d130c9e6f6e6c8b3f8546b;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 5bb783f..232f1a6 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -260,12 +260,7 @@ :format-arguments (list key-name))) (deferr invalid-array-index-error (array bound index) - (error 'simple-type-error - :format-control - "invalid array index ~W for ~S (should be nonnegative and <~W)" - :format-arguments (list index array bound) - :datum index - :expected-type `(integer 0 (,bound)))) + (invalid-array-index-error array bound index)) (deferr object-not-simple-array-error (object) (error 'type-error @@ -282,6 +277,15 @@ :datum object :expected-type '(unsigned-byte 32))) +(deferr tls-exhausted-error () + ;; There is nothing we can do about it. A number of entries in the + ;; tls could be reserved and made available for recovery but since + ;; tls indices are never reused it would be kind of silly and + ;; without it signalling an error is more than likely to end in a + ;; recursive error. + (%primitive print "Thread local storage exhausted.") + (sb!impl::%halt)) + (macrolet ((define-simple-array-internal-errors () `(progn @@ -363,8 +367,8 @@ (values "" nil))))) -(defun find-interrupted-name () - (/show0 "entering FIND-INTERRUPTED-NAME") +(defun find-interrupted-name-and-frame () + (/show0 "entering FIND-INTERRUPTED-NAME-AND-FRAME") (if *finding-name* (values "" nil) (handler-case @@ -390,6 +394,7 @@ (values "" nil))))) + ;;;; INTERNAL-ERROR signal handler (defun internal-error (context continuable) @@ -400,7 +405,7 @@ (infinite-error-protect (/show0 "about to bind ALIEN-CONTEXT") (let ((alien-context (locally - (declare (optimize (inhibit-warnings 3))) + (declare (optimize (inhibit-warnings 3))) (sb!alien:sap-alien context (* os-context-t))))) (/show0 "about to bind ERROR-NUMBER and ARGUMENTS") (multiple-value-bind (error-number arguments) @@ -417,35 +422,44 @@ (%primitive print "can't recover from error in cold init, halting") (%primitive sb!c:halt)) - (multiple-value-bind (name sb!debug:*stack-top-hint*) - (find-interrupted-name) - (/show0 "back from FIND-INTERRUPTED-NAME") - (let ((fp (int-sap (sb!vm:context-register alien-context - sb!vm::cfp-offset))) - (handler (and (< -1 error-number (length *internal-errors*)) - (svref *internal-errors* error-number)))) - (cond ((null handler) - (error 'simple-error - :format-control - "unknown internal error, ~D, args=~S" - :format-arguments - (list error-number - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - fp sc-offset alien-context)) - arguments)))) - ((not (functionp handler)) - (error 'simple-error - :format-control "internal error ~D: ~A; args=~S" - :format-arguments - (list error-number - handler - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - fp sc-offset alien-context)) - arguments)))) - (t - (funcall handler name fp alien-context arguments))))))))) + (with-interrupt-bindings + (multiple-value-bind (name sb!debug:*stack-top-hint*) + (find-interrupted-name-and-frame) + (/show0 "back from FIND-INTERRUPTED-NAME") + ;; Unblock trap signal here, we unwound the stack and can't return. + ;; FIXME: Should we not reset the _entire_ mask, but just + ;; restore it to the state before we got the condition? + ;; FIXME 2: Signals are currently unblocked in + ;; interrupt.c:internal_error before we do stack unwinding, can this + ;; introduce a race condition? + #!+(and linux mips) + (sb!unix::reset-signal-mask) + (let ((fp (int-sap (sb!vm:context-register alien-context + sb!vm::cfp-offset))) + (handler (and (< -1 error-number (length *internal-errors*)) + (svref *internal-errors* error-number)))) + (cond ((null handler) + (error 'simple-error + :format-control + "unknown internal error, ~D, args=~S" + :format-arguments + (list error-number + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + fp sc-offset alien-context)) + arguments)))) + ((not (functionp handler)) + (error 'simple-error + :format-control "internal error ~D: ~A; args=~S" + :format-arguments + (list error-number + handler + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + fp sc-offset alien-context)) + arguments)))) + (t + (funcall handler name fp alien-context arguments)))))))))) (defun control-stack-exhausted-error () (let ((sb!debug:*stack-top-hint* nil)) @@ -454,11 +468,42 @@ "Control stack guard page temporarily disabled: proceed with caution~%") (error 'control-stack-exhausted)))) +;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so +;;; that we don't need to allocate it when running out of +;;; memory. Similarly we pass the amounts in special variables as +;;; there may be multiple threads running into trouble at the same +;;; time. The condition is created by GC-REINIT. +(defvar *heap-exhausted-error-condition*) +(defvar *heap-exhausted-error-available-bytes*) +(defvar *heap-exhausted-error-requested-bytes*) + +(defun heap-exhausted-error (available requested) + (infinite-error-protect + (let ((*heap-exhausted-error-available-bytes* available) + (*heap-exhausted-error-requested-bytes* requested)) + (error *heap-exhausted-error-condition*)))) + (defun undefined-alien-variable-error () (error 'undefined-alien-variable-error)) (defun undefined-alien-function-error () (error 'undefined-alien-function-error)) +#!-win32 +(define-alien-variable current-memory-fault-address unsigned-long) + +#!-win32 (defun memory-fault-error () - (error 'memory-fault-error)) + (error 'memory-fault-error + :address current-memory-fault-address)) + +;;; This is SIGTRAP / EXCEPTION_BREAKPOINT that runtime could not deal +;;; with. Prior to Windows we just had a Lisp side handler for +;;; SIGTRAP, but now we need to deal with this portably. +(defun unhandled-trap-error (context-sap) + (declare (type system-area-pointer context-sap)) + (infinite-error-protect + (let ((context (sap-alien context-sap (* os-context-t)))) + (error 'breakpoint-error + :context context + :address (sap-int (sb!vm:context-pc context))))))