(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
(symbol fdefn-or-symbol)
(fdefn (fdefn-name fdefn-or-symbol)))))
+#!+x86-64
+(deferr undefined-alien-fun-error (address)
+ (error 'undefined-alien-function-error
+ :name
+ (and (integerp address)
+ (sap-foreign-symbol (int-sap address)))))
+
+#!-x86-64
+(defun undefined-alien-fun-error ()
+ (error 'undefined-alien-function-error))
+
(deferr invalid-arg-count-error (nargs)
(error 'simple-program-error
:format-control "invalid number of arguments: ~S"
: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 '(complex long-float)))
+#!+sb-simd-pack
+(deferr object-not-simd-pack-error (object)
+ (error 'type-error
+ :datum object
+ :expected-type 'simd-pack))
+
(deferr object-not-weak-pointer-error (object)
(error 'type-error
:datum object
(/show0 "trapped DEBUG-CONDITION")
(values "<error finding interrupted name -- trapped debug-condition>"
nil)))))
+
+(defun find-caller-of-named-frame (name)
+ (unless *finding-name*
+ (handler-case
+ (let ((*finding-name* t))
+ (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
+ ((null frame))
+ (when (and (sb!di::compiled-frame-p frame)
+ (eq name (sb!di:debug-fun-name
+ (sb!di:frame-debug-fun frame))))
+ (let ((caller (sb!di:frame-down frame)))
+ (sb!di:flush-frames-above caller)
+ (return caller)))))
+ ((or error sb!di:debug-condition) ()
+ nil)
+ (sb!di:debug-condition ()
+ nil))))
\f
;;;; INTERNAL-ERROR signal handler
(/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)))))
+ (let* ((alien-context (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (sb!alien:sap-alien context (* os-context-t))))
+ #!+c-stack-is-control-stack
+ (*saved-fp-and-pcs*
+ (cons (cons (%make-lisp-obj (sb!vm:context-register
+ alien-context
+ sb!vm::cfp-offset))
+ (sb!vm:context-pc alien-context))
+ (when (boundp '*saved-fp-and-pcs*)
+ *saved-fp-and-pcs*))))
+ (declare (truly-dynamic-extent *saved-fp-and-pcs*))
(/show0 "about to bind ERROR-NUMBER and ARGUMENTS")
(multiple-value-bind (error-number arguments)
(sb!vm:internal-error-args alien-context)
(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*))
"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
(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)
+(define-alien-variable current-memory-fault-address unsigned)
#!-win32
(defun memory-fault-error ()