From e6bb8e10a8e53a74b2346a246b69ef18c0807638 Mon Sep 17 00:00:00 2001 From: Attila Lendvai Date: Fri, 3 Aug 2007 15:48:28 +0200 Subject: [PATCH] Improve frame cleaning in the debugger Added a *verbosity* instead of *show-entry-point-details* and implement sb-pcl::fast-method "cleaning" when the verbosity is below 2. This is not a cleaning strictly speaking, because it's the valid name of the methods, but from a user's point of view it may be considered noise therefore it's simplified on low enough verbosity levels. --- doc/manual/debugger.texinfo | 4 +- package-data-list.lisp-expr | 2 +- src/code/debug.lisp | 175 +++++++++++++++++++++++++++----------------- tests/debug.impure.lisp | 28 +++---- 4 files changed, 125 insertions(+), 84 deletions(-) diff --git a/doc/manual/debugger.texinfo b/doc/manual/debugger.texinfo index 45a4b99f3..fbb496d09 100644 --- a/doc/manual/debugger.texinfo +++ b/doc/manual/debugger.texinfo @@ -307,7 +307,7 @@ 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 +by setting @code{sb-debug:*verbosity*}; this is primarily useful for debugging SBCL itself, but may help pinpoint problems that occur during lambda-list processing. @@ -332,7 +332,7 @@ 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*} os true. +visible only if @code{sb-debug:*verbosity*} is high enough. @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 0dbc4d0bb..357c64481 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -398,7 +398,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*DEBUG-CONDITION*" "*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*" "*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*" - "*SHOW-ENTRY-POINT-DETAILS*" + "*VERBOSITY*" "*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*" "*TRACE-FRAME*" "*TRACED-FUN-LIST*" "ARG" "BACKTRACE" "BACKTRACE-AS-LIST" "INTERNAL-DEBUG" "VAR" diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 1726964f8..3d75a49ab 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -267,10 +267,12 @@ is how many frames to show." () (make-unprintable-object "unavailable lambda list"))))) -(defvar *show-entry-point-details* nil) +(defvar *verbosity* 1) (defun clean-xep (name args) - (values (second name) + (values (or (and (consp name) + (second name)) + name) (if (consp args) (let ((count (first args)) (real-args (rest args))) @@ -281,7 +283,9 @@ is how many frames to show." args))) (defun clean-&more-processor (name args) - (values (second name) + (values (or (and (consp name) + (second name)) + name) (if (consp args) (let* ((more (last args 2)) (context (first more)) @@ -295,31 +299,64 @@ is how many frames to show." (make-unprintable-object "more unavailable arguments"))))) args))) -(defun frame-call (frame) - (labels ((clean-name-and-args (name args) - (if (and (consp name) (not *show-entry-point-details*)) - ;; 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 - (case (first name) - ((sb!c::xep sb!c::tl-xep) - (clean-xep name args)) - ((sb!c::&more-processor) - (clean-&more-processor name args)) - ((sb!c::hairy-arg-processor - sb!c::varargs-entry sb!c::&optional-processor) - (clean-name-and-args (second name) args)) - (t - (values 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 - (when *show-entry-point-details* - (sb!di:debug-fun-kind debug-fun))))))) +;; Cleaning sb-pcl::fast-method is a bit different then other cleanings in that +;; sb-pcl::fast-method is actually part of the method name. But it makes the +;; backtrace less readable, so we do it on (< verbosity 2) +(defun clean-fast-method (name args) + (values (or (and (consp name) + (rest name)) + name) + (if (and (consp args) + (consp name)) + (let ((last (car (last name)))) + (or (and (consp last) + ;; safely get the length of the lambda-list and the last + ;; n args are the actual args of the function call + (loop for cell = last :then (cdr cell) + while cell + unless (consp cell) do (return nil) + count 1 :into arg-count + finally (return (last args arg-count)))) + args)) + args))) + +(defun frame-call (frame &key (verbosity *verbosity*)) + (let* ((*verbosity* verbosity) + (debug-fun (sb!di:frame-debug-fun frame)) + (name (sb!di:debug-fun-name debug-fun)) + (args (frame-args-as-list frame))) + (labels ((clean-name-and-args (name args) + (if (consp name) + ;; 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 + (case (first name) + ((sb!c::xep sb!c::tl-xep) + (clean-xep name args)) + ((sb!c::&more-processor) + (clean-&more-processor name args)) + ((sb!pcl::fast-method) + (if (< verbosity 2) + (clean-fast-method name args) + (values name args))) + ((sb!c::hairy-arg-processor + sb!c::varargs-entry sb!c::&optional-processor) + (clean-name-and-args (second name) args)) + (t (values name args))) + (values name args)))) + (unless (>= *verbosity* 2) + (loop named cleaning do + (progn + (multiple-value-bind (new-name new-args) + (clean-name-and-args name args) + (when (or (not new-name) + (and (eq new-name name) + (eq new-args args))) + (return-from cleaning)) + (setf name new-name + args new-args))))) + (values name args (sb!di:debug-fun-kind debug-fun))))) (defun ensure-printable-object (object) (handler-case @@ -341,43 +378,45 @@ is how many frames to show." ;;; 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)) - (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 (ensure-printable-object 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. - (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) - (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) - (error (c) - (format stream "~&error finding source: ~A" c)))))) +(defun print-frame-call (frame stream &key (verbosity *verbosity*) (number nil)) + (let ((*verbosity* verbosity)) + (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 (ensure-printable-object 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. + (let ((args (ensure-printable-object args))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args)))) + (when (and kind (> *verbosity* 1)) + (format stream " [~S]" kind)))) + (when (>= *verbosity* 2) + (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) + (error (c) + (format stream "~&error finding source: ~A" c))))))) ;;;; INVOKE-DEBUGGER @@ -417,7 +456,8 @@ is how many frames to show." ;; any default we might use is less useful than just reusing ;; the global values. (original-package *package*) - (original-print-pretty *print-pretty*)) + (original-print-pretty *print-pretty*) + (original-print-right-margin *print-right-margin*)) (with-standard-io-syntax (with-sane-io-syntax (let (;; We want the printer and reader to be in a useful @@ -437,6 +477,7 @@ is how many frames to show." ;; rebindings here. (sb!kernel:*current-level-in-print* 0) (*package* original-package) + (*print-right-margin* original-print-right-margin) (*print-pretty* original-print-pretty) ;; Clear the circularity machinery to try to to reduce the ;; pain from sharing the circularity table across all @@ -758,7 +799,7 @@ reset to ~S." (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*))) (loop (catch 'debug-loop-catcher (handler-bind ((error (lambda (condition) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 28b7f4d20..713ad0e3b 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -256,29 +256,29 @@ (with-test (:name (:backtrace :misc) :fails-on '(or (and :x86 (or :sunos)) (and :x86-64 :darwin))) - (macrolet ((with-details (bool &body body) - `(let ((sb-debug:*show-entry-point-details* ,bool)) + (macrolet ((with-verbosity (level &body body) + `(let ((sb-debug:*verbosity* ,level)) ,@body))) ;; TL-XEP (print :tl-xep) - (with-details t + (with-verbosity 3 (assert (verify-backtrace #'namestring '(((sb-c::tl-xep namestring) 0 ?))))) - (with-details nil + (with-verbosity 0 (assert (verify-backtrace #'namestring '((namestring))))) ;; &MORE-PROCESSOR - (with-details t + (with-verbosity 3 (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 + (with-verbosity 0 (assert (verify-backtrace (lambda () (bt.1.1 :key)) '((bt.1.1 :key)))) (assert (verify-backtrace (lambda () (bt.1.2 :key)) @@ -288,14 +288,14 @@ ;; XEP (print :xep) - (with-details t + (with-verbosity 3 (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 + (with-verbosity 0 (assert (verify-backtrace #'bt.2.1 '((bt.2.1)))) (assert (verify-backtrace #'bt.2.2 @@ -305,14 +305,14 @@ ;; VARARGS-ENTRY (print :varargs-entry) - (with-details t + (with-verbosity 3 (assert (verify-backtrace #'bt.3.1 '(((sb-c::varargs-entry bt.3.1) :key nil)))) (assert (verify-backtrace #'bt.3.2 '(((sb-c::varargs-entry bt.3.2) :key ?)))) (assert (verify-backtrace #'bt.3.3 '(((sb-c::varargs-entry bt.3.3) &rest))))) - (with-details nil + (with-verbosity 0 (assert (verify-backtrace #'bt.3.1 '((bt.3.1 :key nil)))) (assert (verify-backtrace #'bt.3.2 @@ -322,14 +322,14 @@ ;; HAIRY-ARG-PROCESSOR (print :hairy-args-processor) - (with-details t + (with-verbosity 3 (assert (verify-backtrace #'bt.4.1 '(((sb-c::hairy-arg-processor bt.4.1) ?)))) (assert (verify-backtrace #'bt.4.2 '(((sb-c::hairy-arg-processor bt.4.2) ?)))) (assert (verify-backtrace #'bt.4.3 '(((sb-c::hairy-arg-processor bt.4.3) &rest))))) - (with-details nil + (with-verbosity 0 (assert (verify-backtrace #'bt.4.1 '((bt.4.1 ?)))) (assert (verify-backtrace #'bt.4.2 @@ -339,14 +339,14 @@ ;; &OPTIONAL-PROCESSOR (print :optional-processor) - (with-details t + (with-verbosity 3 (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 + (with-verbosity 0 (assert (verify-backtrace #'bt.5.1 '((bt.5.1)))) (assert (verify-backtrace #'bt.5.2 -- 2.11.4.GIT