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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 ?))))