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-fixnum-error
(object)
109 :expected-type
'fixnum
))
111 (deferr object-not-vector-error
(object)
114 :expected-type
'vector
))
116 (deferr object-not-string-error
(object)
119 :expected-type
'string
))
121 (deferr object-not-base-string-error
(object)
124 :expected-type
'base-string
))
126 (deferr object-not-vector-nil-error
(object)
129 :expected-type
'(vector nil
)))
132 (deferr object-not-character-string-error
(object)
135 :expected-type
'(vector character
)))
137 (deferr object-not-bit-vector-error
(object)
140 :expected-type
'bit-vector
))
142 (deferr object-not-array-error
(object)
145 :expected-type
'array
))
147 (deferr object-not-number-error
(object)
150 :expected-type
'number
))
152 (deferr object-not-rational-error
(object)
155 :expected-type
'rational
))
157 (deferr object-not-float-error
(object)
160 :expected-type
'float
))
162 (deferr object-not-real-error
(object)
165 :expected-type
'real
))
167 (deferr object-not-integer-error
(object)
170 :expected-type
'integer
))
172 (deferr object-not-cons-error
(object)
175 :expected-type
'cons
))
177 (deferr object-not-symbol-error
(object)
180 :expected-type
'symbol
))
182 (deferr undefined-fun-error
(fdefn-or-symbol)
183 (error 'undefined-function
184 :name
(etypecase fdefn-or-symbol
185 (symbol fdefn-or-symbol
)
186 (fdefn (fdefn-name fdefn-or-symbol
)))))
188 (deferr invalid-arg-count-error
(nargs)
189 (error 'simple-program-error
190 :format-control
"invalid number of arguments: ~S"
191 :format-arguments
(list nargs
)))
193 (deferr bogus-arg-to-values-list-error
(list)
194 (error 'simple-type-error
198 "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
199 :format-arguments
(list list
)))
201 (deferr unbound-symbol-error
(symbol)
202 (error 'unbound-variable
:name symbol
))
204 (deferr object-not-character-error
(object)
207 :expected-type
'character
))
209 (deferr object-not-sap-error
(object)
212 :expected-type
'system-area-pointer
))
214 (deferr invalid-unwind-error
()
215 (error 'simple-control-error
217 "attempt to RETURN-FROM a block or GO to a tag that no longer exists"
220 (deferr unseen-throw-tag-error
(tag)
221 (error 'simple-control-error
222 :format-control
"attempt to THROW to a tag that does not exist: ~S"
223 :format-arguments
(list tag
)))
225 (deferr nil-fun-returned-error
(function)
226 (error 'simple-control-error
228 "A function with declared result type NIL returned:~% ~S"
229 :format-arguments
(list function
)))
231 (deferr nil-array-accessed-error
(array)
232 (error 'nil-array-accessed-error
233 :datum array
:expected-type
'(not (array nil
))))
235 (deferr division-by-zero-error
(this that
)
236 (error 'division-by-zero
238 :operands
(list this that
)))
240 (deferr object-not-type-error
(object type
)
241 (error (if (and (%instancep object
)
242 (layout-invalid (%instance-layout object
)))
246 :expected-type type
))
248 (deferr layout-invalid-error
(object layout
)
249 (error 'layout-invalid
251 :expected-type
(layout-classoid layout
)))
253 (deferr odd-key-args-error
()
254 (error 'simple-program-error
255 :format-control
"odd number of &KEY arguments"))
257 (deferr unknown-key-arg-error
(key-name)
258 (error 'simple-program-error
259 :format-control
"unknown &KEY argument: ~S"
260 :format-arguments
(list key-name
)))
262 (deferr invalid-array-index-error
(array bound index
)
263 (error 'simple-type-error
265 "invalid array index ~W for ~S (should be nonnegative and <~W)"
266 :format-arguments
(list index array bound
)
268 :expected-type
`(integer 0 (,bound
))))
270 (deferr object-not-simple-array-error
(object)
273 :expected-type
'simple-array
))
275 (deferr object-not-signed-byte-32-error
(object)
278 :expected-type
'(signed-byte 32)))
280 (deferr object-not-unsigned-byte-32-error
(object)
283 :expected-type
'(unsigned-byte 32)))
285 (deferr tls-exhausted-error
()
286 ;; There is nothing we can do about it. A number of entries in the
287 ;; tls could be reserved and made available for recovery but since
288 ;; tls indices are never reused it would be kind of silly and
289 ;; without it signalling an error is more than likely to end in a
291 (%primitive print
"Thread local storage exhausted.")
295 ((define-simple-array-internal-errors ()
299 `(deferr ,(symbolicate
301 (sb!vm
:saetp-primitive-type-name saetp
)
306 :expected-type
'(simple-array
307 ,(sb!vm
:saetp-specifier saetp
)
309 sb
!vm
:*specialized-array-element-type-properties
*))))
310 (define-simple-array-internal-errors))
312 (deferr object-not-complex-error
(object)
315 :expected-type
'complex
))
317 (deferr object-not-complex-rational-error
(object)
320 :expected-type
'(complex rational
)))
322 (deferr object-not-complex-single-float-error
(object)
325 :expected-type
'(complex single-float
)))
327 (deferr object-not-complex-double-float-error
(object)
330 :expected-type
'(complex double-float
)))
333 (deferr object-not-complex-long-float-error
(object)
336 :expected-type
'(complex long-float
)))
338 (deferr object-not-weak-pointer-error
(object)
341 :expected-type
'weak-pointer
))
343 (deferr object-not-instance-error
(object)
346 :expected-type
'instance
))
348 (deferr object-not-complex-vector-error
(object)
351 :expected-type
'(and vector
(not simple-array
))))
353 ;;;; fetching errorful function name
355 ;;; This flag is used to prevent infinite recursive lossage when
356 ;;; we can't find the caller for some reason.
357 (defvar *finding-name
* nil
)
359 (defun find-caller-name-and-frame ()
361 (values "<error finding caller name -- already finding name>" nil
)
363 (let* ((*finding-name
* t
)
364 (frame (sb!di
:frame-down
(sb!di
:frame-down
(sb!di
:top-frame
))))
365 (name (sb!di
:debug-fun-name
366 (sb!di
:frame-debug-fun frame
))))
367 (sb!di
:flush-frames-above frame
)
370 (values "<error finding caller name -- trapped error>" nil
))
371 (sb!di
:debug-condition
()
372 (values "<error finding caller name -- trapped debug-condition>"
375 (defun find-interrupted-name-and-frame ()
376 (/show0
"entering FIND-INTERRUPTED-NAME-AND-FRAME")
378 (values "<error finding interrupted name -- already finding name>" nil
)
380 (let ((*finding-name
* t
))
381 (/show0
"in ordinary case")
382 (do ((frame (sb!di
:top-frame
) (sb!di
:frame-down frame
)))
384 (/show0
"null frame")
385 (values "<error finding interrupted name -- null frame>" nil
))
386 (/show0
"at head of DO loop")
387 (when (and (sb!di
::compiled-frame-p frame
)
388 (sb!di
::compiled-frame-escaped frame
))
389 (sb!di
:flush-frames-above frame
)
390 (/show0
"returning from within DO loop")
391 (return (values (sb!di
:debug-fun-name
392 (sb!di
:frame-debug-fun frame
))
395 (/show0
"trapped ERROR")
396 (values "<error finding interrupted name -- trapped error>" nil
))
397 (sb!di
:debug-condition
()
398 (/show0
"trapped DEBUG-CONDITION")
399 (values "<error finding interrupted name -- trapped debug-condition>"
403 ;;;; INTERNAL-ERROR signal handler
405 (defun internal-error (context continuable
)
406 (declare (type system-area-pointer context
))
407 (declare (ignore continuable
))
408 (/show0
"entering INTERNAL-ERROR, CONTEXT=..")
410 (infinite-error-protect
411 (/show0
"about to bind ALIEN-CONTEXT")
412 (let ((alien-context (locally
413 (declare (optimize (inhibit-warnings 3)))
414 (sb!alien
:sap-alien context
(* os-context-t
)))))
415 (/show0
"about to bind ERROR-NUMBER and ARGUMENTS")
416 (multiple-value-bind (error-number arguments
)
417 (sb!vm
:internal-error-args alien-context
)
419 ;; There's a limit to how much error reporting we can usefully
420 ;; do before initialization is complete, but try to be a little
421 ;; bit helpful before we die.
422 (/show0
"back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..")
423 (/hexstr error-number
)
424 (/show0
"cold/low ARGUMENTS=..")
426 (unless *cold-init-complete-p
*
427 (%primitive print
"can't recover from error in cold init, halting")
428 (%primitive sb
!c
:halt
))
430 (with-interrupt-bindings
431 (multiple-value-bind (name sb
!debug
:*stack-top-hint
*)
432 (find-interrupted-name-and-frame)
433 (/show0
"back from FIND-INTERRUPTED-NAME")
434 ;; Unblock trap signal here, we unwound the stack and can't return.
435 ;; FIXME: Should we not reset the _entire_ mask, but just
436 ;; restore it to the state before we got the condition?
437 ;; FIXME 2: Signals are currently unblocked in
438 ;; interrupt.c:internal_error before we do stack unwinding, can this
439 ;; introduce a race condition?
441 (sb!unix
::reset-signal-mask
)
442 (let ((fp (int-sap (sb!vm
:context-register alien-context
444 (handler (and (< -
1 error-number
(length *internal-errors
*))
445 (svref *internal-errors
* error-number
))))
446 (cond ((null handler
)
449 "unknown internal error, ~D, args=~S"
452 (mapcar (lambda (sc-offset)
453 (sb!di
::sub-access-debug-var-slot
454 fp sc-offset alien-context
))
456 ((not (functionp handler
))
458 :format-control
"internal error ~D: ~A; args=~S"
462 (mapcar (lambda (sc-offset)
463 (sb!di
::sub-access-debug-var-slot
464 fp sc-offset alien-context
))
467 (funcall handler name fp alien-context arguments
))))))))))
469 (defun control-stack-exhausted-error ()
470 (let ((sb!debug
:*stack-top-hint
* nil
))
471 (infinite-error-protect
472 (format *error-output
*
473 "Control stack guard page temporarily disabled: proceed with caution~%")
474 (error 'control-stack-exhausted
))))
476 ;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so
477 ;;; that we don't need to allocate it when running out of memory. Similarly
478 ;;; we pass the amounts in special variables as there may be multiple threads
479 ;;; running into trouble at the same time. The condition is created by GC-REINIT.
480 (defvar *heap-exhausted-error-condition
*)
481 (defvar *heap-exhausted-error-available-bytes
*)
482 (defvar *heap-exhausted-error-requested-bytes
*)
484 (defun heap-exhausted-error (available requested
)
485 (infinite-error-protect
486 (let ((*heap-exhausted-error-available-bytes
* available
)
487 (*heap-exhausted-error-requested-bytes
* requested
))
488 (error *heap-exhausted-error-condition
*))))
490 (defun undefined-alien-variable-error ()
491 (error 'undefined-alien-variable-error
))
493 (defun undefined-alien-function-error ()
494 (error 'undefined-alien-function-error
))
497 (define-alien-variable current-memory-fault-address long
)
500 (defun memory-fault-error ()
501 (error 'memory-fault-error
502 :address current-memory-fault-address
))
504 ;;; This is SIGTRAP / EXCEPTION_BREAKPOINT that runtime could not deal
505 ;;; with. Prior to Windows we just had a Lisp side handler for
506 ;;; SIGTRAP, but now we need to deal with this portably.
507 (defun unhandled-trap-error (context-sap)
508 (declare (type system-area-pointer context-sap
))
509 (infinite-error-protect
510 (let ((context (sap-alien context-sap
(* os-context-t
))))
511 (error 'breakpoint-error
513 :address
(sap-int (sb!vm
:context-pc context
))))))