prettier backtraces

Introduce PRINT-BACKTRACE and LIST-BACKTRACE as forward compatible
  replacements for BACKTRACE and BACKTRACE-AS-LIST. (Not yet deprecated.)

  *SHOW-ENTRY-POINT-DETAILS* is also deprecated. Function names and
  lambda-lists are now always cleaned, but the details that were
  previously available via the debug name are now provided as part of
  the auxilliary frame info.

  *METHOD-FRAME-STYLE* can be :MINIMAL, :NORMAL, or :FULL, defaulting to
  :NORMAL.

NEWS

@@ -10,8 +10,15 @@ changes relative to sbcl-1.1.4:
     resolving the situation. See manual for details. (lp#891351)
   * enhancement: make-random-state now uses CryptGenRandom as a seed on Windows.
     (Thanks to Anton Kovalenko.) (lp#1102748)
-  * bug fix: secondary CLOS dispatch functions have better debug names.
-    (lp#503081)
+  * enhancement: backtrace improvements
+    ** secondary CLOS dispatch functions have better debug names (lp#503081)
+    ** easier to read method names in backtraces. See
+       SB-DEBUG:*METHOD-FRAME-STYLE*.
+    ** SB-DEBUG:PRINT-BACKTRACE and SB-DEBUG:LIST-BACKTRACE are available as
+       forwards-compatible replacements for SB-DEBUG:BACKTRACE and
+       SB-DEBUG:BACKTRACE-AS-LIST.
+    ** SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS** has been deprecated, as the same
+       information is available in less intrusive form as frame annotations.
   * bug fix: deleting a package removes it from implementation-package
     lists of other packages.
 

doc/manual/debugger.texinfo

@@ -306,12 +306,6 @@ Sometimes the compiler introduces new functions that are used to
 implement a user function, but are not directly specified in the
 source. This is mostly done for argument type and count checking.
 
-The debugger will normally show these entry point functions as if
-they were the normal main entry point, but more detail can be obtained
-by setting @code{sb-debug:*show-entry-point-details*} to true; this is
-primarily useful for debugging SBCL itself, but may help pinpoint
-problems that occur during lambda-list processing.
-
 @c FIXME: the following bits talked about block-compilation, but
 @c we don't currently support it...
 
@@ -327,13 +321,12 @@ problems that occur during lambda-list processing.
 @c frames during the execution of @code{unwind-protect} cleanup
 @c code.
 
-With recursive functions, an additional @code{:EXTERNAL} frame may
+With recursive functions, an additional @code{external} frame may
 appear before the frame representing the first call to the recursive
 function. This is a consequence of the way the compiler works: there
-is nothing odd with your program. You will also see @code{:CLEANUP}
-frames during the execution of @code{unwind-protect} cleanup code.
-The @code{:EXTERNAL} and @code{:CLEANUP} above are entry-point types,
-visible only if @code{sb-debug:*show-entry-point-details*} is true.
+is nothing odd with your program. You may also see @code{cleanup}
+frames during the execution of @code{unwind-protect} cleanup code, and
+@code{optional} for variable argument entry points.
 
 @node  Debug Tail Recursion
 @comment  node-name,  next,  previous,  up

package-data-list.lisp-expr

@@ -410,20 +410,26 @@ is still mixed indiscriminately with low-level internal implementation stuff
 like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
       :use ("CL" "SB!EXT" "SB!INT" "SB!SYS" "SB!KERNEL")
       :reexport ("*DEBUG-PRINT-VARIABLE-ALIST*")
-      :export ("*DEBUG-BEGINNER-HELP-P*"
+      :export ("*BACKTRACE-FRAME-COUNT*"
+               "*DEBUG-BEGINNER-HELP-P*"
                "*DEBUG-CONDITION*"
                "*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*"
                "*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*"
-               "*SHOW-ENTRY-POINT-DETAILS*"
+               "*METHOD-FRAME-STYLE*"
                "*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*"
                "*TRACE-FRAME*" "*TRACED-FUN-LIST*"
-               "ARG" "BACKTRACE" "BACKTRACE-AS-LIST" "INTERNAL-DEBUG" "VAR"
+               "ARG"
+               "INTERNAL-DEBUG" "VAR"
                "*PRINT-LOCATION-KIND*"
                "*ONLY-BLOCK-START-LOCATIONS*" "*STACK-TOP-HINT*"
                "*TRACE-VALUES*" "DO-DEBUG-COMMAND"
                "*TRACE-ENCAPSULATE-DEFAULT*"
                "FRAME-HAS-DEBUG-TAG-P"
-               "UNWIND-TO-FRAME-AND-CALL"))
+               "UNWIND-TO-FRAME-AND-CALL"
+               ;; Deprecated
+               "BACKTRACE" "BACKTRACE-AS-LIST" "*SHOW-ENTRY-POINT-DETAILS*"
+               ;; Replaced by
+               "PRINT-BACKTRACE" "LIST-BACKTRACE"))
 
    #s(sb-cold:package-data
       :name "SB!DI"

src/code/debug.lisp

@@ -171,58 +171,243 @@ Other commands:
 
 ;;;; BACKTRACE
 
-(defun map-backtrace (thunk &key (start 0) (count most-positive-fixnum))
-  (loop
-     with result = nil
-     for index upfrom 0
-     for frame = (if *in-the-debugger*
-                     *current-frame*
-                     (sb!di:top-frame))
-               then (sb!di:frame-down frame)
-     until (null frame)
-     when (<= start index) do
-       (if (minusp (decf count))
-           (return result)
-           (setf result (funcall thunk frame)))
-     finally (return result)))
+(declaim (unsigned-byte *backtrace-frame-count*))
+(defvar *backtrace-frame-count* 1000
+  "Default number of frames to backtrace. Defaults to 1000.")
 
-(defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*))
+(declaim (type (member :minimal :normal :full) *method-frame-style*))
+(defvar *method-frame-style* :normal
+  "Determines how frames corresponding to method functions are represented in
+backtraces. Possible values are :MINIMAL, :NORMAL, and :FULL.
+
+  :MINIMAL represents them as
+
+    (<gf-name> ...args...)
+
+    if all arguments are available, and only a single method is applicable to
+    the arguments -- otherwise behaves as :NORMAL.
+
+  :NORMAL represents them as
+
+    ((:method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
+
+    The frame is then followed by either [fast-method] or [slow-method],
+    designating the kind of method function. (See below.)
+
+  :FULL represents them using the actual funcallable method function name:
+
+    ((sb-pcl:fast-method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
+
+   or
+
+    ((sb-pcl:slow-method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
+
+   In the this case arguments may include values internal to SBCL's method
+   dispatch machinery.")
+
+(define-deprecated-variable :early "1.1.4.9" *show-entry-point-details*
+  :value nil)
+
+(defun backtrace (&optional (count *backtrace-frame-count*) (stream *debug-io*))
+  "Replaced by PRINT-BACKTRACE, will eventually be deprecated."
+  (print-backtrace :count count :stream stream))
+
+(defun backtrace-as-list (&optional (count *backtrace-frame-count*))
+  "Replaced by LIST-BACKTRACE, will eventually be deprecated."
+  (list-backtrace :count count))
+
+(defun backtrace-start-frame (frame-designator)
+  (let ((here (sb!di:top-frame)))
+    (labels ((current-frame ()
+               (let ((frame here))
+                 ;; Our caller's caller.
+                 (loop repeat 2
+                       do (setf frame (or (sb!di:frame-down frame) frame)))
+                 frame))
+             (interrupted-frame ()
+               (or (nth-value 1 (find-interrupted-name-and-frame))
+                   (current-frame))))
+     (cond ((eq :current-frame frame-designator)
+            (current-frame))
+           ((eq :interrupted-frame frame-designator)
+            (interrupted-frame))
+           ((eq :debugger-frame frame-designator)
+            (if (and *in-the-debugger* *current-frame*)
+                *current-frame*
+                (interrupted-frame)))
+           ((sb!di:frame-p frame-designator)
+            frame-designator)
+           (t
+            (error "Invalid designator for initial backtrace frame: ~S"
+                   frame-designator))))))
+
+(defun map-backtrace (function &key
+                      (start 0)
+                      (from :debugger-frame)
+                      (count *backtrace-frame-count*))
   #!+sb-doc
-  "Show a listing of the call stack going down from the current frame.
-In the debugger, the current frame is indicated by the prompt. COUNT
-is how many frames to show."
+  "Calls the designated FUNCTION with each frame on the call stack.
+Returns the last value returned by FUNCTION.
+
+COUNT is the number of frames to backtrace, defaulting to
+*BACKTRACE-FRAME-COUNT*.
+
+START is the number of the frame the backtrace should start from.
+
+FROM specifies the frame relative to which the frames are numbered. Possible
+values are an explicit SB-DI:FRAME object, and the
+keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
+is :DEBUGGER-FRAME.
+
+  :CURRENT-FRAME
+    specifies the caller of MAP-BACKTRACE.
+
+  :INTERRUPTED-FRAME
+    specifies the first interrupted frame on the stack \(typically the frame
+    where the error occured, as opposed to error handling frames) if any,
+    otherwise behaving as :CURRENT-FRAME.
+
+  :DEBUGGER-FRAME
+    specifies the currently debugged frame when inside the debugger, and
+    behaves as :INTERRUPTED-FRAME outside the debugger.
+"
+  (loop with result = nil
+        for index upfrom 0
+        for frame = (backtrace-start-frame from)
+        then (sb!di:frame-down frame)
+        until (null frame)
+        when (<= start index) do
+        (if (minusp (decf count))
+            (return result)
+            (setf result (funcall function frame)))
+        finally (return result)))
+
+(defun print-backtrace (&key
+                        (stream *debug-io*)
+                        (start 0)
+                        (from :debugger-frame)
+                        (count *backtrace-frame-count*)
+                        (print-thread t)
+                        (print-frame-source nil)
+                        (method-frame-style *method-frame-style*))
+  #!+sb-doc
+  "Print a listing of the call stack to STREAM, defaulting to *DEBUG-IO*.
+
+COUNT is the number of frames to backtrace, defaulting to
+*BACKTRACE-FRAME-COUNT*.
+
+START is the number of the frame the backtrace should start from.
+
+FROM specifies the frame relative to which the frames are numbered. Possible
+values are an explicit SB-DI:FRAME object, and the
+keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
+is :DEBUGGER-FRAME.
+
+  :CURRENT-FRAME
+    specifies the caller of PRINT-BACKTRACE.
+
+  :INTERRUPTED-FRAME
+    specifies the first interrupted frame on the stack \(typically the frame
+    where the error occured, as opposed to error handling frames) if any,
+    otherwise behaving as :CURRENT-FRAME.
+
+  :DEBUGGER-FRAME
+    specifies the currently debugged frame when inside the debugger, and
+    behaves as :INTERRUPTED-FRAME outside the debugger.
+
+If PRINT-THREAD is true (default), backtrace is preceded by printing the
+thread object the backtrace is from.
+
+If PRINT-FRAME-SOURCE is true (default is false), each frame is followed by
+printing the currently executing source form in the function responsible for
+that frame, when available. Requires the function to have been compiled at
+DEBUG 2 or higher. If PRINT-FRAME-SOURCE is :ALWAYS, it also reports \"no
+source available\" for frames for which were compiled at lower debug settings.
+
+METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
+corresponding to method functions are printed. Possible values
+are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
+information."
   (fresh-line stream)
+  (when print-thread
+    (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*))
   (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
                                      *suppress-print-errors*
                                      'serious-condition))
-        (*print-circle* t))
+        (*print-circle* t)
+        (n start))
     (handler-bind ((print-not-readable #'print-unreadably))
         (map-backtrace (lambda (frame)
-                         (print-frame-call frame stream :number t))
+                         (print-frame-call frame stream
+                                           :number n
+                                           :method-frame-style method-frame-style
+                                           :print-frame-source print-frame-source)
+                         (incf n))
+                       :from (backtrace-start-frame from)
+                       :start start
                        :count count)))
   (fresh-line stream)
   (values))
 
-(defun backtrace-as-list (&optional (count most-positive-fixnum))
+(defun list-backtrace (&key
+                       (count *backtrace-frame-count*)
+                       (start 0)
+                       (from :debugger-frame)
+                       (method-frame-style *method-frame-style*))
   #!+sb-doc
-  "Return a list representing the current BACKTRACE.
+    "Returns a list describing the call stack. Each frame is represented
+by a sublist:
 
-Objects in the backtrace with dynamic-extent allocation by the current
-thread are represented by substitutes to avoid references to them from
-leaking outside their legal extent."
-  (let ((reversed-result (list)))
-    (map-backtrace (lambda (frame)
-                     (let ((frame-list (frame-call-as-list frame)))
-                       (if (listp (cdr frame-list))
-                           (push (mapcar #'replace-dynamic-extent-object frame-list)
-                                 reversed-result)
-                           (push frame-list reversed-result))))
-                   :count count)
-    (nreverse reversed-result)))
+  \(<name> ...args...)
 
-(defun frame-call-as-list (frame)
-  (multiple-value-bind (name args) (frame-call frame)
-    (cons name args)))
+where the name describes the function responsible for the frame. The name
+might not be bound to the actual function object. Unavailable arguments are
+represented by dummy objects that print as #<unavailable argument>. Objects
+with dynamic-extent allocation by the current thread are represented by
+substitutes to avoid references to them from leaking outside their legal
+extent.
+
+COUNT is the number of frames to backtrace, defaulting to
+*BACKTRACE-FRAME-COUNT*.
+
+START is the number of the frame the backtrace should start from.
+
+FROM specifies the frame relative to which the frames are numbered. Possible
+values are an explicit SB-DI:FRAME object, and the
+keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
+is :DEBUGGER-FRAME.
+
+  :CURRENT-FRAME
+    specifies the caller of LIST-BACKTRACE.
+
+  :INTERRUPTED-FRAME
+    specifies the first interrupted frame on the stack \(typically the frame
+    where the error occured, as opposed to error handling frames) if any,
+    otherwise behaving as :CURRENT-FRAME.
+
+  :DEBUGGER-FRAME
+    specifies the currently debugged frame when inside the debugger, and
+    behaves as :INTERRUPTED-FRAME outside the debugger.
+
+METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
+corresponding to method functions are printed. Possible values
+are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
+information."
+  (let (rbacktrace)
+     (map-backtrace
+      (lambda (frame)
+        (push (frame-call-as-list frame :method-frame-style method-frame-style)
+              rbacktrace))
+      :count count
+      :start start
+      :from (backtrace-start-frame from))
+     (nreverse rbacktrace)))
+
+(defun frame-call-as-list (frame &key (method-frame-style *method-frame-style*))
+  (multiple-value-bind (name args info)
+      (frame-call frame :method-frame-style method-frame-style
+                        :replace-dynamic-extent-objects t)
+    (values (cons name args) info)))
 
 (defun replace-dynamic-extent-object (obj)
   (if (stack-allocated-p obj)
@@ -327,9 +512,7 @@ thread, NIL otherwise."
     (sb!di:lambda-list-unavailable ()
       (make-unprintable-object "unavailable lambda list"))))
 
-(defvar *show-entry-point-details* nil)
-
-(defun clean-xep (name args)
+(defun clean-xep (name args info)
   (values (second name)
           (if (consp args)
               (let* ((count (first args))
@@ -345,9 +528,12 @@ thread, NIL otherwise."
                                         (make-unprintable-object "unknown"))
                           collect arg)
                     real-args))
-              args)))
+              args)
+          (if (eq (car name) 'sb!c::tl-xep)
+              (cons :tl info)
+              info)))
 
-(defun clean-&more-processor (name args)
+(defun clean-&more-processor (name args info)
   (values (second name)
           (if (consp args)
               (let* ((more (last args 2))
@@ -360,36 +546,71 @@ thread, NIL otherwise."
                       (sb!c:%more-arg-values context 0 count))
                      (list
                       (make-unprintable-object "more unavailable arguments")))))
-              args)))
+              args)
+          (cons :more info)))
 
-(defun clean-debug-fun-name (name &optional args)
-  ;; FIXME: do we need to deal with
-  ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
-  ;; &AUX-BINDINGS appear in backtraces, so they are
-  ;; left alone for now. --NS 2005-02-28
+(defun clean-fast-method (name args style info)
+  (multiple-value-bind (cname cargs)
+      (ecase style
+        (:minimal
+         (let ((gf-name (second name))
+               (real-args (cddr args)))
+           (if (and (fboundp gf-name)
+                    (notany #'sb!impl::unprintable-object-p real-args)
+                    (let ((methods (compute-applicable-methods
+                                    (fdefinition gf-name) real-args)))
+                      (and methods (not (cdr methods)))))
+               (values gf-name real-args)
+               (values (cons :method (cdr name)) real-args))))
+        (:normal
+         (values (cons :method (cdr name)) (cddr args)))
+        (:full
+         (values name args)))
+    (values cname cargs (cons :fast-method info))))
+
+(defun clean-frame-call (name args method-frame-style info)
   (if (consp name)
       (case (first name)
         ((sb!c::xep sb!c::tl-xep)
-         (clean-xep name args))
+         (clean-xep name args info))
         ((sb!c::&more-processor)
-         (clean-&more-processor name args))
-        ((sb!c::hairy-arg-processor
-          sb!c::varargs-entry sb!c::&optional-processor)
-         (clean-debug-fun-name (second name) args))
+         (clean-&more-processor name args info))
+        ((sb!c::&optional-processor)
+         (clean-frame-call (second name) args method-frame-style
+                           info))
+        ((sb!pcl::fast-method)
+         (clean-fast-method name args method-frame-style info))
         (t
-         (values name args)))
-      (values name args)))
+         (values name args info)))
+      (values name args info)))
 
