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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5