(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))))
+ (required (if rest-pos (subseq args 0 rest-pos) args))
+ (fn-name (symbolicate name "-HANDLER")))
+ (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
(deferr object-not-fun-error (object)
(error 'type-error
- :datum object
- :expected-type 'function))
+ :datum object
+ :expected-type 'function))
(deferr object-not-list-error (object)
(error 'type-error
- :datum object
- :expected-type 'list))
+ :datum object
+ :expected-type 'list))
(deferr object-not-bignum-error (object)
(error 'type-error
- :datum object
- :expected-type 'bignum))
+ :datum object
+ :expected-type 'bignum))
(deferr object-not-ratio-error (object)
(error 'type-error
- :datum object
- :expected-type 'ratio))
+ :datum object
+ :expected-type 'ratio))
(deferr object-not-single-float-error (object)
(error 'type-error
- :datum object
- :expected-type 'single-float))
+ :datum object
+ :expected-type 'single-float))
(deferr object-not-double-float-error (object)
(error 'type-error
- :datum object
- :expected-type 'double-float))
+ :datum object
+ :expected-type 'double-float))
#!+long-float
(deferr object-not-long-float-error (object)
(error 'type-error
- :datum object
- :expected-type 'long-float))
+ :datum object
+ :expected-type 'long-float))
(deferr object-not-simple-string-error (object)
(error 'type-error
- :datum object
- :expected-type 'simple-string))
+ :datum object
+ :expected-type 'simple-string))
(deferr object-not-fixnum-error (object)
(error 'type-error
- :datum object
- :expected-type 'fixnum))
+ :datum object
+ :expected-type 'fixnum))
(deferr object-not-vector-error (object)
(error 'type-error
- :datum object
- :expected-type 'vector))
+ :datum object
+ :expected-type 'vector))
(deferr object-not-string-error (object)
(error 'type-error
- :datum object
- :expected-type 'string))
+ :datum object
+ :expected-type 'string))
(deferr object-not-base-string-error (object)
(error 'type-error
- :datum object
- :expected-type 'base-string))
+ :datum object
+ :expected-type 'base-string))
+
+(deferr object-not-vector-nil-error (object)
+ (error 'type-error
+ :datum object
+ :expected-type '(vector nil)))
+
+#!+sb-unicode
+(deferr object-not-character-string-error (object)
+ (error 'type-error
+ :datum object
+ :expected-type '(vector character)))
(deferr object-not-bit-vector-error (object)
(error 'type-error
- :datum object
- :expected-type 'bit-vector))
+ :datum object
+ :expected-type 'bit-vector))
(deferr object-not-array-error (object)
(error 'type-error
- :datum object
- :expected-type 'array))
+ :datum object
+ :expected-type 'array))
(deferr object-not-number-error (object)
(error 'type-error
- :datum object
- :expected-type 'number))
+ :datum object
+ :expected-type 'number))
(deferr object-not-rational-error (object)
(error 'type-error
- :datum object
- :expected-type 'rational))
+ :datum object
+ :expected-type 'rational))
(deferr object-not-float-error (object)
(error 'type-error
- :datum object
- :expected-type 'float))
+ :datum object
+ :expected-type 'float))
(deferr object-not-real-error (object)
(error 'type-error
- :datum object
- :expected-type 'real))
+ :datum object
+ :expected-type 'real))
(deferr object-not-integer-error (object)
(error 'type-error
- :datum object
- :expected-type 'integer))
+ :datum object
+ :expected-type 'integer))
(deferr object-not-cons-error (object)
(error 'type-error
- :datum object
- :expected-type 'cons))
+ :datum object
+ :expected-type 'cons))
(deferr object-not-symbol-error (object)
(error 'type-error
- :datum object
- :expected-type 'symbol))
+ :datum object
+ :expected-type 'symbol))
(deferr undefined-fun-error (fdefn-or-symbol)
(error 'undefined-function
- :name (etypecase fdefn-or-symbol
- (symbol fdefn-or-symbol)
- (fdefn (fdefn-name fdefn-or-symbol)))))
+ :name (etypecase fdefn-or-symbol
+ (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"
- :format-arguments (list nargs)))
+ :format-control "invalid number of arguments: ~S"
+ :format-arguments (list nargs)))
(deferr bogus-arg-to-values-list-error (list)
(error 'simple-type-error
- :datum list
- :expected-type 'list
- :format-control
- "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
- :format-arguments (list list)))
+ :datum list
+ :expected-type 'list
+ :format-control
+ "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
+ :format-arguments (list list)))
(deferr unbound-symbol-error (symbol)
(error 'unbound-variable :name symbol))
-(deferr object-not-base-char-error (object)
+(deferr object-not-character-error (object)
(error 'type-error
- :datum object
- :expected-type 'base-char))
+ :datum object
+ :expected-type 'character))
(deferr object-not-sap-error (object)
(error 'type-error
- :datum object
- :expected-type 'system-area-pointer))
+ :datum object
+ :expected-type 'system-area-pointer))
(deferr invalid-unwind-error ()
(error 'simple-control-error
- :format-control
- "attempt to RETURN-FROM a block or GO to a tag that no longer exists"
- ))
+ :format-control
+ "attempt to RETURN-FROM a block or GO to a tag that no longer exists"
+ ))
(deferr unseen-throw-tag-error (tag)
(error 'simple-control-error
- :format-control "attempt to THROW to a tag that does not exist: ~S"
- :format-arguments (list tag)))
+ :format-control "attempt to THROW to a tag that does not exist: ~S"
+ :format-arguments (list tag)))
(deferr nil-fun-returned-error (function)
(error 'simple-control-error
- :format-control
- "A function with declared result type NIL returned:~% ~S"
- :format-arguments (list function)))
+ :format-control
+ "A function with declared result type NIL returned:~% ~S"
+ :format-arguments (list function)))
(deferr nil-array-accessed-error (array)
(error 'nil-array-accessed-error
- :datum array :expected-type '(not (array nil))))
+ :datum array :expected-type '(not (array nil))))
(deferr division-by-zero-error (this that)
(error 'division-by-zero
- :operation 'division
- :operands (list this that)))
+ :operation 'division
+ :operands (list this that)))
(deferr object-not-type-error (object type)
- (error (if (and (typep object 'instance)
- (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
- :datum object
- :expected-type (layout-classoid layout)))
+ :datum object
+ :expected-type (layout-classoid layout)))
(deferr odd-key-args-error ()
(error 'simple-program-error
- :format-control "odd number of &KEY arguments"))
+ :format-control "odd number of &KEY arguments"))
(deferr unknown-key-arg-error (key-name)
(error 'simple-program-error
- :format-control "unknown &KEY argument: ~S"
- :format-arguments (list key-name)))
+ :format-control "unknown &KEY argument: ~S"
+ :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 'simple-array))
+ :datum object
+ :expected-type 'simple-array))
(deferr object-not-signed-byte-32-error (object)
(error 'type-error
- :datum object
- :expected-type '(signed-byte 32)))
+ :datum object
+ :expected-type '(signed-byte 32)))
(deferr object-not-unsigned-byte-32-error (object)
(error 'type-error
- :datum object
- :expected-type '(unsigned-byte 32)))
+ :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
- ,@(map 'list
- (lambda (saetp)
- `(deferr ,(symbolicate
- "OBJECT-NOT-"
- (sb!vm:saetp-primitive-type-name saetp)
- "-ERROR")
- (object)
- (error 'type-error
- :datum object
- :expected-type `(simple-array
- ,(sb!vm:saetp-specifier saetp)
- (*)))))
- sb!vm:*specialized-array-element-type-properties*))))
+ `(progn
+ ,@(map 'list
+ (lambda (saetp)
+ `(deferr ,(symbolicate
+ "OBJECT-NOT-"
+ (sb!vm:saetp-primitive-type-name saetp)
+ "-ERROR")
+ (object)
+ (error 'type-error
+ :datum object
+ :expected-type '(simple-array
+ ,(sb!vm:saetp-specifier saetp)
+ (*)))))
+ sb!vm:*specialized-array-element-type-properties*))))
(define-simple-array-internal-errors))
(deferr object-not-complex-error (object)
(error 'type-error
- :datum object
- :expected-type 'complex))
+ :datum object
+ :expected-type 'complex))
(deferr object-not-complex-rational-error (object)
(error 'type-error
- :datum object
- :expected-type '(complex rational)))
+ :datum object
+ :expected-type '(complex rational)))
(deferr object-not-complex-single-float-error (object)
(error 'type-error
- :datum object
- :expected-type '(complex single-float)))
+ :datum object
+ :expected-type '(complex single-float)))
(deferr object-not-complex-double-float-error (object)
(error 'type-error
- :datum object
- :expected-type '(complex double-float)))
+ :datum object
+ :expected-type '(complex double-float)))
#!+long-float
(deferr object-not-complex-long-float-error (object)
(error 'type-error
- :datum object
- :expected-type '(complex long-float)))
+ :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
- :expected-type 'weak-pointer))
+ :datum object
+ :expected-type 'weak-pointer))
(deferr object-not-instance-error (object)
(error 'type-error
- :datum object
- :expected-type 'instance))
+ :datum object
+ :expected-type 'instance))
(deferr object-not-complex-vector-error (object)
(error 'type-error
- :datum object
- :expected-type '(and vector (not simple-array))))
+ :datum object
+ :expected-type '(and vector (not simple-array))))
\f
;;;; fetching errorful function name
(if *finding-name*
(values "<error finding caller name -- already finding name>" nil)
(handler-case
- (let* ((*finding-name* t)
- (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame))))
- (name (sb!di:debug-fun-name
- (sb!di:frame-debug-fun frame))))
- (sb!di:flush-frames-above frame)
- (values name frame))
- (error ()
- (values "<error finding caller name -- trapped error>" nil))
- (sb!di:debug-condition ()
- (values "<error finding caller name -- trapped debug-condition>"
- nil)))))
-
-(defun find-interrupted-name ()
- (/show0 "entering FIND-INTERRUPTED-NAME")
+ (let* ((*finding-name* t)
+ (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame))))
+ (name (sb!di:debug-fun-name
+ (sb!di:frame-debug-fun frame))))
+ (sb!di:flush-frames-above frame)
+ (values name frame))
+ (error ()
+ (values "<error finding caller name -- trapped error>" nil))
+ (sb!di:debug-condition ()
+ (values "<error finding caller name -- trapped debug-condition>"
+ nil)))))
+
+(defun find-interrupted-name-and-frame ()
+ (/show0 "entering FIND-INTERRUPTED-NAME-AND-FRAME")
(if *finding-name*
(values "<error finding interrupted name -- already finding name>" nil)
(handler-case
- (let ((*finding-name* t))
- (/show0 "in ordinary case")
- (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
- ((null frame)
- (/show0 "null frame")
- (values "<error finding interrupted name -- null frame>" nil))
- (/show0 "at head of DO loop")
- (when (and (sb!di::compiled-frame-p frame)
- (sb!di::compiled-frame-escaped frame))
- (sb!di:flush-frames-above frame)
- (/show0 "returning from within DO loop")
- (return (values (sb!di:debug-fun-name
- (sb!di:frame-debug-fun frame))
- frame)))))
- (error ()
- (/show0 "trapped ERROR")
- (values "<error finding interrupted name -- trapped error>" nil))
- (sb!di:debug-condition ()
- (/show0 "trapped DEBUG-CONDITION")
- (values "<error finding interrupted name -- trapped debug-condition>"
- nil)))))
+ (let ((*finding-name* t))
+ (/show0 "in ordinary case")
+ (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
+ ((null frame)
+ (/show0 "null frame")
+ (values "<error finding interrupted name -- null frame>" nil))
+ (/show0 "at head of DO loop")
+ (when (and (sb!di::compiled-frame-p frame)
+ (sb!di::compiled-frame-escaped frame))
+ (sb!di:flush-frames-above frame)
+ (/show0 "returning from within DO loop")
+ (return (values (sb!di:debug-fun-name
+ (sb!di:frame-debug-fun frame))
+ frame)))))
+ (error ()
+ (/show0 "trapped ERROR")
+ (values "<error finding interrupted name -- trapped error>" nil))
+ (sb!di:debug-condition ()
+ (/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
-(defvar *internal-error-args*)
+;;;; INTERNAL-ERROR signal handler
(defun internal-error (context continuable)
(declare (type system-area-pointer 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)))))
+ (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)
+ (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
(/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))
-
- (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)))))))))
+ (%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")
+ (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))
(infinite-error-protect
(format *error-output*
- "Control stack guard page temporarily disabled: proceed with caution~%")
+ "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.
+(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))
+
+#!-win32
+(define-alien-variable current-memory-fault-address unsigned)
+
+#!-win32
+(defun 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))))))
projects / sbcl.git / blobdiff