src/code/error-error.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!IMPL")
  11
  12 ;;; These specials are used by ERROR-ERROR to track the success of recovery
  13 ;;; attempts. Not to be confused with SB-KERNEL::*CURRENT-ERROR-DEPTH*.
  14 (defvar *error-error-depth* 0)
  15
  16 ;;; ERROR-ERROR can be called when the error system is in trouble and needs to
  17 ;;; punt fast. It prints a message without using FORMAT. If we get into this
  18 ;;; recursively, then we halt.
  19 (defun error-error (&rest messages)
  20   ;; Be very conservative until nesting is dealt with, including consing.
  21   (let ((*error-error-depth* (1+ *error-error-depth*)))
  22     (when (> *error-error-depth* 4)
  23       (/show0 "*ERROR-ERROR-DEPTH* too big, trying HALT")
  24       (%primitive sb!c:halt)
  25       (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
  26       (throw 'toplevel-catcher nil))
  27     ;; We can be somewhat more relaxed now, the above will save us.
  28     (with-standard-io-syntax
  29       (let ((*print-readably* nil))
  30         (flet
  31             ((try-to-invoke-debugger ()
  32                ;; Try to print something useful for debugging and try to invoke the debugger.
  33                ;; Many things can trigger potentially nested errors beyond this point.
  34                (dolist (item messages)
  35                  (princ item *terminal-io*))
  36                (terpri *terminal-io*)
  37                (sb!debug:print-backtrace :stream *terminal-io* :emergency-best-effort t)
  38                (force-output *terminal-io*)
  39                (invoke-debugger
  40                 (coerce-to-condition "Maximum error nesting depth exceeded"
  41                                      'simple-error 'error)))
  42              (safely-print (message)
  43                (handler-case
  44                    (progn
  45                      (princ "Help! ERROR-ERROR is " *terminal-io*)
  46                      (princ *error-error-depth* *terminal-io*)
  47                      (princ " levels deep. " *terminal-io*)
  48                      (princ message *terminal-io*)
  49                      (terpri *terminal-io*))
  50                  (t ()))))
  51           (declare (inline safely-print))
  52           (case *error-error-depth*
  53             (1
  54              ;; Don't scream on the first invocation.
  55              (try-to-invoke-debugger))
  56             (2
  57              (safely-print "Will try to reset the IO streams by calling STREAM-COLD-INIT-OR-RESET.")
  58              (stream-cold-init-or-reset)
  59              (try-to-invoke-debugger))
  60             (3
  61              (safely-print "Will try to THROW this thread to the toplevel.")
  62              (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
  63              ;; FIXME: TOPLEVEL-REPL installs a (catch 'toplevel-catcher ...)
  64              ;; inside its LOOP. If any error nesting happens while inside that
  65              ;; LOOP (e.g. due to a "Broken pipe" on stderr, which is used by the
  66              ;; debugger), then when we get here this throw below will only unwind
  67              ;; until inside this LOOP, and thus the repl will loop forever busy
  68              ;; printing errors. https://bugs.launchpad.net/sbcl/+bug/1520694
  69              (throw 'toplevel-catcher nil))
  70             (t
  71              (safely-print "Will try to halt this thread as a last resort.")
  72              (/show0 "*ERROR-ERROR-DEPTH* too big, trying HALT")
  73              (%primitive sb!c:halt)
  74              (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
  75              (throw '%abort-thread nil))))))))