-(defun frame-call (frame)
-  (flet ((clean-name-and-args (name args)
-           (if (not *show-entry-point-details*)
-               (clean-debug-fun-name name args)
-               (values name args))))
-    (let ((debug-fun (sb!di:frame-debug-fun frame)))
-      (multiple-value-bind (name args)
-          (clean-name-and-args (sb!di:debug-fun-name debug-fun)
-                               (frame-args-as-list frame))
-        (values name args (sb!di:debug-fun-kind debug-fun))))))
+(defun frame-call (frame &key (method-frame-style *method-frame-style*)
+                              replace-dynamic-extent-objects)
+  "Returns as multiple values a descriptive name for the function responsible
+for FRAME, arguments that that function, and a list providing additional
+information about the frame.
+
+Unavailable arguments are represented using dummy-objects printing as
+#<unavailable argument>.
+
+METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
+corresponding to method functions are printed. Possible values
+are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
+information.
+
+If REPLACE-DYNAMIC-EXTENT-OBJECTS is true, objects allocated on the stack of
+the current thread are replaced with dummy objects which can safely escape."
+  (let* ((debug-fun (sb!di:frame-debug-fun frame))
+         (kind (sb!di:debug-fun-kind debug-fun)))
+    (multiple-value-bind (name args info)
+        (clean-frame-call (sb!di:debug-fun-name debug-fun)
+                          (frame-args-as-list frame)
+                          method-frame-style
+                          (when kind (list kind)))
+      (let ((args (if (and (consp args) replace-dynamic-extent-objects)
+                      (mapcar #'replace-dynamic-extent-object args)
+                      args)))
+        (values name args info)))))
 
 (defun ensure-printable-object (object)
   (handler-case
@@ -411,49 +632,50 @@ thread, NIL otherwise."
 ;;; zero indicates just printing the DEBUG-FUN's name, and one
 ;;; indicates displaying call-like, one-liner format with argument
 ;;; values.
-(defun print-frame-call (frame stream &key (verbosity 1) (number nil))
+(defun print-frame-call (frame stream
+                         &key print-frame-source
+                              number
+                              (method-frame-style *method-frame-style*))
   (when number
-    (format stream "~&~S: " (sb!di:frame-number frame)))
-  (if (zerop verbosity)
-      (let ((*print-readably* nil))
-        (prin1 frame stream))
-      (multiple-value-bind (name args kind) (frame-call frame)
-        (pprint-logical-block (stream nil :prefix "(" :suffix ")")
-          ;; 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*.
-          ;; For the function arguments, we can just print normally.
-          (let ((*print-length* nil)
-                (*print-level* nil))
-            (prin1 name stream))
-          ;; 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. Special case *PRINT-PRETTY* for eval frames:
-          ;; if *PRINT-LINES* is 1, turn off pretty-printing.
-          (let ((*print-pretty*
-                  (if (and (eql 1 *print-lines*)
-                           (member name '(eval simple-eval-in-lexenv)))
-                      nil
-                      *print-pretty*))))
+    (format stream "~&~S: " (if (integerp number)
+                                number
+                                (sb!di:frame-number frame))))
+  (multiple-value-bind (name args info)
+      (frame-call frame :method-frame-style method-frame-style)
+    (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+      ;; 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*.
+      ;; For the function arguments, we can just print normally.
+      (let ((*print-length* nil)
+            (*print-level* nil)
+            (*print-pretty* nil)
+            (*print-circle* t)
+            (name (ensure-printable-object name)))
+        (write name :stream stream :escape t :pretty (equal '(lambda ()) name))
+        ;; 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.
+        (let ((args (ensure-printable-object args)))
           (if (listp args)
               (format stream "~{ ~_~S~}" args)
-              (format stream " ~S" args)))
-        (when kind
-          (format stream "[~S]" kind))))
-  (when (>= verbosity 2)
+              (format stream " ~S" args)))))
+    (when info
+      (format stream " [~{~(~A~)~^,~}]" info)))
+  (when print-frame-source
     (let ((loc (sb!di:frame-code-location frame)))
       (handler-case
-          (progn
-            ;; FIXME: Is this call really necessary here? If it is,
-            ;; then the reason for it should be unobscured.
-            (sb!di:code-location-debug-block loc)
-            (format stream "~%source: ")
-            (prin1 (code-location-source-form loc 0) stream))
-        (sb!di:debug-condition (ignore)
-          ignore)
+          (let ((source (handler-case
+                            (code-location-source-form loc 0)
+                          (error (c)
+                            (format stream "~&   error finding frame source: ~A" c)))))
+            (format stream "~%   source: ~S" source))
+        (sb!di:debug-condition ()
+          ;; This is mostly noise.
+          (when (eq :always print-frame-source)
+            (format stream "~&   no source available for frame")))
         (error (c)
-          (format stream "~&error finding source: ~A" c))))))
+          (format stream "~&   error printing frame source: ~A" c))))))
 
 ;;;; INVOKE-DEBUGGER
 
@@ -720,7 +942,8 @@ reset to ~S."
           (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*)
+          (print-backtrace :count 128 :stream *error-output*
+                           :from :interrupted-frame)
           (format
            *error-output*
            "~%unhandled condition in --disable-debugger mode, quitting~%")
@@ -863,7 +1086,7 @@ and LDB (the low-level debugger).  See also ENABLE-DEBUGGER."
              (setf *suppress-frame-print* nil))
             (t
              (terpri *debug-io*)
-             (print-frame-call *current-frame* *debug-io* :verbosity 2)))
+             (print-frame-call *current-frame* *debug-io* :print-frame-source t)))
       (loop
        (catch 'debug-loop-catcher
          (handler-bind ((error (lambda (condition)
@@ -1286,7 +1509,7 @@ and LDB (the low-level debugger).  See also ENABLE-DEBUGGER."
   (show-restarts *debug-restarts* *debug-io*))
 
 (!def-debug-command "BACKTRACE" ()
-  (backtrace (read-if-available most-positive-fixnum)))
+ (print-backtrace :count (read-if-available most-positive-fixnum)))
 
 (!def-debug-command "PRINT" ()
   (print-frame-call *current-frame* *debug-io*))

src/code/early-extensions.lisp

@@ -1154,9 +1154,11 @@
 ;;; - SB-C::MERGE-TAIL-CALLS (policy), since 1.0.53.74 (11/2011)    -> Late: 11/2012
 ;;; - SB-EXT:QUIT, since 1.0.56.55 (05/2012)                        -> Late: 05/2013
 ;;; - SB-UNIX:UNIX-EXIT, since 1.0.56.55 (05/2012)                  -> Late: 05/2013
+;;; - SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS*, since 1.1.4.9 (02/2013)  -> Late: 02/2014
 ;;;
 ;;; LATE:
 ;;; - SB-SYS:OUTPUT-RAW-BYTES, since 1.0.8.16 (06/2007)                 -> Final: anytime
+;;;   Note: make sure CLX doesn't use it anymore!
 ;;; - SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT (policy), since 1.0.19.7      -> Final: anytime
 ;;; - SB-C::STACK-ALLOCATE-VECTOR (policy), since 1.0.19.7              -> Final: anytime
 ;;; - SB-C::STACK-ALLOCATE-VALUE-CELLS (policy), since 1.0.19.7         -> Final: anytime

src/code/error-error.lisp

@@ -36,7 +36,7 @@
         (dolist (item messages)
           (princ item *terminal-io*))
         (terpri *terminal-io*)
-        (sb!debug:backtrace most-positive-fixnum *terminal-io*)
+        (sb!debug:backtrace :stream *terminal-io*)
         (force-output *terminal-io*)
         (invoke-debugger
          (coerce-to-condition "Maximum error nesting depth exceeded" nil

src/code/interr.lisp

@@ -401,9 +401,8 @@
           (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
               ((null frame))
             (when (and (sb!di::compiled-frame-p frame)
-                       (eq name (sb!debug::clean-debug-fun-name
-                                 (sb!di:debug-fun-name
-                                  (sb!di:frame-debug-fun frame)))))
+                       (eq name (sb!di:debug-fun-name
+                                 (sb!di:frame-debug-fun frame))))
               (let ((caller (sb!di:frame-down frame)))
                 (sb!di:flush-frames-above caller)
                 (return caller)))))

src/code/toplevel.lisp

@@ -131,7 +131,7 @@ means to wait indefinitely.")
      (let ((*current-error-depth* (1+ *current-error-depth*)))
        (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
        ;; arbitrary truncation
-       #!+sb-show (sb!debug:backtrace 8)
+       #!+sb-show (sb!debug:print-backtrace :count 8)
        ,@forms)))
 
 ;;; a helper function for INFINITE-ERROR-PROTECT

src/compiler/debug-dump.lisp

@@ -538,8 +538,9 @@
          (level (if #!+sb-dyncount *collect-dynamic-statistics*
                     #!-sb-dyncount nil
                     (max actual-level 2)
-                    actual-level)))
-    (cond ((zerop level))
+                    actual-level))
+         (toplevel-p (eq :toplevel (compiled-debug-fun-kind dfun))))
+    (cond ((or (zerop level) toplevel-p))
           ((and (<= level 1)
                 (let ((od (lambda-optional-dispatch fun)))
                   (or (not od)
@@ -553,7 +554,7 @@
            (setf (compiled-debug-fun-arguments dfun)
                  (compute-args fun var-locs))))
 
-    (if (>= level 2)
+    (if (and (>= level 2) (not toplevel-p))
         (multiple-value-bind (blocks tlf-num)
             (compute-debug-blocks fun var-locs)
           (setf (compiled-debug-fun-tlf-number dfun) tlf-num)

tests/debug.impure.lisp

@@ -81,7 +81,7 @@
 ;;; and that it contains the frames we expect, doesn't contain any
 ;;; "bogus stack frame"s, and contains the appropriate toplevel call
 ;;; and hasn't been cut off anywhere.
-(defun verify-backtrace (test-function frame-specs &key (allow-stunted nil))
+(defun verify-backtrace (test-function frame-specs &key (allow-stunted nil) details)
   (labels ((args-equal (want real)
              (cond ((eq '&rest (car want))
                     t)
@@ -96,39 +96,66 @@
         (handler-bind
             ((error (lambda (condition)
                       ;; find the part of the backtrace we're interested in
-                      (let* ((full-backtrace (sb-debug:backtrace-as-list))
-                             (backtrace (member (caar frame-specs) full-backtrace
-                                                :key #'car
-                                                :test #'equal)))
+                      (let (full-backtrace)
+                        (sb-debug::map-backtrace
+                         (lambda (frame)
+                           (multiple-value-bind (name args info)
+                               (sb-debug::frame-call frame #+nil #+nil
+                                                           :replace-dynamic-extent-objects t)
+                             (if details
+                                 (push (list (cons name args) info) full-backtrace)
+                                 (push (cons name args) full-backtrace)))))
 
-                        (setf result condition)
+                        (setf full-backtrace (nreverse full-backtrace))
+                        (let ((backtrace (if details
+                                             (member (caaar frame-specs)
+                                                     full-backtrace
+                                                     :key #'caar
+                                                     :test #'equal)
+                                             (member (caar frame-specs)
+                                                     full-backtrace
+                                                     :key #'car
+                                                     :test #'equal))))
 
-                        (unless backtrace
-                          (format t "~&//~S not in backtrace:~%   ~S~%"
-                                  (caar frame-specs)
-                                  full-backtrace)
-                          (setf result nil))
-                        ;; check that we have all the frames we wanted
-                        (mapcar
-                         (lambda (spec frame)
-                           (unless (or (not spec)
-                                       (and (equal (car spec) (car frame))
-                                            (args-equal (cdr spec)
-                                                        (cdr frame))))
-                             (print (list :wanted spec :got frame))
-                             (setf result nil)))
-                         frame-specs
-                         backtrace)
+                          (setf result condition)
 
-                        ;; Make sure the backtrace isn't stunted in
-                        ;; any way.  (Depends on running in the main
-                        ;; thread.) FIXME: On Windows we get two
-                        ;; extra foreign frames below regular frames.
-                        (unless (find '(sb-impl::toplevel-init) backtrace
-                                      :test #'equal)
-                          (print (list :backtrace-stunted backtrace))
-                          (setf result nil))
-                        (return-from outer-handler)))))
+                          (unless backtrace
+                            (format t "~&//~S not in backtrace:~%   ~S~%"
+                                    (caar frame-specs)
+                                    full-backtrace)
+                            (setf result nil))
+                          ;; check that we have all the frames we wanted
+                          (mapcar
+                           (lambda (spec frame)
+                             (unless (or (not spec)
+                                         (if details
+                                             (handler-case
+                                                 (and (args-equal (car spec)
+                                                                  (car frame))
+                                                      (equal (cdr spec) (cdr frame)))
+                                               (error (e)
+                                                 (print (list :spec spec :frame frame))
+                                                 (error e)))
+                                             (and (equal (car spec) (car frame))
+                                                  (args-equal (cdr spec)
+                                                              (cdr frame)))))
+                               (print (list :wanted spec :got frame))
+                               (setf result nil)))
+                           frame-specs
+                           backtrace)
+
+                          ;; Make sure the backtrace isn't stunted in
+                          ;; any way.  (Depends on running in the main
+                          ;; thread.) FIXME: On Windows we get two
+                          ;; extra foreign frames below regular frames.
+                          (unless (find (if details
+                                            '((sb-impl::toplevel-init) ())
+                                            '(sb-impl::toplevel-init))
+                                        backtrace
+                                        :test #'equal)
+                            (print (list :backtrace-stunted backtrace))
+                            (setf result nil))
+                          (return-from outer-handler))))))
           (funcall test-function)))
       result)))
 
@@ -177,12 +204,13 @@
                   ;; stunted, ending at _sigtramp, when we add :TIMEOUT NIL to
                   ;; the frame we expect. If we leave it out, the backtrace is
                   ;; fine -- but the test fails. I can only boggle right now.
-            :fails-on '(or (and :x86 :linux)
-                           (and :win32 :sb-thread)))
+            :fails-on `(or (and :x86 :linux)
+                           :darwin
+                           :win32))
   (let ((m (sb-thread:make-mutex))
         (q (sb-thread:make-waitqueue)))
     (assert (verify-backtrace
-            (lambda ()
+             (lambda ()
               (sb-thread:with-mutex (m)
                 (handler-bind ((timeout (lambda (c)
                                           (error "foo"))))
@@ -292,115 +320,108 @@
 (defbt 5 (&optional (opt (oops)))
   (list opt))
 
-(defmacro with-details (bool &body body)
-  `(let ((sb-debug:*show-entry-point-details* ,bool))
-     ,@body))
-
 (defun bug-354 (x)
   (error "XEPs in backtraces: ~S" x))
 
 (with-test (:name :bug-354)
-  (with-details t
-    (assert (not (verify-backtrace (lambda () (bug-354 354))
-                                   '((bug-354 &rest)
-                                     ((sb-c::tl-xep bug-354) &rest))))))
+  (assert (not (verify-backtrace (lambda () (bug-354 354))
+                                 '((bug-354 354)
+                                   (((bug-354 &rest) (:tl :external)) 354)))))
   (assert (verify-backtrace (lambda () (bug-354 354)) '((bug-354 354)))))
 
 ;;; FIXME: This test really should be broken into smaller pieces
 (with-test (:name (:backtrace :tl-xep))
-  (with-details t
-    (assert (verify-backtrace #'namestring
-                              '(((sb-c::tl-xep namestring) 0 ?)))))
-  (with-details nil
-    (assert (verify-backtrace #'namestring
-                              '((namestring))))))
+  (assert (verify-backtrace #'namestring
+                            '(((namestring) (:tl :external)))
+                            :details t))
+  (assert (verify-backtrace #'namestring
+                            '((namestring)))))
 
 (with-test (:name (:backtrace :more-processor))
-  (with-details t
-    (assert (verify-backtrace (lambda () (bt.1.1 :key))
-                              '(((sb-c::&more-processor bt.1.1) &rest))))
-    (assert (verify-backtrace (lambda () (bt.1.2 :key))
-                              '(((sb-c::&more-processor bt.1.2) &rest))))
-    (assert (verify-backtrace (lambda () (bt.1.3 :key))
-                              '(((sb-c::&more-processor bt.1.3) &rest)))))
-  (with-details nil
-    (assert (verify-backtrace (lambda () (bt.1.1 :key))
-                              '((bt.1.1 :key))))
-    (assert (verify-backtrace (lambda () (bt.1.2 :key))
-                              '((bt.1.2 &rest))))
-    (assert (verify-backtrace (lambda () (bt.1.3 :key))
-                              '((bt.1.3 &rest))))))
+  (assert (verify-backtrace (lambda () (bt.1.1 :key))
+                            '(((bt.1.1 :key) (:more :optional)))
+                            :details t))
+  (assert (verify-backtrace (lambda () (bt.1.2 :key))
+                            '(((bt.1.2 ?) (:more :optional)))
+                            :details t))
+  (assert (verify-backtrace (lambda () (bt.1.3 :key))
+                            '(((bt.1.3 &rest) (:more :optional)))
+                            :details t))
+  (assert (verify-backtrace (lambda () (bt.1.1 :key))
+                            '((bt.1.1 :key))))
+  (assert (verify-backtrace (lambda () (bt.1.2 :key))
+                            '((bt.1.2 &rest))))
+  (assert (verify-backtrace (lambda () (bt.1.3 :key))
+                            '((bt.1.3 &rest)))))
 
 (with-test (:name (:backtrace :xep))
-  (with-details t
-    (assert (verify-backtrace #'bt.2.1
-                              '(((sb-c::xep bt.2.1) 0 ?))))
-    (assert (verify-backtrace #'bt.2.2
-                              '(((sb-c::xep bt.2.2) &rest))))
-    (assert (verify-backtrace #'bt.2.3
-                              '(((sb-c::xep bt.2.3) &rest)))))
-  (with-details nil
-    (assert (verify-backtrace #'bt.2.1
-                              '((bt.2.1))))
-    (assert (verify-backtrace #'bt.2.2
-                              '((bt.2.2 &rest))))
-    (assert (verify-backtrace #'bt.2.3
-                              '((bt.2.3 &rest))))))
+  (assert (verify-backtrace #'bt.2.1
+                            '(((bt.2.1) (:external)))
+                            :details t))
+  (assert (verify-backtrace #'bt.2.2
+                            '(((bt.2.2 &rest) (:external)))
+                            :details t))
+  (assert (verify-backtrace #'bt.2.3
+                            '(((bt.2.3 &rest) (:external)))
+                            :details t))
+  (assert (verify-backtrace #'bt.2.1
+                            '((bt.2.1))))
+  (assert (verify-backtrace #'bt.2.2
+                            '((bt.2.2 &rest))))
+  (assert (verify-backtrace #'bt.2.3
+                            '((bt.2.3 &rest)))))
 
 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
 ;;; these functions used to have sb-c::varargs-entry debug names for their
 ;;; main lambda.
 (with-test (:name (:backtrace :varargs-entry))
-  (with-details t
-    (assert (verify-backtrace #'bt.3.1
-                              '((bt.3.1 :key nil))))
-    (assert (verify-backtrace #'bt.3.2
-                              '((bt.3.2 :key ?))))
-    (assert (verify-backtrace #'bt.3.3
-                              '((bt.3.3 &rest)))))
-  (with-details nil
-    (assert (verify-backtrace #'bt.3.1
-                              '((bt.3.1 :key nil))))
-    (assert (verify-backtrace #'bt.3.2
-                              '((bt.3.2 :key ?))))
-    (assert (verify-backtrace #'bt.3.3
-                              '((bt.3.3 &rest))))))
+  (assert (verify-backtrace #'bt.3.1
+                            '((bt.3.1 :key nil))))
+  (assert (verify-backtrace #'bt.3.2
+                            '((bt.3.2 :key ?))))
+  (assert (verify-backtrace #'bt.3.3
+                            '((bt.3.3 &rest))))
+  (assert (verify-backtrace #'bt.3.1
+                            '((bt.3.1 :key nil))))
+  (assert (verify-backtrace #'bt.3.2
+                            '((bt.3.2 :key ?))))
+  (assert (verify-backtrace #'bt.3.3
+                            '((bt.3.3 &rest)))))
 
 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
 ;;; these functions used to have sb-c::hairy-args-processor debug names for
 ;;; their main lambda.
 (with-test (:name (:backtrace :hairy-args-processor))
-  (with-details t
-    (assert (verify-backtrace #'bt.4.1
-                              '((bt.4.1 ?))))
-    (assert (verify-backtrace #'bt.4.2
-                              '((bt.4.2 ?))))
-    (assert (verify-backtrace #'bt.4.3
-                              '((bt.4.3 &rest)))))
-  (with-details nil
-    (assert (verify-backtrace #'bt.4.1
-                              '((bt.4.1 ?))))
-    (assert (verify-backtrace #'bt.4.2
-                              '((bt.4.2 ?))))
-    (assert (verify-backtrace #'bt.4.3
-                              '((bt.4.3 &rest))))))
+  (assert (verify-backtrace #'bt.4.1
+                            '((bt.4.1 ?))))
+  (assert (verify-backtrace #'bt.4.2
+                            '((bt.4.2 ?))))
+  (assert (verify-backtrace #'bt.4.3
+                            '((bt.4.3 &rest))))
+  (assert (verify-backtrace #'bt.4.1
+                            '((bt.4.1 ?))))
+  (assert (verify-backtrace #'bt.4.2
+                            '((bt.4.2 ?))))
+  (assert (verify-backtrace #'bt.4.3
+                            '((bt.4.3 &rest)))))
 
 
 (with-test (:name (:backtrace :optional-processor))
-  (with-details t
-    (assert (verify-backtrace #'bt.5.1
-                              '(((sb-c::&optional-processor bt.5.1)))))
-    (assert (verify-backtrace #'bt.5.2
-                              '(((sb-c::&optional-processor bt.5.2) &rest))))
-    (assert (verify-backtrace #'bt.5.3
-                              '(((sb-c::&optional-processor bt.5.3) &rest)))))
-  (with-details nil
-    (assert (verify-backtrace #'bt.5.1
-                              '((bt.5.1))))
-    (assert (verify-backtrace #'bt.5.2
-                              '((bt.5.2 &rest))))
-    (assert (verify-backtrace #'bt.5.3
-                              '((bt.5.3 &rest))))))
+  (assert (verify-backtrace #'bt.5.1
+                            '(((bt.5.1) (:optional)))
+                            :details t))
+  (assert (verify-backtrace #'bt.5.2
+                            '(((bt.5.2 &rest) (:optional)))
+                            :details t))
+  (assert (verify-backtrace #'bt.5.3
+                            '(((bt.5.3 &rest) (:optional)))
+                            :details t))
+  (assert (verify-backtrace #'bt.5.1
+                            '((bt.5.1))))
+  (assert (verify-backtrace #'bt.5.2
+                            '((bt.5.2 &rest))))
+  (assert (verify-backtrace #'bt.5.3
+                            '((bt.5.3 &rest)))))
 
 (write-line "//compile nil")
 (defvar *compile-nil-error* (compile nil '(lambda (x) (cons (when x (error "oops")) nil))))
@@ -523,7 +544,7 @@
     (declare (dynamic-extent dx-arg))
     (flet ((dx-arg-backtrace (x)
              (declare (optimize (debug 2)))
-             (prog1 (sb-debug:backtrace-as-list 10)
+             (prog1 (sb-debug:list-backtrace :count 10)
                (assert (sb-debug::stack-allocated-p x)))))
       (declare (notinline dx-arg-backtrace))
       (assert (member-if (lambda (frame)
@@ -541,7 +562,8 @@
              ((error (lambda (e)
                        (declare (ignore e))
                        (handler-case
-                           (sb-debug:backtrace 100 (make-broadcast-stream))
+                           (sb-debug:print-backtrace :count 100
+                                                     :stream (make-broadcast-stream))
                          (error ()
                            (throw 'done :error))
                          (:no-error ()

tests/run-tests.lisp

@@ -141,7 +141,7 @@
                                 (t
                                  (format *error-output* "~&Unhandled ~a: ~a~%"
                                          (type-of condition) condition)
-                                 (sb-debug:backtrace)))
+                                 (sb-debug:print-backtrace)))
                           (invoke-restart 'skip-file))))
               ,test-code)
           (skip-file ()
@@ -174,7 +174,7 @@
           (t
            (format *error-output* "~&Unhandled ~a: ~a~%"
                    (type-of condition) condition)
-           (sb-debug:backtrace)))
+           (sb-debug:print-backtrace)))
     (invoke-restart 'skip-file)))
 
 (defun append-failures (&optional (failures *failures*))

tests/script.test.sh

@@ -29,9 +29,9 @@ check_status_maybe_lose "--script exit status from EXIT" $? 7 "(status good)"
 echo '(error "oops")' > $tmpscript
 run_sbcl --script $tmpscript 1> $tmpout 2> $tmperr
 check_status_maybe_lose "--script exit status from ERROR" $? 1 "(error implies 1)"
-grep BACKTRACE $tmpout > /dev/null
+grep Backtrace $tmpout > /dev/null
 check_status_maybe_lose "--script backtrace not to stdout" $? 1 "(ok)"
-grep BACKTRACE $tmperr > /dev/null
+grep Backtrace $tmperr > /dev/null
 check_status_maybe_lose "--script backtrace to stderr" $? 0 "(ok)"
 
 echo 'nil'> $tmpscript