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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44.6.1.2.2 - (show annotations)
Sat Jun 17 02:59:42 2006 UTC (7 years, 10 months ago) by rtoy
Branch: double-double-array-branch
Changes since 1.44.6.1.2.1: +8 -1 lines
Initial support for (complex double-double-float).

Use boot-2006-06-2-cross-dd* to cross compile this change (along with
the simple-array double-double-float change).
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.44.6.1.2.2 2006/06/17 02:59:42 rtoy 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 #+stack-checking red-zone-hit #+stack-checking yellow-zone-hit
22 #+heap-overflow-check dynamic-space-overflow-error-hit
23 #+heap-overflow-check dynamic-space-overflow-warning-hit))
24
25
26
27 ;;;; Internal Errors
28
29 (defvar *internal-errors*
30 (macrolet ((frob ()
31 (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
32 (frob)))
33
34
35 (eval-when (compile eval)
36
37 (defmacro deferr (name args &rest body)
38 (let* ((rest-pos (position '&rest args))
39 (required (if rest-pos (subseq args 0 rest-pos) args))
40 (fp (gensym))
41 (sigcontext (gensym))
42 (sc-offsets (gensym))
43 (temp (gensym))
44 (fn-name (symbolicate name "-HANDLER")))
45 `(progn
46 (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
47 (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
48 (macrolet ((set-value (var value)
49 (let ((pos (position var ',required)))
50 (unless pos
51 (error "~S isn't one of the required args."
52 var))
53 `(let ((,',temp ,value))
54 (di::sub-set-debug-var-slot
55 ,',fp (nth ,pos ,',sc-offsets)
56 ,',temp ,',sigcontext)
57 (setf ,var ,',temp)))))
58 (let (,@(let ((offset -1))
59 (mapcar #'(lambda (var)
60 `(,var (di::sub-access-debug-var-slot
61 ,fp
62 (nth ,(incf offset)
63 ,sc-offsets)
64 ,sigcontext)))
65 required))
66 ,@(when rest-pos
67 `((,(nth (1+ rest-pos) args)
68 (mapcar #'(lambda (sc-offset)
69 (di::sub-access-debug-var-slot
70 ,fp
71 sc-offset
72 ,sigcontext))
73 (nthcdr ,rest-pos ,sc-offsets))))))
74 ,@body)))
75 (setf (svref *internal-errors* ,(error-number-or-lose name))
76 #',fn-name))))
77
78 ) ; Eval-When (Compile Eval)
79
80
81
82 (deferr unknown-error (&rest args)
83 (error "Unknown error:~{ ~S~})" args))
84
85 (deferr object-not-function-error (object)
86 (error 'type-error
87 :function-name name
88 :datum object
89 :expected-type 'function))
90
91 (deferr object-not-list-error (object)
92 (error 'type-error
93 :function-name name
94 :datum object
95 :expected-type 'list))
96
97 (deferr object-not-bignum-error (object)
98 (error 'type-error
99 :function-name name
100 :datum object
101 :expected-type 'bignum))
102
103 (deferr object-not-ratio-error (object)
104 (error 'type-error
105 :function-name name
106 :datum object
107 :expected-type 'ratio))
108
109 (deferr object-not-single-float-error (object)
110 (error 'type-error
111 :function-name name
112 :datum object
113 :expected-type 'single-float))
114
115 (deferr object-not-double-float-error (object)
116 (error 'type-error
117 :function-name name
118 :datum object
119 :expected-type 'double-float))
120
121 #+long-float
122 (deferr object-not-long-float-error (object)
123 (error 'type-error
124 :function-name name
125 :datum object
126 :expected-type 'long-float))
127
128 #+double-double
129 (deferr object-not-double-double-float-error (object)
130 (error 'type-error
131 :function-name name
132 :datum object
133 :expected-type 'double-double-float))
134
135 (deferr object-not-simple-string-error (object)
136 (error 'type-error
137 :function-name name
138 :datum object
139 :expected-type 'simple-string))
140
141 (deferr object-not-simple-bit-vector-error (object)
142 (error 'type-error
143 :function-name name
144 :datum object
145 :expected-type 'simple-bit-vector))
146
147 (deferr object-not-simple-vector-error (object)
148 (error 'type-error
149 :function-name name
150 :datum object
151 :expected-type 'simple-vector))
152
153 (deferr object-not-fixnum-error (object)
154 (error 'type-error
155 :function-name name
156 :datum object
157 :expected-type 'fixnum))
158
159 (deferr object-not-function-or-symbol-error (object)
160 (error 'type-error
161 :function-name name
162 :datum object
163 :expected-type '(or function symbol)))
164
165 (deferr object-not-vector-error (object)
166 (error 'type-error
167 :function-name name
168 :datum object
169 :expected-type 'vector))
170
171 (deferr object-not-string-error (object)
172 (error 'type-error
173 :function-name name
174 :datum object
175 :expected-type 'string))
176
177 (deferr object-not-bit-vector-error (object)
178 (error 'type-error
179 :function-name name
180 :datum object
181 :expected-type 'bit-vector))
182
183 (deferr object-not-array-error (object)
184 (error 'type-error
185 :function-name name
186 :datum object
187 :expected-type 'array))
188
189 (deferr object-not-number-error (object)
190 (error 'type-error
191 :function-name name
192 :datum object
193 :expected-type 'number))
194
195 (deferr object-not-rational-error (object)
196 (error 'type-error
197 :function-name name
198 :datum object
199 :expected-type 'rational))
200
201 (deferr object-not-float-error (object)
202 (error 'type-error
203 :function-name name
204 :datum object
205 :expected-type 'float))
206
207 (deferr object-not-real-error (object)
208 (error 'type-error
209 :function-name name
210 :datum object
211 :expected-type 'real))
212
213 (deferr object-not-integer-error (object)
214 (error 'type-error
215 :function-name name
216 :datum object
217 :expected-type 'integer))
218
219 (deferr object-not-cons-error (object)
220 (error 'type-error
221 :function-name name
222 :datum object
223 :expected-type 'cons))
224
225 (deferr object-not-symbol-error (object)
226 (error 'type-error
227 :function-name name
228 :datum object
229 :expected-type 'symbol))
230
231 (deferr undefined-symbol-error (fdefn-or-symbol)
232 (error 'undefined-function
233 :function-name name
234 :name (etypecase fdefn-or-symbol
235 (symbol fdefn-or-symbol)
236 (fdefn (fdefn-name fdefn-or-symbol)))))
237
238 (deferr object-not-coercable-to-function-error (object)
239 (error 'type-error
240 :function-name name
241 :datum object
242 :expected-type 'coercable-to-function))
243
244 (deferr invalid-argument-count-error (nargs)
245 (error 'simple-program-error
246 :function-name name
247 :format-control "Invalid number of arguments: ~S"
248 :format-arguments (list nargs)))
249
250 (deferr bogus-argument-to-values-list-error (list)
251 (error 'simple-type-error
252 :function-name name
253 :datum list
254 :expected-type 'list
255 :format-control "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
256 :format-arguments (list list)))
257
258 (deferr unbound-symbol-error (symbol)
259 (error 'unbound-variable :function-name name :name symbol))
260
261 (deferr object-not-base-char-error (object)
262 (error 'type-error
263 :function-name name
264 :datum object
265 :expected-type 'base-char))
266
267 (deferr object-not-sap-error (object)
268 (error 'type-error
269 :function-name name
270 :datum object
271 :expected-type 'system-area-pointer))
272
273 (deferr invalid-unwind-error ()
274 (error 'simple-control-error
275 :function-name name
276 :format-control
277 "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
278
279 (deferr unseen-throw-tag-error (tag)
280 (error 'simple-control-error
281 :function-name name
282 :format-control "Attempt to THROW to a tag that does not exist: ~S"
283 :format-arguments (list tag)))
284
285 (deferr nil-function-returned-error (function)
286 (error 'simple-control-error
287 :function-name name
288 :format-control
289 "Function with declared result type NIL returned:~% ~S"
290 :format-arguments (list function)))
291
292 (deferr division-by-zero-error (this that)
293 (error 'division-by-zero
294 :function-name name
295 :operation 'division
296 :operands (list this that)))
297
298 (deferr object-not-type-error (object type)
299 (error (if (and (%instancep object)
300 (layout-invalid (%instance-layout object)))
301 'layout-invalid
302 'type-error)
303 :function-name name
304 :datum object
305 :expected-type type))
306
307 (deferr layout-invalid-error (object layout)
308 (error 'layout-invalid
309 :function-name name
310 :datum object
311 :expected-type (layout-class layout)))
312
313 (deferr odd-keyword-arguments-error ()
314 (error 'simple-program-error
315 :function-name name
316 :format-control "Odd number of keyword arguments."))
317
318 (deferr unknown-keyword-argument-error (key)
319 (error 'simple-program-error
320 :function-name name
321 :format-control "Unknown keyword: ~S"
322 :format-arguments (list key)))
323
324 (deferr invalid-array-index-error (array bound index)
325 (error 'type-error
326 :function-name name
327 :datum index
328 :expected-type `(integer 0 (,bound))
329 :format-control
330 (cond ((zerop bound)
331 "Invalid array index, ~D for ~S. Array has no elements.")
332 ((minusp index)
333 "Invalid array index, ~D for ~S. Should have greater than or equal to 0.")
334 (t
335 "Invalid array index, ~D for ~S. Should have been less than ~D"))
336 :format-arguments (list index array bound)))
337
338 (deferr object-not-simple-array-error (object)
339 (error 'type-error
340 :function-name name
341 :datum object
342 :expected-type 'simple-array))
343
344 (deferr object-not-signed-byte-32-error (object)
345 (error 'type-error
346 :function-name name
347 :datum object
348 :expected-type '(signed-byte 32)))
349
350 (deferr object-not-unsigned-byte-32-error (object)
351 (error 'type-error
352 :function-name name
353 :datum object
354 :expected-type '(unsigned-byte 32)))
355
356 (deferr object-not-simple-array-unsigned-byte-2-error (object)
357 (error 'type-error
358 :function-name name
359 :datum object
360 :expected-type '(simple-array (unsigned-byte 2) (*))))
361
362 (deferr object-not-simple-array-unsigned-byte-4-error (object)
363 (error 'type-error
364 :function-name name
365 :datum object
366 :expected-type '(simple-array (unsigned-byte 4) (*))))
367
368 (deferr object-not-simple-array-unsigned-byte-8-error (object)
369 (error 'type-error
370 :function-name name
371 :datum object
372 :expected-type '(simple-array (unsigned-byte 8) (*))))
373
374 (deferr object-not-simple-array-unsigned-byte-16-error (object)
375 (error 'type-error
376 :function-name name
377 :datum object
378 :expected-type '(simple-array (unsigned-byte 16) (*))))
379
380 (deferr object-not-simple-array-unsigned-byte-32-error (object)
381 (error 'type-error
382 :function-name name
383 :datum object
384 :expected-type '(simple-array (unsigned-byte 32) (*))))
385
386 (deferr object-not-simple-array-signed-byte-8-error (object)
387 (error 'type-error
388 :function-name name
389 :datum object
390 :expected-type '(simple-array (signed-byte 8) (*))))
391
392 (deferr object-not-simple-array-signed-byte-16-error (object)
393 (error 'type-error
394 :function-name name
395 :datum object
396 :expected-type '(simple-array (signed-byte 16) (*))))
397
398 (deferr object-not-simple-array-signed-byte-30-error (object)
399 (error 'type-error
400 :function-name name
401 :datum object
402 :expected-type '(simple-array (signed-byte 30) (*))))
403
404 (deferr object-not-simple-array-signed-byte-32-error (object)
405 (error 'type-error
406 :function-name name
407 :datum object
408 :expected-type '(simple-array (signed-byte 32) (*))))
409
410 (deferr object-not-simple-array-single-float-error (object)
411 (error 'type-error
412 :function-name name
413 :datum object
414 :expected-type '(simple-array single-float (*))))
415
416 (deferr object-not-simple-array-double-float-error (object)
417 (error 'type-error
418 :function-name name
419 :datum object
420 :expected-type '(simple-array double-float (*))))
421
422 #+double-double
423 (deferr object-not-simple-array-double-double-float-error (object)
424 (error 'type-error
425 :function-name name
426 :datum object
427 :expected-type '(simple-array double-double-float (*))))
428
429 (deferr object-not-simple-array-complex-single-float-error (object)
430 (error 'type-error
431 :function-name name
432 :datum object
433 :expected-type '(simple-array (complex single-float) (*))))
434
435 (deferr object-not-simple-array-complex-double-float-error (object)
436 (error 'type-error
437 :function-name name
438 :datum object
439 :expected-type '(simple-array (complex double-float) (*))))
440
441 #+long-float
442 (deferr object-not-simple-array-complex-long-float-error (object)
443 (error 'type-error
444 :function-name name
445 :datum object
446 :expected-type '(simple-array (complex long-float) (*))))
447
448 (deferr object-not-complex-error (object)
449 (error 'type-error
450 :function-name name
451 :datum object
452 :expected-type 'complex))
453
454 (deferr object-not-complex-rational-error (object)
455 (error 'type-error
456 :function-name name
457 :datum object
458 :expected-type '(complex rational)))
459
460 (deferr object-not-complex-single-float-error (object)
461 (error 'type-error
462 :function-name name
463 :datum object
464 :expected-type '(complex single-float)))
465
466 (deferr object-not-complex-double-float-error (object)
467 (error 'type-error
468 :function-name name
469 :datum object
470 :expected-type '(complex double-float)))
471
472 #+long-float
473 (deferr object-not-complex-long-float-error (object)
474 (error 'type-error
475 :function-name name
476 :datum object
477 :expected-type '(complex long-float)))
478
479 #+double-double
480 (deferr object-not-complex-double-double-float-error (object)
481 (error 'type-error
482 :function-name name
483 :datum object
484 :expected-type '(complex double-double-float)))
485
486 (deferr object-not-weak-pointer-error (object)
487 (error 'type-error
488 :function-name name
489 :datum object
490 :expected-type 'weak-pointer))
491
492 (deferr object-not-instance-error (object)
493 (error 'type-error
494 :function-name name
495 :datum object
496 :expected-type 'instance))
497
498 #+linkage-table
499 (deferr undefined-foreign-symbol-error (symbol)
500 (error 'simple-program-error
501 :function-name name
502 :format-control "Undefined foreign symbol: ~S"
503 :format-arguments (list symbol)))
504
505
506 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
507 ;;; hyperspace.
508 ;;;
509 (defmacro infinite-error-protect (&rest forms)
510 `(if (and (boundp '*error-system-initialized*)
511 (numberp *current-error-depth*))
512 (let ((*current-error-depth* (1+ *current-error-depth*)))
513 (if (> *current-error-depth* *maximum-error-depth*)
514 (error-error "Help! " *current-error-depth* " nested errors. "
515 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
516 (progn ,@forms)))
517 (%primitive halt)))
518
519 ;;; Track the depth of recursive errors.
520 ;;;
521 (defvar *maximum-error-depth* 10
522 "The maximum number of nested errors allowed. Internal errors are
523 double-counted.")
524 (defvar *current-error-depth* 0 "The current number of nested errors.")
525
526 ;;; These specials are used by ERROR-ERROR to track the success of recovery
527 ;;; attempts.
528 ;;;
529 (defvar *error-error-depth* 0)
530 (defvar *error-throw-up-count* 0)
531
532 ;;; This protects against errors that happen before we run this top-level form.
533 ;;;
534 (defvar *error-system-initialized* t)
535
536 ;;; ERROR-ERROR can be called when the error system is in trouble and needs
537 ;;; to punt fast. Prints a message without using format. If we get into
538 ;;; this recursively, then halt.
539 ;;;
540 (defun error-error (&rest messages)
541 (let ((*error-error-depth* (1+ *error-error-depth*)))
542 (when (> *error-throw-up-count* 50)
543 (%primitive halt)
544 (throw 'lisp::top-level-catcher nil))
545 (case *error-error-depth*
546 (1)
547 (2
548 (lisp::stream-init))
549 (3
550 (incf *error-throw-up-count*)
551 (throw 'lisp::top-level-catcher nil))
552 (t
553 (%primitive halt)
554 (throw 'lisp::top-level-catcher nil)))
555
556 (with-standard-io-syntax
557 (let ((*print-readably* nil))
558 (dolist (item messages) (princ item *terminal-io*))
559 (debug:internal-debug)))))
560
561
562 ;;;; Fetching errorful function name.
563
564 ;;; Used to prevent infinite recursive lossage when we can't find the caller
565 ;;; for some reason.
566 ;;;
567 (defvar *finding-name* nil)
568
569 ;;; FIND-CALLER-NAME -- Internal
570 ;;;
571 (defun find-caller-name ()
572 (if *finding-name*
573 (values "<error finding name>" nil)
574 (handler-case
575 (let* ((*finding-name* t)
576 (frame (di:frame-down (di:frame-down (di:top-frame))))
577 (name (di:debug-function-name
578 (di:frame-debug-function frame))))
579 (di:flush-frames-above frame)
580 (values name frame))
581 (error ()
582 (values "<error finding name>" nil))
583 (di:debug-condition ()
584 (values "<error finding name>" nil)))))
585
586
587 (defun find-interrupted-name ()
588 (if *finding-name*
589 (values "<error finding name>" nil)
590 (handler-case
591 (let ((*finding-name* t))
592 (do ((frame (di:top-frame) (di:frame-down frame)))
593 ((null frame)
594 (values "<error finding name>" nil))
595 (when (and (di::compiled-frame-p frame)
596 (di::compiled-frame-escaped frame))
597 (di:flush-frames-above frame)
598 (return (values (di:debug-function-name
599 (di:frame-debug-function frame))
600 frame)))))
601 (error ()
602 (values "<error finding name>" nil))
603 (di:debug-condition ()
604 (values "<error finding name>" nil)))))
605
606
607 ;;;; internal-error signal handler.
608
609 (defun internal-error (scp continuable)
610 (declare (type system-area-pointer scp) (ignore continuable))
611 (infinite-error-protect
612 (let ((scp (locally
613 (declare (optimize (inhibit-warnings 3)))
614 (alien:sap-alien scp (* unix:sigcontext)))))
615 (multiple-value-bind
616 (error-number arguments)
617 (vm:internal-error-arguments scp)
618 (multiple-value-bind
619 (name debug:*stack-top-hint*)
620 (find-interrupted-name)
621 (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
622 (handler (and (< -1 error-number (length *internal-errors*))
623 (svref *internal-errors* error-number))))
624 (cond ((null handler)
625 (error 'simple-error
626 :function-name name
627 :format-control
628 "Unknown internal error, ~D? args=~S"
629 :format-arguments
630 (list error-number
631 (mapcar #'(lambda (sc-offset)
632 (di::sub-access-debug-var-slot
633 fp sc-offset scp))
634 arguments))))
635 ((not (functionp handler))
636 (error 'simple-error
637 :function-name name
638 :format-control
639 "Internal error ~D: ~A. args=~S"
640 :format-arguments
641 (list error-number
642 handler
643 (mapcar #'(lambda (sc-offset)
644 (di::sub-access-debug-var-slot
645 fp sc-offset scp))
646 arguments))))
647 (t
648 (funcall handler name fp scp arguments)))))))))
649
650 ;;;
651 ;;; Called from C when the yellow control stack guard zone is hit.
652 ;;; The yellow zone is unprotected in the C code prior to calling this
653 ;;; function, to give some room for debugging. The red zone is still
654 ;;; protected.
655 ;;;
656 #+stack-checking
657 (defun yellow-zone-hit ()
658 (let ((debug:*stack-top-hint* nil))
659 (format *error-output*
660 "~2&~@<A control stack overflow has occurred: ~
661 the program has entered the yellow control stack guard zone. ~
662 Please note that you will be returned to the Top-Level if you ~
663 enter the red control stack guard zone while debugging.~@:>~2%")
664 (infinite-error-protect (error 'stack-overflow))))
665
666 ;;;
667 ;;; Called from C when the red control stack guard zone is hit. We
668 ;;; could ABORT here, which would usually take us back to the debugger
669 ;;; or top-level, and add code to the restarts re-protecting the red
670 ;;; zone (which can't be done here because we're still in the red
671 ;;; zone). Using ABORT is too dangerous because users may be using
672 ;;; abort restarts which don't do the necessary re-protecting of the
673 ;;; red zone, and would thus render CMUCL unprotected.
674 ;;;
675 #+stack-checking
676 (defun red-zone-hit ()
677 (format *error-output*
678 "~2&~@<Fatal control stack overflow. You have entered ~
679 the red control stack guard zone while debugging. ~
680 Returning to Top-Level.~@:>~2%")
681 (throw 'lisp::top-level-catcher nil))
682
683 #+heap-overflow-check
684 (defun dynamic-space-overflow-warning-hit ()
685 (let ((debug:*stack-top-hint* nil))
686 ;; Don't reserve any more pages
687 (setf lisp::reserved-heap-pages 0)
688 (format *error-output*
689 "~2&~@<Imminent dynamic space overflow has occurred: ~
690 Only a small amount of dynamic space is available now. ~
691 Please note that you will be returned to the Top-Level without ~
692 warning if you run out of space while debugging.~@:>~%")
693 (infinite-error-protect (error 'heap-overflow))))
694
695 #+heap-overflow-check
696 (defun dynamic-space-overflow-error-hit ()
697 (throw 'lisp::top-level-catcher nil))
698

  ViewVC Help
Powered by ViewVC 1.1.5