From: Nikodemus Siivola Date: Tue, 12 Jun 2012 05:36:58 +0000 (+0300) Subject: fix long-standing debug-name confusion X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d720bc359f03734ccb9baf66cb45dc01d623f369;p=sbcl.git fix long-standing debug-name confusion The calls to IR1-CONVERT-LAMBDA-BODY with the a VARARGS-ENTRY and HAIRY-ARG-PROCESSOR debug-names were no such things. These calls produces the actual lambda for the main body of the function, and as such should have the original source-name and debug-name. As proof of the pudding, we previously failed to detect several known function that are recursive but aren't marked as such in the DEFKNOWNs. With this that changes, so fix the DEFKNOWNs. --- diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index dd1760c..775924a 100644 --- a/contrib/sb-sprof/sb-sprof.lisp +++ b/contrib/sb-sprof/sb-sprof.lisp @@ -865,9 +865,7 @@ The following keyword args are recognized: (if (and (consp name) (member (first name) '(sb-c::xep sb-c::tl-xep sb-c::&more-processor - sb-c::varargs-entry sb-c::top-level-form - sb-c::hairy-arg-processor sb-c::&optional-processor))) (second name) name))) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 69715ba..59a3aad 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -381,14 +381,14 @@ thread, NIL otherwise." (values name args))) (defun frame-call (frame) - (labels ((clean-name-and-args (name args) - (if (not *show-entry-point-details*) - (clean-debug-fun-name name args) - (values name args)))) + (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)) + (frame-args-as-list frame)) (values name args (sb!di:debug-fun-kind debug-fun)))))) (defun ensure-printable-object (object) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 1ff4843..8fede70 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -253,7 +253,7 @@ (defknown expt (number number) number (movable foldable flushable explicit-check recursive)) (defknown log (number &optional real) irrational - (movable foldable flushable explicit-check)) + (movable foldable flushable explicit-check recursive)) (defknown sqrt (number) irrational (movable foldable flushable explicit-check)) (defknown isqrt (unsigned-byte) unsigned-byte @@ -311,10 +311,14 @@ (defknown (numerator denominator) (rational) integer (movable foldable flushable)) -(defknown (floor ceiling truncate round) +(defknown (floor ceiling round) (real &optional real) (values integer real) (movable foldable flushable explicit-check)) +(defknown truncate + (real &optional real) (values integer real) + (movable foldable flushable explicit-check recursive)) + (defknown %multiply-high (word word) word (movable foldable flushable)) @@ -1159,10 +1163,12 @@ :directory :name :type :version)) generalized-boolean - ()) + (recursive)) + (defknown pathname-match-p (pathname-designator pathname-designator) generalized-boolean ()) + (defknown translate-pathname (pathname-designator pathname-designator pathname-designator &key) @@ -1187,7 +1193,7 @@ (:end sequence-end) (:junk-allowed t)) (values (or pathname null) sequence-end) - ()) + (recursive)) (defknown merge-pathnames (pathname-designator &optional pathname-designator pathname-version) @@ -1337,7 +1343,7 @@ (defknown apropos (string-designator &optional package-designator t) (values)) (defknown apropos-list (string-designator &optional package-designator t) list - (flushable)) + (flushable recursive)) (defknown get-decoded-time () (values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 2e9e66a..5501a62 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -740,14 +740,15 @@ (main-vals (arg-info-default info)) (bind-vals n-val))))) - (let* ((name (or debug-name source-name)) - (main-entry (ir1-convert-lambda-body + (let* ((main-entry (ir1-convert-lambda-body body (main-vars) :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) :post-binding-lexenv post-binding-lexenv - :debug-name (debug-name 'varargs-entry name) + :source-name source-name + :debug-name debug-name :system-lambda system-lambda)) + (name (or debug-name source-name)) (last-entry (convert-optional-entry main-entry default-vars (main-vals) () name))) (setf (optional-dispatch-main-entry res) @@ -821,7 +822,8 @@ :aux-vars aux-vars :aux-vals aux-vals :post-binding-lexenv post-binding-lexenv - :debug-name (debug-name 'hairy-arg-processor name) + :source-name source-name + :debug-name debug-name :system-lambda system-lambda))) (setf (optional-dispatch-main-entry res) fun) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index dab0481..65683d4 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -346,14 +346,17 @@ (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 - '(((sb-c::varargs-entry bt.3.1) :key nil)))) + '((bt.3.1 :key nil)))) (assert (verify-backtrace #'bt.3.2 - '(((sb-c::varargs-entry bt.3.2) :key ?)))) + '((bt.3.2 :key ?)))) (assert (verify-backtrace #'bt.3.3 - '(((sb-c::varargs-entry bt.3.3) &rest))))) + '((bt.3.3 &rest))))) (with-details nil (assert (verify-backtrace #'bt.3.1 '((bt.3.1 :key nil)))) @@ -362,14 +365,17 @@ (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 - '(((sb-c::hairy-arg-processor bt.4.1) ?)))) + '((bt.4.1 ?)))) (assert (verify-backtrace #'bt.4.2 - '(((sb-c::hairy-arg-processor bt.4.2) ?)))) + '((bt.4.2 ?)))) (assert (verify-backtrace #'bt.4.3 - '(((sb-c::hairy-arg-processor bt.4.3) &rest))))) + '((bt.4.3 &rest))))) (with-details nil (assert (verify-backtrace #'bt.4.1 '((bt.4.1 ?))))