X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=232f1a6e21a1d257b2d166f5da788acfc317d73e;hb=de0a47a2f2b165f34177669bd9499135847b4897;hp=260e105e1107963325563ddf4feb759c90b93f6f;hpb=23124951022f995aace9e7f17e650cd23b83c591;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 260e105..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 @@ -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-and-frame) - (/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)) @@ -455,9 +469,10 @@ (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. +;;; 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*) @@ -475,7 +490,7 @@ (error 'undefined-alien-function-error)) #!-win32 -(define-alien-variable current-memory-fault-address long) +(define-alien-variable current-memory-fault-address unsigned-long) #!-win32 (defun memory-fault-error () @@ -484,10 +499,11 @@ ;;; 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 this portably. +;;; 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 "Unhandled breakpoint/trap at #x~X." - (sap-int (sb!vm:context-pc context)))))) + (error 'breakpoint-error + :context context + :address (sap-int (sb!vm:context-pc context))))))