Newer
Older
;;; -*- Log: code.log; Package: KERNEL -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.47 2007/08/17 14:02:12 rtoy Rel $")
;;; **********************************************************************
;;;
;;; Functions and macros to define and deal with internal errors (i.e.
;;; problems that can be signaled from assembler code).
;;;
;;; Written by William Lott.
;;;
(in-package "KERNEL")
(export '(infinite-error-protect find-caller-name *maximum-error-depth*
#+stack-checking red-zone-hit #+stack-checking yellow-zone-hit
#+heap-overflow-check dynamic-space-overflow-error-hit
#+heap-overflow-check dynamic-space-overflow-warning-hit))
(defvar *internal-errors*
(macrolet ((frob ()
(map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
(frob)))
(defmacro deferr (name args &rest body)
(let* ((rest-pos (position '&rest args))
(required (if rest-pos (subseq args 0 rest-pos) args))
(fp (gensym "FP-"))
(sigcontext (gensym "SIGCONTEXT-"))
(sc-offsets (gensym "SC-OFFSETS-"))
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
(temp (gensym))
(fn-name (symbolicate name "-HANDLER")))
`(progn
(defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
(declare (ignorable name ,fp ,sigcontext ,sc-offsets))
(macrolet ((set-value (var value)
(let ((pos (position var ',required)))
(unless pos
(error "~S isn't one of the required args."
var))
`(let ((,',temp ,value))
(di::sub-set-debug-var-slot
,',fp (nth ,pos ,',sc-offsets)
,',temp ,',sigcontext)
(setf ,var ,',temp)))))
(let (,@(let ((offset -1))
(mapcar #'(lambda (var)
`(,var (di::sub-access-debug-var-slot
,fp
(nth ,(incf offset)
,sc-offsets)
,sigcontext)))
required))
,@(when rest-pos
`((,(nth (1+ rest-pos) args)
(mapcar #'(lambda (sc-offset)
(di::sub-access-debug-var-slot
,fp
sc-offset
,sigcontext))
(nthcdr ,rest-pos ,sc-offsets))))))
,@body)))
(setf (svref *internal-errors* ,(error-number-or-lose name))
#',fn-name))))
) ; Eval-When (Compile Eval)
(deferr unknown-error (&rest args)
(deferr object-not-function-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'function))
(deferr object-not-list-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'list))
(deferr object-not-bignum-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'bignum))
(deferr object-not-ratio-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'ratio))
(deferr object-not-single-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'single-float))
(deferr object-not-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'double-float))
#+long-float
(deferr object-not-long-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'long-float))
#+double-double
(deferr object-not-double-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'double-double-float))
(deferr object-not-simple-string-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'simple-string))
(deferr object-not-simple-bit-vector-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'simple-bit-vector))
(deferr object-not-simple-vector-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'simple-vector))
(deferr object-not-fixnum-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'fixnum))
(deferr object-not-function-or-symbol-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(or function symbol)))
(deferr object-not-vector-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'vector))
(deferr object-not-string-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'string))
(deferr object-not-bit-vector-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'bit-vector))
(deferr object-not-array-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'array))
(deferr object-not-number-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'number))
(deferr object-not-rational-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'rational))
(deferr object-not-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'float))
(deferr object-not-real-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'real))
(deferr object-not-integer-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'integer))
(deferr object-not-cons-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'cons))
(deferr object-not-symbol-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'symbol))
(deferr undefined-symbol-error (fdefn-or-symbol)
(error 'undefined-function
:function-name name
:name (etypecase fdefn-or-symbol
(symbol fdefn-or-symbol)
(fdefn (fdefn-name fdefn-or-symbol)))))
(deferr object-not-coercable-to-function-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'coercable-to-function))
(deferr invalid-argument-count-error (nargs)
(error 'simple-program-error
:function-name name
:format-arguments (list nargs)))
(deferr bogus-argument-to-values-list-error (list)
(error 'simple-type-error
:function-name name
:datum list
:expected-type 'list
:format-control "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
:format-arguments (list list)))
(deferr unbound-symbol-error (symbol)
(error 'unbound-variable :function-name name :name symbol))
(deferr object-not-base-char-error (object)
(error 'type-error
:function-name name
:datum object
(deferr object-not-sap-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'system-area-pointer))
(deferr invalid-unwind-error ()
(error 'simple-control-error
:function-name name
"Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
(deferr unseen-throw-tag-error (tag)
(error 'simple-control-error
:function-name name
:format-control "Attempt to THROW to a tag that does not exist: ~S"
:format-arguments (list tag)))
(deferr nil-function-returned-error (function)
(error 'simple-control-error
:function-name name
"Function with declared result type NIL returned:~% ~S"
:format-arguments (list function)))
(deferr division-by-zero-error (this that)
(error 'division-by-zero
:function-name name
:operation 'division
:operands (list this that)))
(deferr object-not-type-error (object type)
(error (if (and (%instancep object)
(layout-invalid (%instance-layout object)))
'layout-invalid
'type-error)
:function-name name
:datum object
:expected-type type))
(deferr layout-invalid-error (object layout)
(error 'layout-invalid
:function-name name
:datum object
:expected-type (layout-class layout)))
(deferr odd-keyword-arguments-error ()
(error 'simple-program-error
:function-name name
:format-control "Odd number of keyword arguments."))
(deferr unknown-keyword-argument-error (key)
(error 'simple-program-error
:function-name name
:format-arguments (list key)))
(deferr invalid-array-index-error (array bound index)
:function-name name
:datum index
:expected-type `(integer 0 (,bound))
(cond ((zerop bound)
"Invalid array index, ~D for ~S. Array has no elements.")
((minusp index)
"Invalid array index, ~D for ~S. Should have greater than or equal to 0.")
(t
"Invalid array index, ~D for ~S. Should have been less than ~D"))
:format-arguments (list index array bound)))
(deferr object-not-simple-array-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'simple-array))
(deferr object-not-signed-byte-32-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(signed-byte 32)))
(deferr object-not-unsigned-byte-32-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(unsigned-byte 32)))
(deferr object-not-simple-array-unsigned-byte-2-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 2) (*))))
(deferr object-not-simple-array-unsigned-byte-4-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 4) (*))))
(deferr object-not-simple-array-unsigned-byte-8-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 8) (*))))
(deferr object-not-simple-array-unsigned-byte-16-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 16) (*))))
(deferr object-not-simple-array-unsigned-byte-32-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 32) (*))))
(deferr object-not-simple-array-signed-byte-8-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (signed-byte 8) (*))))
(deferr object-not-simple-array-signed-byte-16-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (signed-byte 16) (*))))
(deferr object-not-simple-array-signed-byte-30-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (signed-byte 30) (*))))
(deferr object-not-simple-array-signed-byte-32-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (signed-byte 32) (*))))
(deferr object-not-simple-array-single-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array single-float (*))))
(deferr object-not-simple-array-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array double-float (*))))
#+double-double
(deferr object-not-simple-array-double-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array double-double-float (*))))
(deferr object-not-simple-array-complex-single-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (complex single-float) (*))))
(deferr object-not-simple-array-complex-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (complex double-float) (*))))
(deferr object-not-simple-array-complex-long-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (complex long-float) (*))))
#+double-double
(deferr object-not-simple-array-complex-double-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (complex double-double-float) (*))))
(deferr object-not-complex-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'complex))
(deferr object-not-complex-rational-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(complex rational)))
(deferr object-not-complex-single-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(complex single-float)))
(deferr object-not-complex-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(complex double-float)))
(deferr object-not-complex-long-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(complex long-float)))
#+double-double
(deferr object-not-complex-double-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(complex double-double-float)))
(deferr object-not-weak-pointer-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'weak-pointer))
(deferr object-not-instance-error (object)
(error 'type-error
:datum object
#+linkage-table
(deferr undefined-foreign-symbol-error (symbol)
(error 'simple-program-error
:function-name name
:format-control "Undefined foreign symbol: ~S"
:format-arguments (list symbol)))
;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
;;; hyperspace.
;;;
(defmacro infinite-error-protect (&rest forms)
`(if (and (boundp '*error-system-initialized*)
(numberp *current-error-depth*))
(let ((*current-error-depth* (1+ *current-error-depth*)))
(if (> *current-error-depth* *maximum-error-depth*)
(error-error "Help! " *current-error-depth* " nested errors. "
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
"KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
(progn ,@forms)))
(%primitive halt)))
;;; Track the depth of recursive errors.
;;;
(defvar *maximum-error-depth* 10
"The maximum number of nested errors allowed. Internal errors are
double-counted.")
(defvar *current-error-depth* 0 "The current number of nested errors.")
;;; These specials are used by ERROR-ERROR to track the success of recovery
;;; attempts.
;;;
(defvar *error-error-depth* 0)
(defvar *error-throw-up-count* 0)
;;; This protects against errors that happen before we run this top-level form.
;;;
(defvar *error-system-initialized* t)
;;; ERROR-ERROR can be called when the error system is in trouble and needs
;;; to punt fast. Prints a message without using format. If we get into
;;; this recursively, then halt.
;;;
(defun error-error (&rest messages)
(let ((*error-error-depth* (1+ *error-error-depth*)))
(when (> *error-throw-up-count* 50)
(%primitive halt)
(throw 'lisp::top-level-catcher nil))
(case *error-error-depth*
(1)
(2
(lisp::stream-init))
(3
(incf *error-throw-up-count*)
(throw 'lisp::top-level-catcher nil))
(t
(%primitive halt)
(throw 'lisp::top-level-catcher nil)))
(with-standard-io-syntax
(let ((*print-readably* nil))
(dolist (item messages) (princ item *terminal-io*))
(debug:internal-debug)))))
;;;; Fetching errorful function name.
;;; Used to prevent infinite recursive lossage when we can't find the caller
;;; for some reason.
;;;
(defvar *finding-name* nil)
;;; FIND-CALLER-NAME -- Internal
;;;
(defun find-caller-name ()
(if *finding-name*
(values "<error finding name>" nil)
(handler-case
(let* ((*finding-name* t)
(frame (di:frame-down (di:frame-down (di:top-frame))))
(name (di:debug-function-name
(di:frame-debug-function frame))))
(di:flush-frames-above frame)
(values name frame))
(error ()
(values "<error finding name>" nil))
(di:debug-condition ()
(values "<error finding name>" nil)))))
(defun find-interrupted-name ()
(if *finding-name*
(values "<error finding name>" nil)
(handler-case
(let ((*finding-name* t))
(do ((frame (di:top-frame) (di:frame-down frame)))
((null frame)
(values "<error finding name>" nil))
(when (and (di::compiled-frame-p frame)
(di::compiled-frame-escaped frame))
(di:flush-frames-above frame)
(return (values (di:debug-function-name
(di:frame-debug-function frame))
frame)))))
(error ()
(values "<error finding name>" nil))
(di:debug-condition ()
(values "<error finding name>" nil)))))
;;;; internal-error signal handler.
(defun internal-error (scp continuable)
(declare (type system-area-pointer scp) (ignore continuable))
(infinite-error-protect
(let ((scp (locally
(declare (optimize (inhibit-warnings 3)))
(alien:sap-alien scp (* unix:sigcontext)))))
(multiple-value-bind
(error-number arguments)
(vm:internal-error-arguments scp)
(multiple-value-bind
(name debug:*stack-top-hint*)
(find-interrupted-name)
(let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
(handler (and (< -1 error-number (length *internal-errors*))
(svref *internal-errors* error-number))))
(cond ((null handler)
(error 'simple-error
:function-name name
"Unknown internal error, ~D? args=~S"
:format-arguments
(list error-number
(mapcar #'(lambda (sc-offset)
(di::sub-access-debug-var-slot
fp sc-offset scp))
arguments))))
((not (functionp handler))
(error 'simple-error
:function-name name
"Internal error ~D: ~A. args=~S"
:format-arguments
(list error-number
handler
(mapcar #'(lambda (sc-offset)
(di::sub-access-debug-var-slot
fp sc-offset scp))
arguments))))
(t
(funcall handler name fp scp arguments)))))))))
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
;;;
;;; Called from C when the yellow control stack guard zone is hit.
;;; The yellow zone is unprotected in the C code prior to calling this
;;; function, to give some room for debugging. The red zone is still
;;; protected.
;;;
#+stack-checking
(defun yellow-zone-hit ()
(let ((debug:*stack-top-hint* nil))
(format *error-output*
"~2&~@<A control stack overflow has occurred: ~
the program has entered the yellow control stack guard zone. ~
Please note that you will be returned to the Top-Level if you ~
enter the red control stack guard zone while debugging.~@:>~2%")
(infinite-error-protect (error 'stack-overflow))))
;;;
;;; Called from C when the red control stack guard zone is hit. We
;;; could ABORT here, which would usually take us back to the debugger
;;; or top-level, and add code to the restarts re-protecting the red
;;; zone (which can't be done here because we're still in the red
;;; zone). Using ABORT is too dangerous because users may be using
;;; abort restarts which don't do the necessary re-protecting of the
;;; red zone, and would thus render CMUCL unprotected.
;;;
#+stack-checking
(defun red-zone-hit ()
(format *error-output*
"~2&~@<Fatal control stack overflow. You have entered~%~
the red control stack guard zone while debugging.~%~
Returning to Top-Level.~@:>~2%")
(throw 'lisp::top-level-catcher nil))
#+heap-overflow-check
(defun dynamic-space-overflow-warning-hit ()
(let ((debug:*stack-top-hint* nil))
;; Don't reserve any more pages
(setf lisp::reserved-heap-pages 0)
(format *error-output*
"~2&~@<Imminent dynamic space overflow has occurred:~%~
Only a small amount of dynamic space is available now.~%~
Please note that you will be returned to the Top-Level without~%~
warning if you run out of space while debugging.~@:>~%")
(infinite-error-protect (error 'heap-overflow))))
#+heap-overflow-check
(defun dynamic-space-overflow-error-hit ()
(throw 'lisp::top-level-catcher nil))