src/code/cold-error.lisp

   1 ;;;; miscellaneous error stuff that needs to be in the cold load
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 (!defvar *break-on-signals* nil
  15   #!+sb-doc
  16   "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
  17    enter the debugger prior to signalling that condition.")
  18
  19 (defun maybe-break-on-signal (condition)
  20   (let ((old-bos *break-on-signals*)
  21         (bos-actually-breaking nil))
  22     (restart-case
  23         (let ((break-on-signals *break-on-signals*)
  24               (*break-on-signals* nil))
  25           ;; The rebinding encloses the TYPEP so that a bogus
  26           ;; type specifier will not lead to infinite recursion when
  27           ;; TYPEP fails.
  28           (when (typep condition break-on-signals)
  29             (setf bos-actually-breaking t)
  30             (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
  31                     (now rebound to NIL)."
  32                    condition)))
  33       ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the
  34       ;; way out.
  35       ;;
  36       ;; (e.g.: Consider a long compilation. After a failed compile
  37       ;; the user sets *BREAK-ON-SIGNALS* to T, and select the
  38       ;; RECOMPILE restart. Once the user diagnoses and fixes the
  39       ;; problem, he selects RECOMPILE again... and discovers that
  40       ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape,
  41       ;; unless we provide this restart.)
  42       (reassign (new-value)
  43         :report
  44         (lambda (stream)
  45           (format stream
  46                   (if bos-actually-breaking
  47                       "Return from BREAK and assign a new value to ~
  48                        *BREAK-ON-SIGNALS*."
  49                       "Assign a new value to *BREAK-ON-SIGNALS* and ~
  50                        continue with signal handling.")))
  51         :interactive
  52         (lambda ()
  53           (let (new-value)
  54             (loop
  55               (format *query-io*
  56                       "Enter new value for *BREAK-ON-SIGNALS*. ~
  57                        Current value is ~S.~%~
  58                        > "
  59                       old-bos)
  60               (force-output *query-io*)
  61               (let ((*break-on-signals* nil))
  62                 (setf new-value (eval (read *query-io*)))
  63                 (if (typep new-value 'type-specifier)
  64                     (return)
  65                     (format *query-io*
  66                             "~S is not a valid value for *BREAK-ON-SIGNALS* ~
  67                              (must be a type-specifier).~%"
  68                             new-value))))
  69             (list new-value)))
  70         (setf *break-on-signals* new-value)))))
  71
  72 (defun signal (datum &rest arguments)
  73   #!+sb-doc
  74   "Invokes the signal facility on a condition formed from DATUM and
  75    ARGUMENTS. If the condition is not handled, NIL is returned. If
  76    (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
  77    before any signalling is done."
  78   (declare (explicit-check))
  79   (%signal (apply #'coerce-to-condition datum 'simple-condition 'signal arguments)))
  80 (defun %signal (condition)
  81   (let ((handler-clusters *handler-clusters*)
  82         (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%signal)))
  83     (when *break-on-signals*
  84       (maybe-break-on-signal condition))
  85     (do ((cluster (pop handler-clusters) (pop handler-clusters)))
  86         ((null cluster)
  87          nil)
  88       ;; Remove CLUSTER from *HANDLER-CLUSTERS*: if a condition is
  89       ;; signaled in either the type test, i.e. (the function (car
  90       ;; handler)), or the handler, (the function (cdr handler)), the
  91       ;; recursive SIGNAL call should not consider CLUSTER as doing
  92       ;; would lead to infinite recursive SIGNAL calls.
  93       (let ((*handler-clusters* handler-clusters))
  94         (dolist (handler cluster)
  95           (macrolet ((cast-to-fun (f possibly-symbolp)
  96                        ;; For efficiency the cases are tested in this order:
  97                        ;;  - FUNCTIONP is just a lowtag test
  98                        ;;  - FDEFN-P is a lowtag + widetag.
  99                        ;; Avoiding a SYMBOLP test is fine because
 100                        ;; SYMBOL-FUNCTION rejects bogosity anyway.
 101                        `(let ((f ,f))
 102                           (cond ((functionp f) f)
 103                                 (,(if possibly-symbolp `(fdefn-p f) 't)
 104                                   (sb!c:safe-fdefn-fun f))
 105                                 ,@(if possibly-symbolp
 106                                       `((t (symbol-function f))))))))
 107             (let ((test (car (truly-the cons handler))))
 108               (when (if (%instancep test) ; a condition classoid cell
 109                         (classoid-cell-typep test condition)
 110                         (funcall (cast-to-fun test nil) condition))
 111                 (funcall (cast-to-fun (cdr handler) t) condition)))))))))
 112
 113 ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
 114
 115 ;;; counts of nested errors (with internal errors double-counted)
 116 (defvar *maximum-error-depth*) ; this gets set to 10 in !COLD-INIT
 117 (!defvar *current-error-depth* 0)
 118
 119 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out
 120 ;;; of hyperspace.
 121 (defmacro infinite-error-protect (&rest forms)
 122   `(let ((*current-error-depth* (infinite-error-protector)))
 123      (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
 124      ;; This is almost totally unhelpful. Running with #!+sb-show does not mean
 125      ;; that you care to see an additional 16K characters of output
 126      ;; each time this macro is used when no error is actually happening.
 127      #| #!+sb-show (sb!debug:print-backtrace :count 8) ; arbitrary truncation |#
 128      ,@forms))
 129
 130 ;;; a helper function for INFINITE-ERROR-PROTECT
 131 (defun infinite-error-protector ()
 132   (/show0 "entering INFINITE-ERROR-PROTECTOR, *CURRENT-ERROR-DEPTH*=..")
 133   (/hexstr *current-error-depth*)
 134   ;; *MAXIMUM-ERROR-DEPTH* is not bound during cold-init, and testing BOUNDP
 135   ;; is superfluous since REALP will return false either way.
 136   (let ((cur (locally (declare (optimize (safety 0))) *current-error-depth*))
 137         (max (locally (declare (optimize (safety 0))) *maximum-error-depth*)))
 138     (cond ((or (not (fixnump cur)) (not (fixnump max)))
 139            (%primitive print "Argh! corrupted error depth, halting")
 140            (%primitive sb!c:halt))
 141           ((> cur max)
 142            (/show0 "*MAXIMUM-ERROR-DEPTH*=..")
 143            (/hexstr max)
 144            (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
 145            (sb!impl::error-error "Help! "
 146                         cur
 147                         " nested errors. "
 148                         "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded."))
 149           (t
 150            (/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
 151            (1+ *current-error-depth*)))))
 152
 153 (defun error (datum &rest arguments)
 154   #!+sb-doc
 155   "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
 156   If the condition is not handled, the debugger is invoked."
 157   (/show0 "entering ERROR, argument list=..")
 158   (/hexstr arguments)
 159
 160   (/show0 "cold-printing ERROR arguments one by one..")
 161   #!+sb-show (dolist (argument arguments)
 162                (sb!impl::cold-print argument))
 163   (/show0 "done cold-printing ERROR arguments")
 164
 165   (infinite-error-protect
 166    (let ((condition (apply #'coerce-to-condition datum 'simple-error 'error
 167                            arguments))
 168          (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'error)))
 169      (/show0 "signalling CONDITION from within ERROR")
 170      (%signal condition)
 171      (/show0 "done signalling CONDITION within ERROR")
 172      (invoke-debugger condition))))
 173
 174 (defun cerror (continue-string datum &rest arguments)
 175   (infinite-error-protect
 176     (with-simple-restart
 177         (continue "~A" (apply #'format nil continue-string arguments))
 178       (let ((condition (apply #'coerce-to-condition datum
 179                               'simple-error 'cerror arguments)))
 180         (with-condition-restarts condition (list (find-restart 'continue))
 181           (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'cerror)))
 182             (%signal condition)
 183             (invoke-debugger condition))))))
 184   nil)
 185
 186 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
 187 ;;; we can use it in system code (e.g. in SIGINT handling) without
 188 ;;; messing up --disable-debugger mode (which works by setting
 189 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
 190 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
 191 (defun %break (what &optional (datum "break") &rest arguments)
 192   (infinite-error-protect
 193    (with-simple-restart (continue "Return from ~S." what)
 194      (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%break)))
 195        (invoke-debugger
 196         (apply #'coerce-to-condition datum 'simple-condition what arguments)))))
 197   nil)
 198
 199 (defun break (&optional (datum "break") &rest arguments)
 200   #!+sb-doc
 201   "Print a message and invoke the debugger without allowing any possibility
 202 of condition handling occurring."
 203   (let ((*debugger-hook* nil) ; as specifically required by ANSI
 204         (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
 205     (apply #'%break 'break datum arguments)))
 206
 207 ;;; These functions definitions are for cold-init.
 208 ;;; The real definitions are found in 'condition.lisp'
 209 (defvar *!cold-warn-action* nil)
 210 (defun warn (datum &rest arguments)
 211   (let ((action (cond ((boundp '*!cold-warn-action*) *!cold-warn-action*)
 212                       ((not (member datum
 213                                     '(asterisks-around-constant-variable-name
 214                                       redefinition-with-defun)))
 215                        'print))))
 216     (when (member action '(lose print))
 217       (let ((*package* *cl-package*))
 218         (write-string "cold WARN: datum=") ; WRITE could be too broken as yet
 219         (write (get-lisp-obj-address datum) :radix t :base 16)
 220         (write-string " = ")
 221         (write datum)
 222         (write-char #\space)
 223         (write (get-lisp-obj-address arguments) :radix t :base 16)
 224         (terpri)))
 225     (when (eq action 'lose) (sb!sys:%primitive sb!c:halt))))
 226 (defun style-warn (datum &rest arguments)
 227   (declare (notinline warn))
 228   (apply 'warn datum arguments))