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")
18 (let ((n (1+ (position-if 'stringp sb
!c
:+backend-internal-errors
+
19 :key
#'car
:from-end t
))))
21 (declaim ((simple-vector ,n
) **internal-error-handlers
**))
22 (!defglobal
**internal-error-handlers
**
23 (make-array ,n
:initial-element
0))))))
26 (eval-when (:compile-toplevel
:execute
)
27 (sb!xc
:defmacro deferr
(name args
&rest body
)
28 (multiple-value-bind (llks required optional rest
) (parse-lambda-list args
)
29 (declare (ignore llks
))
31 (let ((max (+ (length required
) (length optional
))))
33 (error "Update (DEFUN INTERNAL-ERROR) for ~D error arguments" max
))))
34 `(setf (svref **internal-error-handlers
** ,(error-number-or-lose name
))
35 (named-lambda ,(string name
) (,@args
)
36 (declare (optimize (sb!c
::verify-arg-count
0)))
37 ,@body
)))) ; EVAL-WHEN
39 (deferr undefined-fun-error
(fdefn-or-symbol)
40 (error 'undefined-function
41 :name
(etypecase fdefn-or-symbol
42 (symbol fdefn-or-symbol
)
43 (fdefn (fdefn-name fdefn-or-symbol
)))))
45 #!+(or arm arm64 x86-64
)
46 (deferr undefined-alien-fun-error
(address)
47 (error 'undefined-alien-function-error
49 (and (integerp address
)
50 (sap-foreign-symbol (int-sap address
)))))
52 #!-
(or arm arm64 x86-64
)
53 (defun undefined-alien-fun-error ()
54 (error 'undefined-alien-function-error
))
56 (deferr invalid-arg-count-error
(nargs)
57 (error 'simple-program-error
58 :format-control
"invalid number of arguments: ~S"
59 :format-arguments
(list nargs
)))
61 (deferr local-invalid-arg-count-error
(nargs name
)
62 (error 'simple-program-error
63 :format-control
"~S called with invalid number of arguments: ~S"
64 :format-arguments
(list name nargs
)))
66 (deferr bogus-arg-to-values-list-error
(list)
67 (error 'simple-type-error
71 "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
72 :format-arguments
(list list
)))
74 (deferr unbound-symbol-error
(symbol)
75 (error 'unbound-variable
:name symbol
))
77 (deferr invalid-unwind-error
()
78 (error 'simple-control-error
80 "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
82 (deferr unseen-throw-tag-error
(tag)
83 (let ((text "attempt to THROW to a tag that does not exist: ~S"))
86 (multiple-value-bind (name frame
)
87 (sb!debug
::find-interrupted-name-and-frame
)
88 ;; KLUDGE: can't inline due to build ordering problem.
89 (declare (notinline sb
!di
:frame-debug-fun
))
90 (let ((down (and (eq name
'sb
!c
::unwind
) ; is this tautological ?
91 (sb!di
:frame-down frame
))))
93 ;; Is this really the canonical way to get a frame name?
94 (let ((prev-frame-name
95 (sb!di
:debug-fun-name
(sb!di
:frame-debug-fun down
))))
96 (when (and (listp prev-frame-name
)
97 (eq (car prev-frame-name
) 'sb
!c
::xep
))
98 (setq prev-frame-name
(second prev-frame-name
)))
99 (cond ((equal prev-frame-name
'(eval return-from
))
100 (setq text
"attempt to RETURN-FROM an exited block: ~S"
101 ;; block name was wrapped in a cons
103 ((equal prev-frame-name
'(eval go
))
104 ;; FIXME: can we reverse-engineer the tag name from
105 ;; the object that was thrown, for a better diagnostic?
106 (setq text
"attempt to GO into an exited tagbody"))))))))
107 (error 'simple-control-error
108 :format-control text
:format-arguments
(list tag
))))
110 (deferr nil-fun-returned-error
(function)
111 (error 'simple-control-error
113 "A function with declared result type NIL returned:~% ~S"
114 :format-arguments
(list function
)))
116 (deferr nil-array-accessed-error
(array)
117 (error 'nil-array-accessed-error
118 :datum array
:expected-type
'(not (array nil
))))
120 (deferr division-by-zero-error
(this that
)
121 (error 'division-by-zero
123 :operands
(list this that
)))
125 (deferr object-not-type-error
(object type
)
126 (if (invalid-array-p object
)
127 (invalid-array-error object
)
128 (error (if (and (%instancep object
)
129 (layout-invalid (%instance-layout object
)))
133 :expected-type type
)))
135 (deferr layout-invalid-error
(object layout
)
136 (error 'layout-invalid
138 :expected-type
(layout-classoid layout
)))
140 (deferr odd-key-args-error
()
141 (error 'simple-program-error
142 :format-control
"odd number of &KEY arguments"))
144 (deferr unknown-key-arg-error
(key-name)
145 (error 'simple-program-error
146 :format-control
"unknown &KEY argument: ~S"
147 :format-arguments
(list key-name
)))
149 ;; TODO: make the arguments (ARRAY INDEX &optional BOUND)
150 ;; and don't need the bound for vectors. Just read it.
151 (deferr invalid-array-index-error
(array bound index
)
152 (invalid-array-index-error array index bound
))
154 (deferr tls-exhausted-error
()
155 ;; There is nothing we can do about it. A number of entries in the
156 ;; tls could be reserved and made available for recovery but since
157 ;; tls indices are never reused it would be kind of silly and
158 ;; without it signalling an error is more than likely to end in a
160 (%primitive print
"Thread local storage exhausted.")
164 ;;; Returns true if number of arguments matches required/optional
165 ;;; arguments handler expects.
166 (defun internal-error-args-ok (arguments handler
)
167 (multiple-value-bind (llks req opt
)
168 (parse-lambda-list (%simple-fun-arglist handler
) :silent t
)
169 (declare (ignore llks
))
170 (let ((n (length arguments
))
172 (n-opt (length opt
)))
173 (and (>= n n-req
) (<= n
(+ n-req n-opt
))))))
175 ;;;; INTERNAL-ERROR signal handler
177 ;;; Backtrace code may want to know the error that caused
178 ;;; interruption, but there are other means to get code interrupted
179 ;;; and inspecting code around PC for the error number may yield wrong
181 (defvar *current-internal-error
* nil
)
183 ;;; This is needed for restarting XEPs, which do not bind anything but
184 ;;; also do not save their own BSP, and we need to discard the
185 ;;; bindings made by the error handling machinery.
186 #!+unwind-to-frame-and-call-vop
187 (defvar *interr-current-bsp
* nil
)
189 (defun internal-error (context continuable
)
190 (declare (type system-area-pointer context
))
191 (declare (ignore continuable
))
192 (/show0
"entering INTERNAL-ERROR, CONTEXT=..")
194 (let (#!+unwind-to-frame-and-call-vop
195 (*interr-current-bsp
*
196 ;; Needs to be done before anything is bound
197 (%primitive sb
!c
:current-binding-pointer
)))
198 (infinite-error-protect
199 (/show0
"about to bind ALIEN-CONTEXT")
200 (let* ((alien-context (sap-alien context
(* os-context-t
)))
201 #!+c-stack-is-control-stack
202 (fp-and-pc (make-array 2 :element-type
'word
)))
203 #!+c-stack-is-control-stack
204 (declare (truly-dynamic-extent fp-and-pc
))
205 #!+c-stack-is-control-stack
206 (setf (aref fp-and-pc
0) (sb!vm
:context-register alien-context sb
!vm
::cfp-offset
)
207 (aref fp-and-pc
1) (sb!sys
:sap-int
(sb!vm
:context-pc alien-context
)))
208 (let (#!+c-stack-is-control-stack
209 (*saved-fp-and-pcs
* (cons fp-and-pc
*saved-fp-and-pcs
*)))
210 #!+c-stack-is-control-stack
211 (declare (truly-dynamic-extent *saved-fp-and-pcs
*))
212 (/show0
"about to bind ERROR-NUMBER and ARGUMENTS"))
213 (multiple-value-bind (error-number arguments
)
214 (sb!vm
:internal-error-args alien-context
)
215 (with-interrupt-bindings
216 (let ((sb!debug
:*stack-top-hint
* (find-interrupted-frame))
217 (*current-internal-error
* error-number
)
218 (fp (int-sap (sb!vm
:context-register alien-context
219 sb
!vm
::cfp-offset
))))
220 (if (and (>= error-number
(length **internal-error-handlers
**))
221 (< error-number
(length sb
!c
:+backend-internal-errors
+)))
223 :datum
(sb!di
::sub-access-debug-var-slot
224 fp
(first arguments
) alien-context
)
226 (car (svref sb
!c
:+backend-internal-errors
+
229 (and (typep error-number
230 '#.
`(mod ,(length **internal-error-handlers
**)))
231 (svref **internal-error-handlers
** error-number
))))
233 ((and (functionp handler
)
234 (internal-error-args-ok arguments handler
))
236 `(sb!di
::sub-access-debug-var-slot
237 fp
(nth ,n arguments
) alien-context
)))
238 (ecase (length arguments
)
239 (0 (funcall handler
))
240 (1 (funcall handler
(arg 0)))
241 (2 (funcall handler
(arg 0) (arg 1)))
242 (3 (funcall handler
(arg 0) (arg 1) (arg 2))))))
243 ((eql handler
0) ; if (DEFERR x) was inadvertently omitted
246 "unknown internal error, ~D, args=~S"
249 (mapcar (lambda (sc-offset)
250 (sb!di
::sub-access-debug-var-slot
251 fp sc-offset alien-context
))
255 :format-control
"internal error ~D: ~A; args=~S"
259 (mapcar (lambda (sc-offset)
260 (sb!di
::sub-access-debug-var-slot
261 fp sc-offset alien-context
))
262 arguments
))))))))))))))
264 (defun control-stack-exhausted-error ()
265 (let ((sb!debug
:*stack-top-hint
* nil
))
266 (infinite-error-protect
267 (format *error-output
*
268 "Control stack guard page temporarily disabled: proceed with caution~%")
269 (error 'control-stack-exhausted
))))
271 (defun binding-stack-exhausted-error ()
272 (let ((sb!debug
:*stack-top-hint
* nil
))
273 (infinite-error-protect
274 (format *error-output
*
275 "Binding stack guard page temporarily disabled: proceed with caution~%")
276 (error 'binding-stack-exhausted
))))
278 (defun alien-stack-exhausted-error ()
279 (let ((sb!debug
:*stack-top-hint
* nil
))
280 (infinite-error-protect
281 (format *error-output
*
282 "Alien stack guard page temporarily disabled: proceed with caution~%")
283 (error 'alien-stack-exhausted
))))
285 ;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so
286 ;;; that we don't need to allocate it when running out of
287 ;;; memory. Similarly we pass the amounts in special variables as
288 ;;; there may be multiple threads running into trouble at the same
289 ;;; time. The condition is created by GC-REINIT.
290 (defvar *heap-exhausted-error-condition
*)
291 (defvar *heap-exhausted-error-available-bytes
*)
292 (defvar *heap-exhausted-error-requested-bytes
*)
294 (defun heap-exhausted-error (available requested
)
295 ;; Double word aligned bytes, can be passed as fixnums to avoid
296 ;; allocating bignums on the C side.
297 (declare (fixnum available requested
))
298 (infinite-error-protect
299 (let ((*heap-exhausted-error-available-bytes
*
300 (ash available sb
!vm
:n-fixnum-tag-bits
))
301 (*heap-exhausted-error-requested-bytes
*
302 (ash requested sb
!vm
:n-fixnum-tag-bits
)))
303 (error *heap-exhausted-error-condition
*))))
305 (defun undefined-alien-variable-error ()
306 (declare (optimize allow-non-returning-tail-call
))
307 (error 'undefined-alien-variable-error
))
310 (define-alien-variable current-memory-fault-address unsigned
)
313 (defun memory-fault-error ()
314 (let ((sb!debug
:*stack-top-hint
* (find-interrupted-frame)))
315 (error 'memory-fault-error
316 :address current-memory-fault-address
)))
318 ;;; This is SIGTRAP / EXCEPTION_BREAKPOINT that runtime could not deal
319 ;;; with. Prior to Windows we just had a Lisp side handler for
320 ;;; SIGTRAP, but now we need to deal with this portably.
321 (defun unhandled-trap-error (context-sap)
322 (declare (type system-area-pointer context-sap
))
323 (infinite-error-protect
324 (let ((context (sap-alien context-sap
(* os-context-t
))))
325 (error 'breakpoint-error
327 :address
(sap-int (sb!vm
:context-pc context
))))))