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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (show annotations)
Fri Jun 30 18:41:22 2006 UTC (7 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2006-11, snapshot-2006-10, release-19d, release-19d-base, release-19d-pre2, release-19d-pre1, snapshot-2006-07, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19d-branch
Changes since 1.44: +29 -1 lines
This large checkin merges the double-double float support to HEAD.
The merge is from the tag "double-double-irrat-end".  The
double-double branch is now obsolete.

The code should build without double-double support (tested on sparc)
as well as build with double-double support (tested also on sparc).
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.45 2006/06/30 18:41:22 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 #+double-double
449 (deferr object-not-simple-array-complex-double-double-float-error (object)
450 (error 'type-error
451 :function-name name
452 :datum object
453 :expected-type '(simple-array (complex double-double-float) (*))))
454
455 (deferr object-not-complex-error (object)
456 (error 'type-error
457 :function-name name
458 :datum object
459 :expected-type 'complex))
460
461 (deferr object-not-complex-rational-error (object)
462 (error 'type-error
463 :function-name name
464 :datum object
465 :expected-type '(complex rational)))
466
467 (deferr object-not-complex-single-float-error (object)
468 (error 'type-error
469 :function-name name
470 :datum object
471 :expected-type '(complex single-float)))
472
473 (deferr object-not-complex-double-float-error (object)
474 (error 'type-error
475 :function-name name
476 :datum object
477 :expected-type '(complex double-float)))
478
479 #+long-float
480 (deferr object-not-complex-long-float-error (object)
481 (error 'type-error
482 :function-name name
483 :datum object
484 :expected-type '(complex long-float)))
485
486 #+double-double
487 (deferr object-not-complex-double-double-float-error (object)
488 (error 'type-error
489 :function-name name
490 :datum object
491 :expected-type '(complex double-double-float)))
492
493 (deferr object-not-weak-pointer-error (object)
494 (error 'type-error
495 :function-name name
496 :datum object
497 :expected-type 'weak-pointer))
498
499 (deferr object-not-instance-error (object)
500 (error 'type-error
501 :function-name name
502 :datum object
503 :expected-type 'instance))
504
505 #+linkage-table
506 (deferr undefined-foreign-symbol-error (symbol)
507 (error 'simple-program-error
508 :function-name name
509 :format-control "Undefined foreign symbol: ~S"
510 :format-arguments (list symbol)))
511
512
513 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
514 ;;; hyperspace.
515 ;;;
516 (defmacro infinite-error-protect (&rest forms)
517 `(if (and (boundp '*error-system-initialized*)
518 (numberp *current-error-depth*))
519 (let ((*current-error-depth* (1+ *current-error-depth*)))
520 (if (> *current-error-depth* *maximum-error-depth*)
521 (error-error "Help! " *current-error-depth* " nested errors. "
522 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
523 (progn ,@forms)))
524 (%primitive halt)))
525
526 ;;; Track the depth of recursive errors.
527 ;;;
528 (defvar *maximum-error-depth* 10
529 "The maximum number of nested errors allowed. Internal errors are
530 double-counted.")
531 (defvar *current-error-depth* 0 "The current number of nested errors.")
532
533 ;;; These specials are used by ERROR-ERROR to track the success of recovery
534 ;;; attempts.
535 ;;;
536 (defvar *error-error-depth* 0)
537 (defvar *error-throw-up-count* 0)
538
539 ;;; This protects against errors that happen before we run this top-level form.
540 ;;;
541 (defvar *error-system-initialized* t)
542
543 ;;; ERROR-ERROR can be called when the error system is in trouble and needs
544 ;;; to punt fast. Prints a message without using format. If we get into
545 ;;; this recursively, then halt.
546 ;;;
547 (defun error-error (&rest messages)
548 (let ((*error-error-depth* (1+ *error-error-depth*)))
549 (when (> *error-throw-up-count* 50)
550 (%primitive halt)
551 (throw 'lisp::top-level-catcher nil))
552 (case *error-error-depth*
553 (1)
554 (2
555 (lisp::stream-init))
556 (3
557 (incf *error-throw-up-count*)
558 (throw 'lisp::top-level-catcher nil))
559 (t
560 (%primitive halt)
561 (throw 'lisp::top-level-catcher nil)))
562
563 (with-standard-io-syntax
564 (let ((*print-readably* nil))
565 (dolist (item messages) (princ item *terminal-io*))
566 (debug:internal-debug)))))
567
568
569 ;;;; Fetching errorful function name.
570
571 ;;; Used to prevent infinite recursive lossage when we can't find the caller
572 ;;; for some reason.
573 ;;;
574 (defvar *finding-name* nil)
575
576 ;;; FIND-CALLER-NAME -- Internal
577 ;;;
578 (defun find-caller-name ()
579 (if *finding-name*
580 (values "<error finding name>" nil)
581 (handler-case
582 (let* ((*finding-name* t)
583 (frame (di:frame-down (di:frame-down (di:top-frame))))
584 (name (di:debug-function-name
585 (di:frame-debug-function frame))))
586 (di:flush-frames-above frame)
587 (values name frame))
588 (error ()
589 (values "<error finding name>" nil))
590 (di:debug-condition ()
591 (values "<error finding name>" nil)))))
592
593
594 (defun find-interrupted-name ()
595 (if *finding-name*
596 (values "<error finding name>" nil)
597 (handler-case
598 (let ((*finding-name* t))
599 (do ((frame (di:top-frame) (di:frame-down frame)))
600 ((null frame)
601 (values "<error finding name>" nil))
602 (when (and (di::compiled-frame-p frame)
603 (di::compiled-frame-escaped frame))
604 (di:flush-frames-above frame)
605 (return (values (di:debug-function-name
606 (di:frame-debug-function frame))
607 frame)))))
608 (error ()
609 (values "<error finding name>" nil))
610 (di:debug-condition ()
611 (values "<error finding name>" nil)))))
612
613
614 ;;;; internal-error signal handler.
615
616 (defun internal-error (scp continuable)
617 (declare (type system-area-pointer scp) (ignore continuable))
618 (infinite-error-protect
619 (let ((scp (locally
620 (declare (optimize (inhibit-warnings 3)))
621 (alien:sap-alien scp (* unix:sigcontext)))))
622 (multiple-value-bind
623 (error-number arguments)
624 (vm:internal-error-arguments scp)
625 (multiple-value-bind
626 (name debug:*stack-top-hint*)
627 (find-interrupted-name)
628 (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
629 (handler (and (< -1 error-number (length *internal-errors*))
630 (svref *internal-errors* error-number))))
631 (cond ((null handler)
632 (error 'simple-error
633 :function-name name
634 :format-control
635 "Unknown internal error, ~D? args=~S"
636 :format-arguments
637 (list error-number
638 (mapcar #'(lambda (sc-offset)
639 (di::sub-access-debug-var-slot
640 fp sc-offset scp))
641 arguments))))
642 ((not (functionp handler))
643 (error 'simple-error
644 :function-name name
645 :format-control
646 "Internal error ~D: ~A. args=~S"
647 :format-arguments
648 (list error-number
649 handler
650 (mapcar #'(lambda (sc-offset)
651 (di::sub-access-debug-var-slot
652 fp sc-offset scp))
653 arguments))))
654 (t
655 (funcall handler name fp scp arguments)))))))))
656
657 ;;;
658 ;;; Called from C when the yellow control stack guard zone is hit.
659 ;;; The yellow zone is unprotected in the C code prior to calling this
660 ;;; function, to give some room for debugging. The red zone is still
661 ;;; protected.
662 ;;;
663 #+stack-checking
664 (defun yellow-zone-hit ()
665 (let ((debug:*stack-top-hint* nil))
666 (format *error-output*
667 "~2&~@<A control stack overflow has occurred: ~
668 the program has entered the yellow control stack guard zone. ~
669 Please note that you will be returned to the Top-Level if you ~
670 enter the red control stack guard zone while debugging.~@:>~2%")
671 (infinite-error-protect (error 'stack-overflow))))
672
673 ;;;
674 ;;; Called from C when the red control stack guard zone is hit. We
675 ;;; could ABORT here, which would usually take us back to the debugger
676 ;;; or top-level, and add code to the restarts re-protecting the red
677 ;;; zone (which can't be done here because we're still in the red
678 ;;; zone). Using ABORT is too dangerous because users may be using
679 ;;; abort restarts which don't do the necessary re-protecting of the
680 ;;; red zone, and would thus render CMUCL unprotected.
681 ;;;
682 #+stack-checking
683 (defun red-zone-hit ()
684 (format *error-output*
685 "~2&~@<Fatal control stack overflow. You have entered ~
686 the red control stack guard zone while debugging. ~
687 Returning to Top-Level.~@:>~2%")
688 (throw 'lisp::top-level-catcher nil))
689
690 #+heap-overflow-check
691 (defun dynamic-space-overflow-warning-hit ()
692 (let ((debug:*stack-top-hint* nil))
693 ;; Don't reserve any more pages
694 (setf lisp::reserved-heap-pages 0)
695 (format *error-output*
696 "~2&~@<Imminent dynamic space overflow has occurred: ~
697 Only a small amount of dynamic space is available now. ~
698 Please note that you will be returned to the Top-Level without ~
699 warning if you run out of space while debugging.~@:>~%")
700 (infinite-error-protect (error 'heap-overflow))))
701
702 #+heap-overflow-check
703 (defun dynamic-space-overflow-error-hit ()
704 (throw 'lisp::top-level-catcher nil))
705

  ViewVC Help
Powered by ViewVC 1.1.5