(sb!xc:defmacro deferr (name args &rest body)
(let* ((rest-pos (position '&rest args))
(required (if rest-pos (subseq args 0 rest-pos) args))
- (fp (gensym))
- (context (gensym))
- (sc-offsets (gensym))
(fn-name (symbolicate name "-HANDLER")))
- `(progn
- ;; FIXME: Having a separate full DEFUN for each error doesn't
- ;; seem to add much value, and it takes a lot of space. Perhaps
- ;; we could do this dispatch with a big CASE statement instead?
- (defun ,fn-name (name ,fp ,context ,sc-offsets)
- ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
- ;; tricks to hide this internal error-handling logic from the
- ;; poor high level user, so his debugger tells him about
- ;; where his error was detected instead of telling him where
- ;; he ended up inside the system error-handling logic.
- (declare (ignorable name ,fp ,context ,sc-offsets))
- (let (,@(let ((offset -1))
- (mapcar (lambda (var)
- `(,var (sb!di::sub-access-debug-var-slot
- ,fp
- (nth ,(incf offset)
- ,sc-offsets)
- ,context)))
- required))
- ,@(when rest-pos
- `((,(nth (1+ rest-pos) args)
- (mapcar (lambda (sc-offset)
- (sb!di::sub-access-debug-var-slot
- ,fp
- sc-offset
- ,context))
- (nthcdr ,rest-pos ,sc-offsets))))))
- ,@body))
- (setf (svref *internal-errors* ,(error-number-or-lose name))
- #',fn-name))))
+ (with-unique-names (fp context sc-offsets)
+ `(progn
+ ;; FIXME: Having a separate full DEFUN for each error doesn't
+ ;; seem to add much value, and it takes a lot of space. Perhaps
+ ;; we could do this dispatch with a big CASE statement instead?
+ (defun ,fn-name (name ,fp ,context ,sc-offsets)
+ ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
+ ;; tricks to hide this internal error-handling logic from the
+ ;; poor high level user, so his debugger tells him about
+ ;; where his error was detected instead of telling him where
+ ;; he ended up inside the system error-handling logic.
+ (declare (ignorable name ,fp ,context ,sc-offsets))
+ (let (,@(let ((offset -1))
+ (mapcar (lambda (var)
+ `(,var (sb!di::sub-access-debug-var-slot
+ ,fp
+ (nth ,(incf offset)
+ ,sc-offsets)
+ ,context)))
+ required))
+ ,@(when rest-pos
+ `((,(nth (1+ rest-pos) args)
+ (mapcar (lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ ,fp
+ sc-offset
+ ,context))
+ (nthcdr ,rest-pos ,sc-offsets))))))
+ ,@body))
+ (setf (svref *internal-errors* ,(error-number-or-lose name))
+ #',fn-name)))))
) ; EVAL-WHEN
:operands (list this that)))
(deferr object-not-type-error (object type)
- (error (if (and (%instancep object)
- (layout-invalid (%instance-layout object)))
- 'layout-invalid
- 'type-error)
- :datum object
- :expected-type type))
+ (if (invalid-array-p object)
+ (invalid-array-error object)
+ (error (if (and (%instancep object)
+ (layout-invalid (%instance-layout object)))
+ 'layout-invalid
+ 'type-error)
+ :datum object
+ :expected-type type)))
(deferr layout-invalid-error (object layout)
(error 'layout-invalid
: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 index bound))
(deferr object-not-simple-array-error (object)
(error 'type-error
: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
nil)))))
\f
-;;; 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")
"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*)
(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 ()
;;; 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))))))