From 70b1a2776c9f3947503b4bcbb8ca5d944e635fb0 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 20 Mar 2005 09:03:40 +0000 Subject: [PATCH 1/1] 0.8.20.28 pretty backtraces with unavailable arguments & lambda-lists * fix issue reported by Juho Snellman on sbcl-devel 2005-03-18, and some related problems. * minor combinatorial explosion in debug.impure.lisp; most tests still skipped on x86/linux :/ --- src/code/debug.lisp | 51 ++++++++++++------- tests/debug.impure.lisp | 130 ++++++++++++++++++++++++++++++++++------------- version.lisp-expr | 2 +- 3 files changed, 129 insertions(+), 54 deletions(-) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index b20dc7e..7ce7153 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -270,29 +270,44 @@ is how many frames to show." (legal-fun-name-p '(lambda ())) (defvar *show-entry-point-details* nil) +(defun clean-xep (name args) + (values (second name) + (if (consp args) + (let ((count (first args)) + (real-args (rest args))) + (if (fixnump count) + (subseq real-args 0 + (min count (length real-args))) + real-args)) + args))) + +(defun clean-&more-processor (name args) + (values (second name) + (if (consp args) + (let* ((more (last args 2)) + (context (first more)) + (count (second more))) + (append + (butlast args 2) + (if (fixnump count) + (multiple-value-list + (sb!c:%more-arg-values context 0 count)) + (list + (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-name-and-args - (second name) - (let ((count (first args)) - (real-args (rest args))) - (subseq real-args 0 (min count (length real-args)))))) + (clean-xep name args)) ((sb!c::&more-processor) - (clean-name-and-args - (second name) - (let* ((more (last args 2)) - (context (first more)) - (count (second more))) - (append (butlast args 2) - (multiple-value-list - (sb!c:%more-arg-values context 0 count)))))) - ;; 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 + (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)) @@ -363,7 +378,7 @@ is how many frames to show." (sb!di:debug-condition (ignore) ignore) (error (c) - (format stream "error finding source: ~A" c)))))) + (format stream "~&error finding source: ~A" c)))))) ;;;; INVOKE-DEBUGGER diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 1b31eb1..96bd754 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -68,10 +68,10 @@ ;;; and hasn't been cut off anywhere. (defun verify-backtrace (test-function frame-specs &key (allow-stunted nil)) (labels ((args-equal (want real) - (cond ((endp want) - (endp real)) - ((eq '&rest (car want)) + (cond ((eq '&rest (car want)) t) + ((endp want) + (endp real)) ((or (eq '? (car want)) (equal (car want) (car real))) (args-equal (cdr want) (cdr real))) (t @@ -195,20 +195,34 @@ (defun oops () (error "oops")) -(defun bt.1 (&key key) +(defmacro defbt (n ll &body body) + `(progn + ;; normal debug info + (defun ,(intern (format nil "BT.~A.1" n)) ,ll + ,@body) + ;; no arguments saved + (defun ,(intern (format nil "BT.~A.2" n)) ,ll + (declare (optimize (debug 1) (speed 3))) + ,@body) + ;; no lambda-list saved + (defun ,(intern (format nil "BT.~A.3" n)) ,ll + (declare (optimize (debug 0))) + ,@body))) + +(defbt 1 (&key key) (list key)) -(defun bt.2 (x) +(defbt 2 (x) (list x)) -(defun bt.3 (&key (key (oops))) +(defbt 3 (&key (key (oops))) (list key)) ;;; ERROR instead of OOPS so that tail call elimination doesn't happen -(defun bt.4 (&optional opt) +(defbt 4 (&optional opt) (list (error "error"))) -(defun bt.5 (&optional (opt (oops))) +(defbt 5 (&optional (opt (oops))) (list opt)) #-(and x86 linux) @@ -216,53 +230,99 @@ `(let ((sb-debug:*show-entry-point-details* ,bool)) ,@body))) - ;; &MORE-PROCESSOR + ;; TL-XEP + (print :tl-xep) (with-details t - (assert (verify-backtrace (lambda () (bt.1 :key)) - '(((sb-c::&more-processor bt.1) &rest))))) + (assert (verify-backtrace #'namestring + '(((sb-c::tl-xep namestring) 0 ?))))) (with-details nil - (assert (verify-backtrace (lambda () (bt.1 :key)) - '((bt.1 :key))))) + (assert (verify-backtrace #'namestring + '((namestring))))) - ;; XEP + + ;; &MORE-PROCESSOR (with-details t - (assert (verify-backtrace #'bt.2 - '(((sb-c::xep bt.2) 0 ?))))) + (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 #'bt.2 - '((bt.2))))) + (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))))) - ;; TL-XEP + ;; XEP + (print :xep) (with-details t - (assert (verify-backtrace #'namestring - '(((sb-c::tl-xep namestring) 0 ?))))) + (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 #'namestring - '((namestring))))) + (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))))) ;; VARARGS-ENTRY + (print :varargs-entry) (with-details t - (assert (verify-backtrace #'bt.3 - '(((sb-c::varargs-entry bt.3) :key nil))))) + (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 - (assert (verify-backtrace #'bt.3 - '((bt.3 :key 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))))) ;; HAIRY-ARG-PROCESSOR + (print :hairy-args-processor) (with-details t - (assert (verify-backtrace #'bt.4 - '(((sb-c::hairy-arg-processor bt.4) ?))))) + (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 - (assert (verify-backtrace #'bt.4 - '((bt.4 ?))))) + (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))))) ;; &OPTIONAL-PROCESSOR + (print :optional-processor) (with-details t - (assert (verify-backtrace #'bt.5 - '(((sb-c::&optional-processor bt.5)))))) + (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 - '((bt.5)))))) + (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)))))) ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 50ff475..1a0c3d7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.20.27" +"0.8.20.28" -- 1.7.10.4