of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
around the invocation.")
+(defvar *invoke-debugger-hook* nil
+ #!+sb-doc
+ "This is either NIL or a designator for a function of two arguments,
+ to be run when the debugger is about to be entered. The function is
+ run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive
+ errors, and receives as arguments the condition that triggered
+ debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK*
+
+ This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*.
+ In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when
+ called by BREAK.")
+
;;; These are bound on each invocation of INVOKE-DEBUGGER.
(defvar *debug-restarts*)
(defvar *debug-condition*)
(defvar *nested-debug-condition*)
+;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by
+;;; command-line --disable-debugger option
(defun invoke-debugger (condition)
#!+sb-doc
"Enter the debugger."
(when old-hook
(let ((*debugger-hook* nil))
(funcall old-hook condition old-hook))))
+ (let ((old-hook *invoke-debugger-hook*))
+ (when old-hook
+ (let ((*invoke-debugger-hook* nil))
+ (funcall old-hook condition old-hook))))
- ;; If we're a background thread and *background-threads-wait-for-debugger*
- ;; is NIL, this will invoke a restart
-
- ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here. I deleted it
- ;; around sbcl-0.7.8.5 (by which time it had mutated to have a
- ;; #!-SUNOS prefix and a FIXME note observing that it wasn't needed
- ;; on SunOS and no one knew why it was needed anywhere else either).
- ;; So if something mysteriously breaks that has worked since the CMU
- ;; CL days, that might be why. -- WHN 2002-09-28
+ ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here, to reset the
+ ;; signal state in the case that we wind up in the debugger as a
+ ;; result of something done by a signal handler. It's not
+ ;; altogether obvious that this is necessary, and indeed SBCL has
+ ;; not been doing it since 0.7.8.5. But nobody seems altogether
+ ;; convinced yet
+ ;; -- dan 2003.11.11, based on earlier comment of WHN 2002-09-28
;; We definitely want *PACKAGE* to be of valid type.
;;
;; regardless of what the debugger does afterwards.)
(handler-case
(format *error-output*
- "~2&~@<debugger invoked on condition of type ~S: ~
+ "~2&~@<debugger invoked on a ~S in thread ~A: ~
~2I~_~A~:>~%"
(type-of *debug-condition*)
+ (sb!thread:current-thread-id)
*debug-condition*)
(error (condition)
(setf *nested-debug-condition* condition)
'*debug-condition*
(cell-error-name *debug-condition*)))))
+ (setf background-p
+ (sb!thread::debugger-wait-until-foreground-thread *debug-io*))
+
;; After the initial error/condition/whatever announcement to
;; *ERROR-OUTPUT*, we become interactive, and should talk on
;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
;; stream was in fashion at the time, and not all of it has
;; been converted to behave this way. -- WHN 2000-11-16)
- (setf background-p
- (sb!thread::debugger-wait-until-foreground-thread *debug-io*))
(unwind-protect
- (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
- ;; violating the principle of least surprise, and making
- ;; it impossible for the user to do reasonable things
- ;; like using PRINT at the debugger prompt to send output
- ;; to the program's ordinary (possibly
- ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
- ;; used to rebind *STANDARD-INPUT* here too, but that's
- ;; been fixed already.)
- (*standard-output* *debug-io*)
- ;; This seems reasonable: e.g. if the user has redirected
- ;; *ERROR-OUTPUT* to some log file, it's probably wrong
- ;; to send errors which occur in interactive debugging to
- ;; that file, and right to send them to *DEBUG-IO*.
- (*error-output* *debug-io*))
- (unless (typep condition 'step-condition)
- (when *debug-beginner-help-p*
- (format *debug-io*
- "~%~@<Within the debugger, you can type HELP for help. ~
- At any command prompt (within the debugger or not) you ~
- can type (SB-EXT:QUIT) to terminate the SBCL ~
- executable. The condition which caused the debugger to ~
- be entered is bound to ~S. You can suppress this ~
- message by clearing ~S.~:@>~2%"
- '*debug-condition*
- '*debug-beginner-help-p*))
- (show-restarts *debug-restarts* *debug-io*))
+ (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
+ ;; violating the principle of least surprise, and making
+ ;; it impossible for the user to do reasonable things
+ ;; like using PRINT at the debugger prompt to send output
+ ;; to the program's ordinary (possibly
+ ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
+ ;; used to rebind *STANDARD-INPUT* here too, but that's
+ ;; been fixed already.)
+ (*standard-output* *debug-io*)
+ ;; This seems reasonable: e.g. if the user has redirected
+ ;; *ERROR-OUTPUT* to some log file, it's probably wrong
+ ;; to send errors which occur in interactive debugging to
+ ;; that file, and right to send them to *DEBUG-IO*.
+ (*error-output* *debug-io*))
+ (unless (typep condition 'step-condition)
+ (when *debug-beginner-help-p*
+ (format *debug-io*
+ "~%~@<You can type HELP for debugger help, or ~
+ (SB-EXT:QUIT) to exit from SBCL.~:@>~2%"))
+ (show-restarts *debug-restarts* *debug-io*))
(internal-debug))
- (when background-p (sb!thread::release-foreground)))))))
+ (when background-p
+ (sb!thread::release-foreground)))))))
+
+;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
+;;; ANSI behavior has been suppressed by command-line
+;;; --disable-debugger option
+(defun debugger-disabled-hook (condition me)
+ (declare (ignore me))
+ ;; There is no one there to interact with, so report the
+ ;; condition and terminate the program.
+ (flet ((failure-quit (&key recklessly-p)
+ (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
+ (quit :unix-status 1 :recklessly-p recklessly-p)))
+ ;; This HANDLER-CASE is here mostly to stop output immediately
+ ;; (and fall through to QUIT) when there's an I/O error. Thus,
+ ;; when we're run under a shell script or something, we can die
+ ;; cleanly when the script dies (and our pipes are cut), instead
+ ;; of falling into ldb or something messy like that. Similarly, we
+ ;; can terminate cleanly even if BACKTRACE dies because of bugs in
+ ;; user PRINT-OBJECT methods.
+ (handler-case
+ (progn
+ (format *error-output*
+ "~&~@<unhandled condition (of type ~S): ~2I~_~A~:>~2%"
+ (type-of condition)
+ condition)
+ ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
+ ;; even if we hit an error within BACKTRACE (e.g. a bug in
+ ;; the debugger's own frame-walking code, or a bug in a user
+ ;; PRINT-OBJECT method) we'll at least have the CONDITION
+ ;; printed out before we die.
+ (finish-output *error-output*)
+ ;; (Where to truncate the BACKTRACE is of course arbitrary, but
+ ;; it seems as though we should at least truncate it somewhere.)
+ (sb!debug:backtrace 128 *error-output*)
+ (format
+ *error-output*
+ "~%unhandled condition in --disable-debugger mode, quitting~%")
+ (finish-output *error-output*)
+ (failure-quit))
+ (condition ()
+ ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
+ ;; fail when our output streams are blown away, as e.g. when
+ ;; we're running under a Unix shell script and it dies somehow
+ ;; (e.g. because of a SIGINT). In that case, we might as well
+ ;; just give it up for a bad job, and stop trying to notify
+ ;; the user of anything.
+ ;;
+ ;; Actually, the only way I've run across to exercise the
+ ;; problem is to have more than one layer of shell script.
+ ;; I have a shell script which does
+ ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
+ ;; and the problem occurs when I interrupt this with Ctrl-C
+ ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
+ ;; I haven't figured out whether it's bash, time, tee, Linux, or
+ ;; what that is responsible, but that it's possible at all
+ ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
+ (ignore-errors
+ (%primitive print
+ "Argh! error within --disable-debugger error handling"))
+ (failure-quit :recklessly-p t)))))
+
+;;; halt-on-failures and prompt-on-failures modes, suitable for
+;;; noninteractive and interactive use respectively
+(defun disable-debugger ()
+ (when (eql *invoke-debugger-hook* nil)
+ (setf *debug-io* *error-output*
+ *invoke-debugger-hook* 'debugger-disabled-hook)))
+
+(defun enable-debugger ()
+ (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
+ (setf *invoke-debugger-hook* nil)))
+
+(setf *debug-io* *query-io*)
(defun show-restarts (restarts s)
(cond ((null restarts)
"~&(no restarts: If you didn't do this on purpose, ~
please report it as a bug.)~%"))
(t
- (format s "~&restarts:~%")
+ (format s "~&restarts (invokable by number or by ~
+ possibly-abbreviated name):~%")
(let ((count 0)
(names-used '(nil))
(max-name-len 0))
(push name names-used))))
(incf count))))))
+(defvar *debug-loop-fun* #'debug-loop-fun
+ "a function taking no parameters that starts the low-level debug loop")
+
;;; This calls DEBUG-LOOP, performing some simple initializations
;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies
(*read-suppress* nil))
(unless (typep *debug-condition* 'step-condition)
(clear-input *debug-io*))
- (debug-loop)))
+ (funcall *debug-loop-fun*)))
\f
;;;; DEBUG-LOOP
"When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
executing in the debugger.")
-(defun debug-loop ()
+(defun debug-loop-fun ()
(let* ((*debug-command-level* (1+ *debug-command-level*))
(*real-stack-top* (sb!di:top-frame))
(*stack-top* (or *stack-top-hint* *real-stack-top*))
projects / sbcl.git / blobdiff