X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=2b6218440af047f63c6389e3c5e8f7fe2225b3a6;hb=a53deb94a224bc903d00a5075acf562488cab06a;hp=67c791fee8322b037a660d4c122a180f378937c7;hpb=7c5a7fb9e1fb0ade9e31de3ffdf02252669c3d4c;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 67c791f..2b62184 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -71,6 +71,7 @@ "Should the debugger display beginner-oriented help messages?") (defun debug-prompt (stream) + (sb!thread::get-foreground) (format stream "~%~W~:[~;[~W~]] " (sb!di:frame-number *current-frame*) @@ -122,17 +123,20 @@ Breakpoints and steps: STEP [n] Step to the next location or step n times. Function and macro commands: - (SB-DEBUG:DEBUG-RETURN expression) - Exit the debugger, returning expression's values from the current frame. (SB-DEBUG:ARG n) Return the n'th argument in the current frame. (SB-DEBUG:VAR string-or-symbol [id]) Returns the value of the specified variable in the current frame. Other commands: - SLURP Discard all pending input on *STANDARD-INPUT*. (This can be - useful when the debugger was invoked to handle an error in - deeply nested input syntax, and now the reader is confused.)") + RETURN expr + [EXPERIMENTAL] Return the values resulting from evaluation of expr + from the current frame, if this frame was compiled with a sufficiently + high DEBUG optimization quality. + SLURP + Discard all pending input on *STANDARD-INPUT*. (This can be + useful when the debugger was invoked to handle an error in + deeply nested input syntax, and now the reader is confused.)") ;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint. (define-condition step-condition (simple-condition) ()) @@ -443,9 +447,10 @@ Other commands: ;;; ANSI specifies that this macro shall exist, even if only as a ;;; trivial placeholder like this. (defmacro step (form) - "a trivial placeholder implementation of the CL:STEP macro required by - the ANSI spec" - `(progn + "This is a trivial placeholder implementation of the CL:STEP macro required + by the ANSI spec, simply expanding to `(LET () ,FORM). A more featureful + version would be welcome, we just haven't written it." + `(let () ,form)) ;;;; BACKTRACE @@ -557,19 +562,17 @@ Other commands: (nreverse reversed-result)) (sb!di:lambda-list-unavailable () - :lambda-list-unavailable)))) + (make-unprintable-object "unavailable lambda list"))))) ;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then ;;; print as many of the values as possible, punting the loop over ;;; lambda-list variables since any other arguments will be in the ;;; &REST arg's list of values. (defun print-frame-call-1 (frame) - (let ((debug-fun (sb!di:frame-debug-fun frame)) - (loc (sb!di:frame-code-location frame))) + (let ((debug-fun (sb!di:frame-debug-fun frame))) (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (let ((args (mapcar #'ensure-printable-object - (frame-args-as-list frame)))) + (let ((args (ensure-printable-object (frame-args-as-list frame)))) ;; Since we go to some trouble to make nice informative function ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*. @@ -577,7 +580,9 @@ Other commands: (*print-level* nil)) (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun)))) ;; For the function arguments, we can just print normally. - (format t "~{ ~_~S~}" args))) + (if (listp args) + (format t "~{ ~_~S~}" args) + (format t " ~S" args)))) (when (sb!di:debug-fun-kind debug-fun) (write-char #\[) @@ -639,7 +644,9 @@ Other commands: (defvar *debug-condition*) (defvar *nested-debug-condition*) -(defun invoke-debugger (condition) +;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by +;;; command-line --disable-debugger option +(defun invoke-debugger/enabled (condition) #!+sb-doc "Enter the debugger." (let ((old-hook *debugger-hook*)) @@ -647,6 +654,9 @@ Other commands: (let ((*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 @@ -700,6 +710,7 @@ reset to ~S." (*readtable* *debug-readtable*) (*print-readably* nil) (*package* original-package) + (background-p nil) (*print-pretty* original-print-pretty)) ;; Before we start our own output, finish any pending output. @@ -715,9 +726,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) @@ -744,6 +756,10 @@ reset to ~S." ;; older debugger code which was written to do i/o on whatever ;; 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 @@ -770,7 +786,76 @@ reset to ~S." '*debug-condition* '*debug-beginner-help-p*)) (show-restarts *debug-restarts* *debug-io*)) - (internal-debug)))))) + (internal-debug)) + (when background-p (sb!thread::release-foreground))))))) + +;;; the degenerate case of INVOKE-DEBUGGER, when ordinary ANSI behavior +;;; has been suppressed by command-line --disable-debugger option +(defun invoke-debugger/disabled (condition) + ;; 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 () + (setf (fdefinition 'invoke-debugger) #'invoke-debugger/disabled + *debug-io* *error-output*)) +(defun enable-debugger () + (setf (fdefinition 'invoke-debugger) #'invoke-debugger/enabled + *debug-io* *query-io*)) +;;; The enabled mode is the ANSI default. +(enable-debugger) (defun show-restarts (restarts s) (cond ((null restarts) @@ -778,7 +863,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)) @@ -811,8 +897,7 @@ reset to ~S." (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) - #!-mp (debug-loop) - #!+mp (sb!mp:without-scheduling (debug-loop)))) + (funcall *debug-loop-fun*))) ;;;; DEBUG-LOOP @@ -823,7 +908,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*)) @@ -859,33 +944,20 @@ reset to ~S." level) (debug-prompt *debug-io*) (force-output *debug-io*) - (let ((input (sb!int:get-stream-command *debug-io*))) - (cond (input - (let ((cmd-fun (debug-command-p - (sb!int:stream-command-name input) - restart-commands))) - (cond - ((not cmd-fun) - (error "unknown stream-command: ~S" input)) - ((consp cmd-fun) - (error "ambiguous debugger command: ~S" cmd-fun)) - (t - (apply cmd-fun - (sb!int:stream-command-args input)))))) + (let* ((exp (read *debug-io*)) + (cmd-fun (debug-command-p exp restart-commands))) + (cond ((not cmd-fun) + (debug-eval-print exp)) + ((consp cmd-fun) + (format t "~&Your command, ~S, is ambiguous:~%" + exp) + (dolist (ele cmd-fun) + (format t " ~A~%" ele))) (t - (let* ((exp (read *debug-io*)) - (cmd-fun (debug-command-p exp - restart-commands))) - (cond ((not cmd-fun) - (debug-eval-print exp)) - ((consp cmd-fun) - (format t - "~&Your command, ~S, is ambiguous:~%" - exp) - (dolist (ele cmd-fun) - (format t " ~A~%" ele))) - (t - (funcall cmd-fun))))))))))))))) + (funcall cmd-fun)))))))))))) + +(defvar *debug-loop-fun* #'debug-loop-fun + "a function taking no parameters that starts the low-level debug loop") ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic. (defun debug-eval-print (expr) @@ -1670,6 +1742,24 @@ reset to ~S." (!def-debug-command "SLURP" () (loop while (read-char-no-hang *standard-input*))) + +(!def-debug-command "RETURN" (&optional + (return (read-prompting-maybe + "return: "))) + (let ((tag (find-if (lambda (x) + (and (typep (car x) 'symbol) + (not (symbol-package (car x))) + (string= (car x) "SB-DEBUG-CATCH-TAG"))) + (sb!di::frame-catches *current-frame*)))) + (if tag + (throw (car tag) + (funcall (sb!di:preprocess-for-eval + return + (sb!di:frame-code-location *current-frame*)) + *current-frame*)) + (format t "~@")))) ;;;; debug loop command utilities