X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=7a48c43b3416613b48b5c3cb006458cf36345f7f;hb=5d04a95274c9ddaebbcd6ddffc5d646e2c25598c;hp=e89f43c29a54cbbae0af05249875b8cbcd3094c5;hpb=3c901eea59aeb4716a7288c943f30c4282af41de;p=sbcl.git

diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index e89f43c..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
@@ -391,44 +400,45 @@
                   nil)))))
 
 
-;;; Special variable to store away the signal context passed to
-;;; internal error. internal-error stores the context for use by
-;;; sb-di:top-frame to figure out what the frame pointer and pc were
-;;; when the error was signalled. This is done since on some platforms
-;;; we have problems tracing through signal handler frames.
-(defparameter *internal-error-context* nil)
-
 ;;;; INTERNAL-ERROR signal handler
 
 (defun internal-error (context continuable)
   (declare (type system-area-pointer context))
   (declare (ignore continuable))
-  (let ((*internal-error-context* context))
-    (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
-    (/hexstr context)
-    (infinite-error-protect
-     (/show0 "about to bind ALIEN-CONTEXT")
-     (let ((alien-context (locally
-                              (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)
-           (sb!vm:internal-error-args alien-context)
-
-         ;; There's a limit to how much error reporting we can usefully
-         ;; do before initialization is complete, but try to be a little
-         ;; bit helpful before we die.
-         (/show0 "back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..")
-         (/hexstr error-number)
-         (/show0 "cold/low ARGUMENTS=..")
-         (/hexstr arguments)
-         (unless *cold-init-complete-p*
-           (%primitive print "can't recover from error in cold init, halting")
-           (%primitive sb!c:halt))
-
+  (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
+  (/hexstr context)
+  (infinite-error-protect
+   (/show0 "about to bind ALIEN-CONTEXT")
+   (let ((alien-context (locally
+                            (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)
+         (sb!vm:internal-error-args alien-context)
+
+       ;; There's a limit to how much error reporting we can usefully
+       ;; do before initialization is complete, but try to be a little
+       ;; bit helpful before we die.
+       (/show0 "back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..")
+       (/hexstr error-number)
+       (/show0 "cold/low ARGUMENTS=..")
+       (/hexstr arguments)
+       (unless *cold-init-complete-p*
+         (%primitive print "can't recover from error in cold init, halting")
+         (%primitive sb!c:halt))
+
+       (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*))
@@ -464,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*)
@@ -493,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))))))