X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=69a135c69524a162635efe82babd4e2a18c18922;hb=020de3c04699323437f0c746fe986506b716ab97;hp=20fa0dacadcf3aadcda51d0986fed5cb9ba544fc;hpb=833c031ec5dd8ee50dd2dbe003e7b2f398a8b699;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 20fa0da..69a135c 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -639,11 +639,25 @@ Other commands: 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." @@ -651,16 +665,18 @@ Other commands: (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. ;; @@ -724,9 +740,10 @@ reset to ~S." ;; regardless of what the debugger does afterwards.) (handler-case (format *error-output* - "~2&~@~%" (type-of *debug-condition*) + (sb!thread:current-thread-id) *debug-condition*) (error (condition) (setf *nested-debug-condition* condition) @@ -746,6 +763,9 @@ reset to ~S." '*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 @@ -754,37 +774,102 @@ reset to ~S." ;; 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* - "~%~@~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* + "~%~@~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* + "~&~@~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) @@ -792,7 +877,8 @@ reset to ~S." "~&(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)) @@ -814,6 +900,9 @@ reset to ~S." (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 @@ -825,7 +914,7 @@ reset to ~S." (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) - (debug-loop))) + (funcall *debug-loop-fun*))) ;;;; DEBUG-LOOP @@ -836,7 +925,7 @@ reset to ~S." "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*))