0.8.4.30:
[sbcl.git] / src / code / debug.lisp
index ec3d3b2..2b62184 100644 (file)
@@ -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*)
@@ -78,9 +79,9 @@
          *debug-command-level*))
   
 (defparameter *debug-help-string*
-"The prompt is square brackets, with number(s) indicating the current control
-  stack level and, if you've entered the debugger recursively, how deeply
-  recursed you are.
+"The debug prompt is square brackets, with number(s) indicating the current
+  control stack level and, if you've entered the debugger recursively, how
+  deeply recursed you are.
 Any command -- including the name of a restart -- may be uniquely abbreviated.
 The debugger rebinds various special variables for controlling i/o, sometimes
   to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to 
@@ -94,8 +95,8 @@ Getting in and out of the debugger:
   RESTART  invokes restart numbered as shown (prompt if not given).
   ERROR    prints the error condition and restart cases.
   The number of any restart, or its name, or a unique abbreviation for its
-    name, is a valid command, and is the same as using RESTART to invoke that
-    restart.
+    name, is a valid command, and is the same as using RESTART to invoke
+    that restart.
 
 Changing frames:
   U      up frame     D    down 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.)")
 \f
 ;;; 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))
 \f
 ;;;; 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,17 +644,28 @@ 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*))
     (when old-hook
       (let ((*debugger-hook* nil))
        (funcall old-hook condition old-hook))))
-  ;; FIXME: No-one seems to know what this is for. Nothing is noticeably
-  ;; broken on sunos...
-  #!-sunos (sb!unix:unix-sigsetmask 0)
 
+  ;; 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
+
+  ;; We definitely want *PACKAGE* to be of valid type.
+  ;;
   ;; Elsewhere in the system, we use the SANE-PACKAGE function for
   ;; this, but here causing an exception just as we're trying to handle
   ;; an exception would be confusing, so instead we use a special hack.
@@ -660,37 +676,47 @@ Other commands:
            "The value of ~S was not an undeleted PACKAGE. It has been
 reset to ~S."
            '*package* *package*))
-  (let (;; Save *PACKAGE* to protect it from WITH-STANDARD-IO-SYNTAX.
-       (original-package *package*))
+
+  ;; Try to force the other special variables into a useful state.
+  (let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where
+       ;; any default we might use is less useful than just reusing
+       ;; the global values.
+       (original-package *package*)
+       (original-print-pretty *print-pretty*))
     (with-standard-io-syntax
-     (let* ((*debug-condition* condition)
-           (*debug-restarts* (compute-restarts condition))
-           ;; We want the i/o subsystem to be in a known, useful
-           ;; state, regardless of where the debugger was invoked in
-           ;; the program. WITH-STANDARD-IO-SYNTAX does some of that,
-           ;; but
-           ;;   1. It doesn't affect our internal special variables 
-           ;;      like *CURRENT-LEVEL-IN-PRINT*.
-           ;;   2. It isn't customizable.
-           ;;   3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY* 
-           ;;      to the same value as the toplevel default.
-           ;;   4. It sets *PACKAGE* to COMMON-LISP-USER, which is not
-           ;;      helpful behavior for a debugger.
-           ;; We try to remedy all these problems with explicit 
-           ;; rebindings here.
-           (sb!kernel:*current-level-in-print* 0)
-           (*print-length* *debug-print-length*)
-           (*print-level* *debug-print-level*)
-           (*readtable* *debug-readtable*)
-           (*print-readably* nil)
-           (*print-pretty* t)
-           (*package* original-package)
-           (*nested-debug-condition* nil))
+     (let ((*debug-condition* condition)
+          (*debug-restarts* (compute-restarts condition))
+          (*nested-debug-condition* nil)
+          ;; We want the printer and reader to be in a useful state,
+          ;; regardless of where the debugger was invoked in the
+          ;; program. WITH-STANDARD-IO-SYNTAX did much of what we
+          ;; want, but
+          ;;   * It doesn't affect our internal special variables 
+          ;;     like *CURRENT-LEVEL-IN-PRINT*.
+          ;;   * It isn't customizable.
+          ;;   * It doesn't set *PRINT-READABLY* to the same value
+          ;;     as the toplevel default.
+          ;;   * It sets *PACKAGE* to COMMON-LISP-USER, which is not
+          ;;     helpful behavior for a debugger.
+          ;;   * There's no particularly good debugger default for
+          ;;     *PRINT-PRETTY*, since T is usually what you want
+          ;;     -- except absolutely not what you want when you're
+          ;;     debugging failures in PRINT-OBJECT logic.
+          ;; We try to address all these issues with explicit
+          ;; rebindings here.
+          (sb!kernel:*current-level-in-print* 0)
+          (*print-length* *debug-print-length*)
+          (*print-level* *debug-print-level*)
+          (*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.
-       ;; Otherwise, if the user tried to track the progress of
-       ;; his program using PRINT statements, he'd tend to lose
-       ;; the last line of output or so, and get confused.
+       ;; Otherwise, if the user tried to track the progress of his
+       ;; program using PRINT statements, he'd tend to lose the last
+       ;; line of output or so, which'd be confusing.
        (flush-standard-output-streams)
 
        ;; (The initial output here goes to *ERROR-OUTPUT*, because the
@@ -700,9 +726,10 @@ reset to ~S."
        ;; regardless of what the debugger does afterwards.)
        (handler-case
           (format *error-output*
-                  "~2&~@<debugger invoked on condition of type ~S: ~
+                  "~2&~@<debugger invoked on condition of type ~S in thread ~A: ~
                     ~2I~_~A~:>~%"
                   (type-of *debug-condition*)
+                  (sb!thread:current-thread-id)
                   *debug-condition*)
         (error (condition)
            (setf *nested-debug-condition* condition)
@@ -729,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
@@ -755,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*
+                 "~&~@<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 ()
+  (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)
@@ -763,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))
@@ -796,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*)))
 \f
 ;;;; DEBUG-LOOP
 
@@ -808,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*))
@@ -840,37 +940,24 @@ reset to ~S."
            (let ((level *debug-command-level*)
                  (restart-commands (make-restart-commands)))
              (with-simple-restart (abort
-                                  "Reduce debugger level (to debug level ~W)."
+                                  "~@<Reduce debugger level (to debug level ~W).~@:>"
                                    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)
@@ -1224,9 +1311,8 @@ reset to ~S."
 ;;;  (throw 'sb!impl::toplevel-catcher nil))
 
 ;;; CMU CL supported this GO debug command, but SBCL doesn't -- in
-;;; SBCL you just type the CONTINUE restart name instead (or "RESTART
-;;; CONTINUE", that's OK too).
-
+;;; SBCL you just type the CONTINUE restart name instead (or "C" or
+;;; "RESTART CONTINUE", that's OK too).
 ;;;(!def-debug-command "GO" ()
 ;;;  (continue *debug-condition*)
 ;;;  (error "There is no restart named CONTINUE."))
@@ -1656,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 "~@<can't find a tag for this frame ~
+                   ~2I~_(hint: try increasing the DEBUG optimization quality ~
+                   and recompiling)~:@>"))))
 \f
 ;;;; debug loop command utilities