X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=3b75632f49f15a41ba19c6358f39396bb9833589;hb=8eee0d3a30bf39d9f201acff28c92059fe6c3e4e;hp=260e105e1107963325563ddf4feb759c90b93f6f;hpb=23124951022f995aace9e7f17e650cd23b83c591;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 260e105..3b75632 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -282,6 +282,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 +399,7 @@ (values "" nil))))) + ;;;; INTERNAL-ERROR signal handler (defun internal-error (context continuable) @@ -400,7 +410,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 +427,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 +474,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 +495,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 +504,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))))))