/[cmucl]/src/code/interr.lisp
ViewVC logotype

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (show annotations)
Sat Nov 1 22:58:13 1997 UTC (16 years, 5 months ago) by dtc
Branch: MAIN
Changes since 1.30: +29 -1 lines
Improved support for (complex single-float) and (complex double-float)
types. Adds storage classes to the backend for these so they can be
stored in registers or on the stack without consing; new primitive
types etc. Also adds (simple-array (complex {single,double}-float))
array types to avoid consing and speed vectors operations.  All
these changes are conditional on the :complex-float feature. More work
is needed to exploit these changes: improving the type dispatch in the
various function; maybe compiler transforms or more VOPs to handle
common functions inline.
1 ;;; -*- Log: code.log; Package: KERNEL -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.31 1997/11/01 22:58:13 dtc Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Functions and macros to define and deal with internal errors (i.e.
13 ;;; problems that can be signaled from assembler code).
14 ;;;
15 ;;; Written by William Lott.
16 ;;;
17
18 (in-package "KERNEL")
19
20 (export '(infinite-error-protect find-caller-name *maximum-error-depth*))
21
22
23
24 ;;;; Internal Errors
25
26 (defvar *internal-errors*
27 (macrolet ((frob ()
28 (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
29 (frob)))
30
31
32 (eval-when (compile eval)
33
34 (defmacro deferr (name args &rest body)
35 (let* ((rest-pos (position '&rest args))
36 (required (if rest-pos (subseq args 0 rest-pos) args))
37 (fp (gensym))
38 (sigcontext (gensym))
39 (sc-offsets (gensym))
40 (temp (gensym))
41 (fn-name (symbolicate name "-HANDLER")))
42 `(progn
43 (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
44 (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
45 (macrolet ((set-value (var value)
46 (let ((pos (position var ',required)))
47 (unless pos
48 (error "~S isn't one of the required args."
49 var))
50 `(let ((,',temp ,value))
51 (di::sub-set-debug-var-slot
52 ,',fp (nth ,pos ,',sc-offsets)
53 ,',temp ,',sigcontext)
54 (setf ,var ,',temp)))))
55 (let (,@(let ((offset -1))
56 (mapcar #'(lambda (var)
57 `(,var (di::sub-access-debug-var-slot
58 ,fp
59 (nth ,(incf offset)
60 ,sc-offsets)
61 ,sigcontext)))
62 required))
63 ,@(when rest-pos
64 `((,(nth (1+ rest-pos) args)
65 (mapcar #'(lambda (sc-offset)
66 (di::sub-access-debug-var-slot
67 ,fp
68 sc-offset
69 ,sigcontext))
70 (nthcdr ,rest-pos ,sc-offsets))))))
71 ,@body)))
72 (setf (svref *internal-errors* ,(error-number-or-lose name))
73 #',fn-name))))
74
75 ) ; Eval-When (Compile Eval)
76
77
78
79 (deferr unknown-error (&rest args)
80 (error "Unknown error:~{ ~S~})" args))
81
82 (deferr object-not-function-error (object)
83 (error 'type-error
84 :function-name name
85 :datum object
86 :expected-type 'function))
87
88 (deferr object-not-list-error (object)
89 (error 'type-error
90 :function-name name
91 :datum object
92 :expected-type 'list))
93
94 (deferr object-not-bignum-error (object)
95 (error 'type-error
96 :function-name name
97 :datum object
98 :expected-type 'bignum))
99
100 (deferr object-not-ratio-error (object)
101 (error 'type-error
102 :function-name name
103 :datum object
104 :expected-type 'ratio))
105
106 (deferr object-not-single-float-error (object)
107 (error 'type-error
108 :function-name name
109 :datum object
110 :expected-type 'single-float))
111
112 (deferr object-not-double-float-error (object)
113 (error 'type-error
114 :function-name name
115 :datum object
116 :expected-type 'double-float))
117
118 (deferr object-not-simple-string-error (object)
119 (error 'type-error
120 :function-name name
121 :datum object
122 :expected-type 'simple-string))
123
124 (deferr object-not-simple-bit-vector-error (object)
125 (error 'type-error
126 :function-name name
127 :datum object
128 :expected-type 'simple-bit-vector))
129
130 (deferr object-not-simple-vector-error (object)
131 (error 'type-error
132 :function-name name
133 :datum object
134 :expected-type 'simple-vector))
135
136 (deferr object-not-fixnum-error (object)
137 (error 'type-error
138 :function-name name
139 :datum object
140 :expected-type 'fixnum))
141
142 (deferr object-not-function-or-symbol-error (object)
143 (error 'type-error
144 :function-name name
145 :datum object
146 :expected-type '(or function symbol)))
147
148 (deferr object-not-vector-error (object)
149 (error 'type-error
150 :function-name name
151 :datum object
152 :expected-type 'vector))
153
154 (deferr object-not-string-error (object)
155 (error 'type-error
156 :function-name name
157 :datum object
158 :expected-type 'string))
159
160 (deferr object-not-bit-vector-error (object)
161 (error 'type-error
162 :function-name name
163 :datum object
164 :expected-type 'bit-vector))
165
166 (deferr object-not-array-error (object)
167 (error 'type-error
168 :function-name name
169 :datum object
170 :expected-type 'array))
171
172 (deferr object-not-number-error (object)
173 (error 'type-error
174 :function-name name
175 :datum object
176 :expected-type 'number))
177
178 (deferr object-not-rational-error (object)
179 (error 'type-error
180 :function-name name
181 :datum object
182 :expected-type 'rational))
183
184 (deferr object-not-float-error (object)
185 (error 'type-error
186 :function-name name
187 :datum object
188 :expected-type 'float))
189
190 (deferr object-not-real-error (object)
191 (error 'type-error
192 :function-name name
193 :datum object
194 :expected-type 'real))
195
196 (deferr object-not-integer-error (object)
197 (error 'type-error
198 :function-name name
199 :datum object
200 :expected-type 'integer))
201
202 (deferr object-not-cons-error (object)
203 (error 'type-error
204 :function-name name
205 :datum object
206 :expected-type 'cons))
207
208 (deferr object-not-symbol-error (object)
209 (error 'type-error
210 :function-name name
211 :datum object
212 :expected-type 'symbol))
213
214 (deferr undefined-symbol-error (fdefn-or-symbol)
215 (error 'undefined-function
216 :function-name name
217 :name (etypecase fdefn-or-symbol
218 (symbol fdefn-or-symbol)
219 (fdefn (fdefn-name fdefn-or-symbol)))))
220
221 (deferr object-not-coercable-to-function-error (object)
222 (error 'type-error
223 :function-name name
224 :datum object
225 :expected-type 'coercable-to-function))
226
227 (deferr invalid-argument-count-error (nargs)
228 (error 'simple-error
229 :function-name name
230 :format-control "Invalid number of arguments: ~S"
231 :format-arguments (list nargs)))
232
233 (deferr bogus-argument-to-values-list-error (list)
234 (error 'simple-error
235 :function-name name
236 :format-control "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
237 :format-arguments (list list)))
238
239 (deferr unbound-symbol-error (symbol)
240 (error 'unbound-variable :function-name name :name symbol))
241
242 (deferr object-not-base-char-error (object)
243 (error 'type-error
244 :function-name name
245 :datum object
246 :expected-type 'base-char))
247
248 (deferr object-not-sap-error (object)
249 (error 'type-error
250 :function-name name
251 :datum object
252 :expected-type 'system-area-pointer))
253
254 (deferr invalid-unwind-error ()
255 (error 'control-error
256 :function-name name
257 :format-control
258 "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
259
260 (deferr unseen-throw-tag-error (tag)
261 (error 'control-error
262 :function-name name
263 :format-control "Attempt to THROW to a tag that does not exist: ~S"
264 :format-arguments (list tag)))
265
266 (deferr nil-function-returned-error (function)
267 (error 'control-error
268 :function-name name
269 :format-control
270 "Function with declared result type NIL returned:~% ~S"
271 :format-arguments (list function)))
272
273 (deferr division-by-zero-error (this that)
274 (error 'division-by-zero
275 :function-name name
276 :operation 'division
277 :operands (list this that)))
278
279 (deferr object-not-type-error (object type)
280 (error (if (and (%instancep object)
281 (layout-invalid (%instance-layout object)))
282 'layout-invalid
283 'type-error)
284 :function-name name
285 :datum object
286 :expected-type type))
287
288 (deferr layout-invalid-error (object layout)
289 (error 'layout-invalid
290 :function-name name
291 :datum object
292 :expected-type (layout-class layout)))
293
294 (deferr odd-keyword-arguments-error ()
295 (error 'simple-error
296 :function-name name
297 :format-control "Odd number of keyword arguments."))
298
299 (deferr unknown-keyword-argument-error (key)
300 (error 'simple-error
301 :function-name name
302 :format-control "Unknown keyword: ~S"
303 :format-arguments (list key)))
304
305 (deferr invalid-array-index-error (array bound index)
306 (error 'simple-error
307 :function-name name
308 :format-control
309 "Invalid array index, ~D for ~S. Should have been less than ~D"
310 :format-arguments (list index array bound)))
311
312 (deferr object-not-simple-array-error (object)
313 (error 'type-error
314 :function-name name
315 :datum object
316 :expected-type 'simple-array))
317
318 (deferr object-not-signed-byte-32-error (object)
319 (error 'type-error
320 :function-name name
321 :datum object
322 :expected-type '(signed-byte 32)))
323
324 (deferr object-not-unsigned-byte-32-error (object)
325 (error 'type-error
326 :function-name name
327 :datum object
328 :expected-type '(unsigned-byte 32)))
329
330 (deferr object-not-simple-array-unsigned-byte-2-error (object)
331 (error 'type-error
332 :function-name name
333 :datum object
334 :expected-type '(simple-array (unsigned-byte 2) (*))))
335
336 (deferr object-not-simple-array-unsigned-byte-4-error (object)
337 (error 'type-error
338 :function-name name
339 :datum object
340 :expected-type '(simple-array (unsigned-byte 4) (*))))
341
342 (deferr object-not-simple-array-unsigned-byte-8-error (object)
343 (error 'type-error
344 :function-name name
345 :datum object
346 :expected-type '(simple-array (unsigned-byte 8) (*))))
347
348 (deferr object-not-simple-array-unsigned-byte-16-error (object)
349 (error 'type-error
350 :function-name name
351 :datum object
352 :expected-type '(simple-array (unsigned-byte 16) (*))))
353
354 (deferr object-not-simple-array-unsigned-byte-32-error (object)
355 (error 'type-error
356 :function-name name
357 :datum object
358 :expected-type '(simple-array (unsigned-byte 32) (*))))
359
360 #+signed-array
361 (deferr object-not-simple-array-signed-byte-8-error (object)
362 (error 'type-error
363 :function-name name
364 :datum object
365 :expected-type '(simple-array (signed-byte 8) (*))))
366
367 #+signed-array
368 (deferr object-not-simple-array-signed-byte-16-error (object)
369 (error 'type-error
370 :function-name name
371 :datum object
372 :expected-type '(simple-array (signed-byte 16) (*))))
373
374 #+signed-array
375 (deferr object-not-simple-array-signed-byte-30-error (object)
376 (error 'type-error
377 :function-name name
378 :datum object
379 :expected-type '(simple-array (signed-byte 30) (*))))
380
381 #+signed-array
382 (deferr object-not-simple-array-signed-byte-32-error (object)
383 (error 'type-error
384 :function-name name
385 :datum object
386 :expected-type '(simple-array (signed-byte 32) (*))))
387
388 (deferr object-not-simple-array-single-float-error (object)
389 (error 'type-error
390 :function-name name
391 :datum object
392 :expected-type '(simple-array single-float (*))))
393
394 (deferr object-not-simple-array-double-float-error (object)
395 (error 'type-error
396 :function-name name
397 :datum object
398 :expected-type '(simple-array double-float (*))))
399
400 #+complex-float
401 (deferr object-not-simple-array-complex-single-float-error (object)
402 (error 'type-error
403 :function-name name
404 :datum object
405 :expected-type '(simple-array (complex single-float) (*))))
406
407 #+complex-float
408 (deferr object-not-simple-array-complex-double-float-error (object)
409 (error 'type-error
410 :function-name name
411 :datum object
412 :expected-type '(simple-array (complex double-float) (*))))
413
414 (deferr object-not-complex-error (object)
415 (error 'type-error
416 :function-name name
417 :datum object
418 :expected-type 'complex))
419
420 #+complex-float
421 (deferr object-not-complex-single-float-error (object)
422 (error 'type-error
423 :function-name name
424 :datum object
425 :expected-type '(complex single-float)))
426
427 #+complex-float
428 (deferr object-not-complex-double-float-error (object)
429 (error 'type-error
430 :function-name name
431 :datum object
432 :expected-type '(complex double-float)))
433
434 (deferr object-not-weak-pointer-error (object)
435 (error 'type-error
436 :function-name name
437 :datum object
438 :expected-type 'weak-pointer))
439
440 (deferr object-not-instance-error (object)
441 (error 'type-error
442 :function-name name
443 :datum object
444 :expected-type 'instance))
445
446
447
448 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
449 ;;; hyperspace.
450 ;;;
451 (defmacro infinite-error-protect (&rest forms)
452 `(if (and (boundp '*error-system-initialized*)
453 (numberp *current-error-depth*))
454 (let ((*current-error-depth* (1+ *current-error-depth*)))
455 (if (> *current-error-depth* *maximum-error-depth*)
456 (error-error "Help! " *current-error-depth* " nested errors. "
457 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
458 (progn ,@forms)))
459 (%primitive halt)))
460
461 ;;; Track the depth of recursive errors.
462 ;;;
463 (defvar *maximum-error-depth* 10
464 "The maximum number of nested errors allowed. Internal errors are
465 double-counted.")
466 (defvar *current-error-depth* 0 "The current number of nested errors.")
467
468 ;;; These specials are used by ERROR-ERROR to track the success of recovery
469 ;;; attempts.
470 ;;;
471 (defvar *error-error-depth* 0)
472 (defvar *error-throw-up-count* 0)
473
474 ;;; This protects against errors that happen before we run this top-level form.
475 ;;;
476 (defvar *error-system-initialized* t)
477
478 ;;; ERROR-ERROR can be called when the error system is in trouble and needs
479 ;;; to punt fast. Prints a message without using format. If we get into
480 ;;; this recursively, then halt.
481 ;;;
482 (defun error-error (&rest messages)
483 (let ((*error-error-depth* (1+ *error-error-depth*)))
484 (when (> *error-throw-up-count* 50)
485 (%primitive halt)
486 (throw 'lisp::top-level-catcher nil))
487 (case *error-error-depth*
488 (1)
489 (2
490 (lisp::stream-init))
491 (3
492 (incf *error-throw-up-count*)
493 (throw 'lisp::top-level-catcher nil))
494 (t
495 (%primitive halt)
496 (throw 'lisp::top-level-catcher nil)))
497
498 (with-standard-io-syntax
499 (let ((*print-readably* nil))
500 (dolist (item messages) (princ item *terminal-io*))
501 (debug:internal-debug)))))
502
503
504 ;;;; Fetching errorful function name.
505
506 ;;; Used to prevent infinite recursive lossage when we can't find the caller
507 ;;; for some reason.
508 ;;;
509 (defvar *finding-name* nil)
510
511 ;;; FIND-CALLER-NAME -- Internal
512 ;;;
513 (defun find-caller-name ()
514 (if *finding-name*
515 (values "<error finding name>" nil)
516 (handler-case
517 (let* ((*finding-name* t)
518 (frame (di:frame-down (di:frame-down (di:top-frame))))
519 (name (di:debug-function-name
520 (di:frame-debug-function frame))))
521 (di:flush-frames-above frame)
522 (values name frame))
523 (error ()
524 (values "<error finding name>" nil))
525 (di:debug-condition ()
526 (values "<error finding name>" nil)))))
527
528
529 (defun find-interrupted-name ()
530 (if *finding-name*
531 (values "<error finding name>" nil)
532 (handler-case
533 (let ((*finding-name* t))
534 (do ((frame (di:top-frame) (di:frame-down frame)))
535 ((null frame)
536 (values "<error finding name>" nil))
537 (when (and (di::compiled-frame-p frame)
538 (di::compiled-frame-escaped frame))
539 (di:flush-frames-above frame)
540 (return (values (di:debug-function-name
541 (di:frame-debug-function frame))
542 frame)))))
543 (error ()
544 (values "<error finding name>" nil))
545 (di:debug-condition ()
546 (values "<error finding name>" nil)))))
547
548
549 ;;;; internal-error signal handler.
550
551 (defun internal-error (scp continuable)
552 (declare (type system-area-pointer scp) (ignore continuable))
553 (infinite-error-protect
554 (let ((scp (locally
555 (declare (optimize (inhibit-warnings 3)))
556 (alien:sap-alien scp (* unix:sigcontext)))))
557 (multiple-value-bind
558 (error-number arguments)
559 (vm:internal-error-arguments scp)
560 (multiple-value-bind
561 (name debug:*stack-top-hint*)
562 (find-interrupted-name)
563 (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
564 (handler (and (< -1 error-number (length *internal-errors*))
565 (svref *internal-errors* error-number))))
566 (cond ((null handler)
567 (error 'simple-error
568 :function-name name
569 :format-control
570 "Unknown internal error, ~D? args=~S"
571 :format-arguments
572 (list error-number
573 (mapcar #'(lambda (sc-offset)
574 (di::sub-access-debug-var-slot
575 fp sc-offset scp))
576 arguments))))
577 ((not (functionp handler))
578 (error 'simple-error
579 :function-name name
580 :format-control
581 "Internal error ~D: ~A. args=~S"
582 :format-arguments
583 (list error-number
584 handler
585 (mapcar #'(lambda (sc-offset)
586 (di::sub-access-debug-var-slot
587 fp sc-offset scp))
588 arguments))))
589 (t
590 (funcall handler name fp scp arguments)))))))))
591

  ViewVC Help
Powered by ViewVC 1.1.5