1 ;;;; functions and macros to define and deal with internal errors
2 ;;;; (i.e. problems that can be signaled from assembler code)
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!KERNEL")
17 (defvar *internal-errors
*
18 #.
(map 'vector
#'cdr sb
!c
:*backend-internal-errors
*))
20 (eval-when (:compile-toplevel
:execute
)
22 (sb!xc
:defmacro deferr
(name args
&rest body
)
23 (let* ((rest-pos (position '&rest args
))
24 (required (if rest-pos
(subseq args
0 rest-pos
) args
))
28 (fn-name (symbolicate name
"-HANDLER")))
30 ;; FIXME: Having a separate full DEFUN for each error doesn't
31 ;; seem to add much value, and it takes a lot of space. Perhaps
32 ;; we could do this dispatch with a big CASE statement instead?
33 (defun ,fn-name
(name ,fp
,context
,sc-offsets
)
34 ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
35 ;; tricks to hide this internal error-handling logic from the
36 ;; poor high level user, so his debugger tells him about
37 ;; where his error was detected instead of telling him where
38 ;; he ended up inside the system error-handling logic.
39 (declare (ignorable name
,fp
,context
,sc-offsets
))
40 (let (,@(let ((offset -
1))
42 `(,var
(sb!di
::sub-access-debug-var-slot
49 `((,(nth (1+ rest-pos
) args
)
50 (mapcar (lambda (sc-offset)
51 (sb!di
::sub-access-debug-var-slot
55 (nthcdr ,rest-pos
,sc-offsets
))))))
57 (setf (svref *internal-errors
* ,(error-number-or-lose name
))
62 (deferr unknown-error
(&rest args
)
63 (error "unknown error:~{ ~S~})" args
))
65 (deferr object-not-fun-error
(object)
68 :expected-type
'function
))
70 (deferr object-not-list-error
(object)
73 :expected-type
'list
))
75 (deferr object-not-bignum-error
(object)
78 :expected-type
'bignum
))
80 (deferr object-not-ratio-error
(object)
83 :expected-type
'ratio
))
85 (deferr object-not-single-float-error
(object)
88 :expected-type
'single-float
))
90 (deferr object-not-double-float-error
(object)
93 :expected-type
'double-float
))
96 (deferr object-not-long-float-error
(object)
99 :expected-type
'long-float
))
101 (deferr object-not-simple-string-error
(object)
104 :expected-type
'simple-string
))
106 (deferr object-not-simple-bit-vector-error
(object)
109 :expected-type
'simple-bit-vector
))
111 (deferr object-not-simple-vector-error
(object)
114 :expected-type
'simple-vector
))
116 (deferr object-not-fixnum-error
(object)
119 :expected-type
'fixnum
))
121 (deferr object-not-vector-error
(object)
124 :expected-type
'vector
))
126 (deferr object-not-string-error
(object)
129 :expected-type
'string
))
131 (deferr object-not-bit-vector-error
(object)
134 :expected-type
'bit-vector
))
136 (deferr object-not-array-error
(object)
139 :expected-type
'array
))
141 (deferr object-not-number-error
(object)
144 :expected-type
'number
))
146 (deferr object-not-rational-error
(object)
149 :expected-type
'rational
))
151 (deferr object-not-float-error
(object)
154 :expected-type
'float
))
156 (deferr object-not-real-error
(object)
159 :expected-type
'real
))
161 (deferr object-not-integer-error
(object)
164 :expected-type
'integer
))
166 (deferr object-not-cons-error
(object)
169 :expected-type
'cons
))
171 (deferr object-not-symbol-error
(object)
174 :expected-type
'symbol
))
176 (deferr undefined-fun-error
(fdefn-or-symbol)
177 (error 'undefined-function
178 :name
(etypecase fdefn-or-symbol
179 (symbol fdefn-or-symbol
)
180 (fdefn (fdefn-name fdefn-or-symbol
)))))
182 (deferr invalid-arg-count-error
(nargs)
183 (error 'simple-program-error
184 :format-control
"invalid number of arguments: ~S"
185 :format-arguments
(list nargs
)))
187 (deferr bogus-arg-to-values-list-error
(list)
188 (error 'simple-type-error
192 "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
193 :format-arguments
(list list
)))
195 (deferr unbound-symbol-error
(symbol)
196 (error 'unbound-variable
:name symbol
))
198 (deferr object-not-base-char-error
(object)
201 :expected-type
'base-char
))
203 (deferr object-not-sap-error
(object)
206 :expected-type
'system-area-pointer
))
208 (deferr invalid-unwind-error
()
209 (error 'simple-control-error
211 "attempt to RETURN-FROM a block or GO to a tag that no longer exists"
214 (deferr unseen-throw-tag-error
(tag)
215 (error 'simple-control-error
216 :format-control
"attempt to THROW to a tag that does not exist: ~S"
217 :format-arguments
(list tag
)))
219 (deferr nil-fun-returned-error
(function)
220 (error 'simple-control-error
222 "A function with declared result type NIL returned:~% ~S"
223 :format-arguments
(list function
)))
225 (deferr division-by-zero-error
(this that
)
226 (error 'division-by-zero
228 :operands
(list this that
)))
230 (deferr object-not-type-error
(object type
)
231 (error (if (and (typep object
'instance
)
232 (layout-invalid (%instance-layout object
)))
236 :expected-type type
))
238 (deferr layout-invalid-error
(object layout
)
239 (error 'layout-invalid
241 :expected-type
(layout-class layout
)))
243 (deferr odd-key-args-error
()
244 (error 'simple-program-error
245 :format-control
"odd number of &KEY arguments"))
247 (deferr unknown-key-arg-error
(key-name)
248 (error 'simple-program-error
249 :format-control
"unknown &KEY argument: ~S"
250 :format-arguments
(list key-name
)))
252 (deferr invalid-array-index-error
(array bound index
)
255 "invalid array index ~W for ~S (should be nonnegative and <~W)"
256 :format-arguments
(list index array bound
)))
258 (deferr object-not-simple-array-error
(object)
261 :expected-type
'simple-array
))
263 (deferr object-not-signed-byte-32-error
(object)
266 :expected-type
'(signed-byte 32)))
268 (deferr object-not-unsigned-byte-32-error
(object)
271 :expected-type
'(unsigned-byte 32)))
273 (deferr object-not-simple-array-unsigned-byte-2-error
(object)
276 :expected-type
'(simple-array (unsigned-byte 2) (*))))
278 (deferr object-not-simple-array-unsigned-byte-4-error
(object)
281 :expected-type
'(simple-array (unsigned-byte 4) (*))))
283 (deferr object-not-simple-array-unsigned-byte-8-error
(object)
286 :expected-type
'(simple-array (unsigned-byte 8) (*))))
288 (deferr object-not-simple-array-unsigned-byte-16-error
(object)
291 :expected-type
'(simple-array (unsigned-byte 16) (*))))
293 (deferr object-not-simple-array-unsigned-byte-32-error
(object)
296 :expected-type
'(simple-array (unsigned-byte 32) (*))))
298 (deferr object-not-simple-array-signed-byte-8-error
(object)
301 :expected-type
'(simple-array (signed-byte 8) (*))))
303 (deferr object-not-simple-array-signed-byte-16-error
(object)
306 :expected-type
'(simple-array (signed-byte 16) (*))))
308 (deferr object-not-simple-array-signed-byte-30-error
(object)
311 :expected-type
'(simple-array (signed-byte 30) (*))))
313 (deferr object-not-simple-array-signed-byte-32-error
(object)
316 :expected-type
'(simple-array (signed-byte 32) (*))))
318 (deferr object-not-simple-array-single-float-error
(object)
321 :expected-type
'(simple-array single-float
(*))))
323 (deferr object-not-simple-array-double-float-error
(object)
326 :expected-type
'(simple-array double-float
(*))))
328 (deferr object-not-simple-array-complex-single-float-error
(object)
331 :expected-type
'(simple-array (complex single-float
) (*))))
333 (deferr object-not-simple-array-complex-double-float-error
(object)
336 :expected-type
'(simple-array (complex double-float
) (*))))
339 (deferr object-not-simple-array-complex-long-float-error
(object)
342 :expected-type
'(simple-array (complex long-float
) (*))))
344 (deferr object-not-complex-error
(object)
347 :expected-type
'complex
))
349 (deferr object-not-complex-rational-error
(object)
352 :expected-type
'(complex rational
)))
354 (deferr object-not-complex-single-float-error
(object)
357 :expected-type
'(complex single-float
)))
359 (deferr object-not-complex-double-float-error
(object)
362 :expected-type
'(complex double-float
)))
365 (deferr object-not-complex-long-float-error
(object)
368 :expected-type
'(complex long-float
)))
370 (deferr object-not-weak-pointer-error
(object)
373 :expected-type
'weak-pointer
))
375 (deferr object-not-instance-error
(object)
378 :expected-type
'instance
))
380 (deferr object-not-complex-vector-error
(object)
383 :expected-type
'(and vector
(not simple-array
))))
385 ;;;; fetching errorful function name
387 ;;; This flag is used to prevent infinite recursive lossage when
388 ;;; we can't find the caller for some reason.
389 (defvar *finding-name
* nil
)
391 (defun find-caller-name-and-frame ()
393 (values "<error finding caller name -- already finding name>" nil
)
395 (let* ((*finding-name
* t
)
396 (frame (sb!di
:frame-down
(sb!di
:frame-down
(sb!di
:top-frame
))))
397 (name (sb!di
:debug-fun-name
398 (sb!di
:frame-debug-fun frame
))))
399 (sb!di
:flush-frames-above frame
)
402 (values "<error finding caller name -- trapped error>" nil
))
403 (sb!di
:debug-condition
()
404 (values "<error finding caller name -- trapped debug-condition>"
407 (defun find-interrupted-name ()
408 (/show0
"entering FIND-INTERRUPTED-NAME")
410 (values "<error finding interrupted name -- already finding name>" nil
)
412 (let ((*finding-name
* t
))
413 (/show0
"in ordinary case")
414 (do ((frame (sb!di
:top-frame
) (sb!di
:frame-down frame
)))
416 (/show0
"null frame")
417 (values "<error finding interrupted name -- null frame>" nil
))
418 (/show0
"at head of DO loop")
419 (when (and (sb!di
::compiled-frame-p frame
)
420 (sb!di
::compiled-frame-escaped frame
))
421 (sb!di
:flush-frames-above frame
)
422 (/show0
"returning from within DO loop")
423 (return (values (sb!di
:debug-fun-name
424 (sb!di
:frame-debug-fun frame
))
427 (/show0
"trapped ERROR")
428 (values "<error finding interrupted name -- trapped error>" nil
))
429 (sb!di
:debug-condition
()
430 (/show0
"trapped DEBUG-CONDITION")
431 (values "<error finding interrupted name -- trapped debug-condition>"
434 ;;;; INTERNAL-ERROR signal handler
436 (defvar *internal-error-args
*)
438 (defun internal-error (context continuable
)
439 (declare (type system-area-pointer context
))
440 (declare (ignore continuable
))
441 (/show0
"entering INTERNAL-ERROR, CONTEXT=..")
443 (infinite-error-protect
444 (/show0
"about to bind ALIEN-CONTEXT")
445 (let ((alien-context (locally
446 (declare (optimize (inhibit-warnings 3)))
447 (sb!alien
:sap-alien context
(* os-context-t
)))))
448 (/show0
"about to bind ERROR-NUMBER and ARGUMENTS")
449 (multiple-value-bind (error-number arguments
)
450 (sb!vm
:internal-error-args alien-context
)
452 ;; There's a limit to how much error reporting we can usefully
453 ;; do before initialization is complete, but try to be a little
454 ;; bit helpful before we die.
455 (/show0
"back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..")
456 (/hexstr error-number
)
457 (/show0
"cold/low ARGUMENTS=..")
459 (unless *cold-init-complete-p
*
460 (%primitive print
"can't recover from error in cold init, halting")
461 (%primitive sb
!c
:halt
))
463 (multiple-value-bind (name sb
!debug
:*stack-top-hint
*)
464 (find-interrupted-name)
465 (/show0
"back from FIND-INTERRUPTED-NAME")
466 (let ((fp (int-sap (sb!vm
:context-register alien-context
468 (handler (and (< -
1 error-number
(length *internal-errors
*))
469 (svref *internal-errors
* error-number
))))
470 (cond ((null handler
)
473 "unknown internal error, ~D, args=~S"
476 (mapcar (lambda (sc-offset)
477 (sb!di
::sub-access-debug-var-slot
478 fp sc-offset alien-context
))
480 ((not (functionp handler
))
482 :format-control
"internal error ~D: ~A; args=~S"
486 (mapcar (lambda (sc-offset)
487 (sb!di
::sub-access-debug-var-slot
488 fp sc-offset alien-context
))
491 (funcall handler name fp alien-context arguments
)))))))))
493 (defun control-stack-exhausted-error ()
494 (let ((sb!debug
:*stack-top-hint
* nil
))
495 (infinite-error-protect
496 (format *error-output
*
497 "Control stack guard page temporarily disabled: proceed with caution~%")
498 (error 'control-stack-exhausted
))))