0.8.1.14:

[sbcl.git] / src / code / debug.lisp

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index c582585..cf7f9db 100644 (file)
--- 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)
   "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*)
   (format stream
          "~%~W~:[~;[~W~]] "
          (sb!di:frame-number *current-frame*)

@@ -78,9 +79,9 @@
          *debug-command-level*))
   
 (defparameter *debug-help-string*
          *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 
 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
   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
 
 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:
   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:
  (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) ())
 \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)
 ;;; 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
      ,form))
 \f
 ;;;; BACKTRACE

@@ -557,19 +562,17 @@ Other commands:
          (nreverse reversed-result))
       (sb!di:lambda-list-unavailable
        ()
          (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)
 
 ;;; 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 ")")
 
     (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*.
        ;; 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.
              (*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 #\[)
 
     (when (sb!di:debug-fun-kind debug-fun)
       (write-char #\[)

@@ -647,6 +652,9 @@ Other commands:
       (let ((*debugger-hook* nil))
        (funcall old-hook condition old-hook))))
 
       (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
   ;; 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 +708,7 @@ reset to ~S."
           (*readtable* *debug-readtable*)
           (*print-readably* nil)
           (*package* original-package)
           (*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.
           (*print-pretty* original-print-pretty))
 
        ;; Before we start our own output, finish any pending output.

@@ -744,6 +753,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)
        ;; 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
        (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 +783,8 @@ reset to ~S."
                     '*debug-condition*
                     '*debug-beginner-help-p*))
           (show-restarts *debug-restarts* *debug-io*))
                     '*debug-condition*
                     '*debug-beginner-help-p*))
           (show-restarts *debug-restarts* *debug-io*))

-        (internal-debug))))))
+             (internal-debug))
+        (when background-p (sb!thread::release-foreground)))))))

 
 (defun show-restarts (restarts s)
   (cond ((null restarts)
 
 (defun show-restarts (restarts s)
   (cond ((null restarts)

@@ -778,7 +792,8 @@ reset to ~S."
                 "~&(no restarts: If you didn't do this on purpose, ~
                   please report it as a bug.)~%"))
        (t
                 "~&(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))
         (let ((count 0)
               (names-used '(nil))
               (max-name-len 0))

@@ -811,8 +826,7 @@ reset to ~S."
        (*read-suppress* nil))
     (unless (typep *debug-condition* 'step-condition)
       (clear-input *debug-io*))
        (*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
 
 \f
 ;;;; DEBUG-LOOP
 

@@ -823,7 +837,7 @@ reset to ~S."
   "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
    executing in the debugger.")
 
   "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*))
   (let* ((*debug-command-level* (1+ *debug-command-level*))
         (*real-stack-top* (sb!di:top-frame))
         (*stack-top* (or *stack-top-hint* *real-stack-top*))

@@ -855,37 +869,24 @@ reset to ~S."
            (let ((level *debug-command-level*)
                  (restart-commands (make-restart-commands)))
              (with-simple-restart (abort
            (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*)
                                    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
                        (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)
 
 ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
 (defun debug-eval-print (expr)

@@ -1239,9 +1240,8 @@ reset to ~S."
 ;;;  (throw 'sb!impl::toplevel-catcher nil))
 
 ;;; CMU CL supported this GO debug command, but SBCL doesn't -- in
 ;;;  (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."))
 ;;;(!def-debug-command "GO" ()
 ;;;  (continue *debug-condition*)
 ;;;  (error "There is no restart named CONTINUE."))

@@ -1671,6 +1671,24 @@ reset to ~S."
 
 (!def-debug-command "SLURP" ()
   (loop while (read-char-no-hang *standard-input*)))
 
 (!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
 
 \f
 ;;;; debug loop command utilities