From 492dce07cf27b3cbee8ce4800c938fcb884aa53e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 15 Nov 2010 17:21:25 +0200 Subject: [PATCH] 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 | 11 +- doc/manual/debugger.texinfo | 15 +- package-data-list.lisp-expr | 14 +- src/code/debug.lisp | 441 ++++++++++++++++++++++++++++++---------- src/code/early-extensions.lisp | 2 + src/code/error-error.lisp | 2 +- src/code/interr.lisp | 5 +- src/code/toplevel.lisp | 2 +- src/compiler/debug-dump.lisp | 7 +- tests/debug.impure.lisp | 268 +++++++++++++----------- tests/run-tests.lisp | 4 +- tests/script.test.sh | 4 +- 12 files changed, 514 insertions(+), 261 deletions(-) diff --git a/NEWS b/NEWS index ec02634..0dd15ae 100644 --- a/NEWS +++ b/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. diff --git a/doc/manual/debugger.texinfo b/doc/manual/debugger.texinfo index d1e0c9c..15abf78 100644 --- a/doc/manual/debugger.texinfo +++ b/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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 8560e0b..1dd2e78 100644 --- a/package-data-list.lisp-expr +++ b/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" diff --git a/src/code/debug.lisp b/src/code/debug.lisp index b9918ab..df913ba 100644 --- a/src/code/debug.lisp +++ b/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))) - -(defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*)) +(declaim (unsigned-byte *backtrace-frame-count*)) +(defvar *backtrace-frame-count* 1000 + "Default number of frames to backtrace. Defaults to 1000.") + +(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 + + ( ...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 [*] (*)) ...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 [*] (*)) ...args...) + + or + + ((sb-pcl:slow-method [*] (*)) ...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. - -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))) - -(defun frame-call-as-list (frame) - (multiple-value-bind (name args) (frame-call frame) - (cons name args))) + "Returns a list describing the call stack. Each frame is represented +by a sublist: + + \( ...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 #. 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-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-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-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))) - -(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)))))) + (values name args info))) + (values name args info))) + +(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 +#. + +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*)) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 6e077f1..7db471f 100644 --- a/src/code/early-extensions.lisp +++ b/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 diff --git a/src/code/error-error.lisp b/src/code/error-error.lisp index 5d3be6f..cefeab5 100644 --- a/src/code/error-error.lisp +++ b/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 diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 82cc549..3e8f95f 100644 --- a/src/code/interr.lisp +++ b/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))))) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index d3f523f..54819e1 100644 --- a/src/code/toplevel.lisp +++ b/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 diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index f6db341..35929cc 100644 --- a/src/compiler/debug-dump.lisp +++ b/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) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 7f6d1bc..8941b59 100644 --- a/tests/debug.impure.lisp +++ b/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))) - - (setf result condition) - - (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) - - ;; 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))))) + (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 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)))) + + (setf result condition) + + (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 () diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index b67497e..1020dad 100644 --- a/tests/run-tests.lisp +++ b/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*)) diff --git a/tests/script.test.sh b/tests/script.test.sh index 48da103..6adfcf0 100644 --- a/tests/script.test.sh +++ b/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 -- 1.7.10.4