X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=7a48c43b3416613b48b5c3cb006458cf36345f7f;hb=672b2f6cb751566526c7f3bb3de6b7d8424760e2;hp=5bb783fb20a3eadf49d130c9e6f6e6c8b3f8546b;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 5bb783f..7a48c43 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 @@ -363,8 +372,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 +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) - (/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 +473,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 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))))))