X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=9014b56ae65333cfd681521e2f69c85ef633ef88;hb=f12b298a4ce9090470000360b49523e56475a680;hp=e89f43c29a54cbbae0af05249875b8cbcd3094c5;hpb=3c901eea59aeb4716a7288c943f30c4282af41de;p=sbcl.git diff --git a/src/code/interr.lisp b/src/code/interr.lisp index e89f43c..9014b56 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 @@ -391,41 +395,34 @@ 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") @@ -463,10 +460,25 @@ "Control stack guard page temporarily disabled: proceed with caution~%") (error 'control-stack-exhausted)))) +(defun binding-stack-exhausted-error () + (let ((sb!debug:*stack-top-hint* nil)) + (infinite-error-protect + (format *error-output* + "Binding stack guard page temporarily disabled: proceed with caution~%") + (error 'binding-stack-exhausted)))) + +(defun alien-stack-exhausted-error () + (let ((sb!debug:*stack-top-hint* nil)) + (infinite-error-protect + (format *error-output* + "Alien stack guard page temporarily disabled: proceed with caution~%") + (error 'alien-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*) @@ -484,7 +496,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 () @@ -493,10 +505,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))))))