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.
(if (and (consp name)
(member (first name)
'(sb-c::xep sb-c::tl-xep sb-c::&more-processor
(if (and (consp name)
(member (first name)
'(sb-c::xep sb-c::tl-xep sb-c::&more-processor
- sb-c::hairy-arg-processor
sb-c::&optional-processor)))
(second name)
name)))
sb-c::&optional-processor)))
(second name)
name)))
(values name args)))
(defun frame-call (frame)
(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)
(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)
(values name args (sb!di:debug-fun-kind debug-fun))))))
(defun ensure-printable-object (object)
(defknown expt (number number) number
(movable foldable flushable explicit-check recursive))
(defknown log (number &optional real) irrational
(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
(defknown sqrt (number) irrational
(movable foldable flushable explicit-check))
(defknown isqrt (unsigned-byte) unsigned-byte
(defknown (numerator denominator) (rational) integer
(movable foldable flushable))
(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))
(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))
(defknown %multiply-high (word word) word
(movable foldable flushable))
:directory :name
:type :version))
generalized-boolean
:directory :name
:type :version))
generalized-boolean
(defknown pathname-match-p (pathname-designator pathname-designator)
generalized-boolean
())
(defknown pathname-match-p (pathname-designator pathname-designator)
generalized-boolean
())
(defknown translate-pathname (pathname-designator
pathname-designator
pathname-designator &key)
(defknown translate-pathname (pathname-designator
pathname-designator
pathname-designator &key)
(:end sequence-end)
(:junk-allowed t))
(values (or pathname null) sequence-end)
(:end sequence-end)
(:junk-allowed t))
(values (or pathname null) sequence-end)
(defknown merge-pathnames
(pathname-designator &optional pathname-designator pathname-version)
(defknown merge-pathnames
(pathname-designator &optional pathname-designator pathname-version)
(defknown apropos (string-designator &optional package-designator t) (values))
(defknown apropos-list (string-designator &optional package-designator t) list
(defknown apropos (string-designator &optional package-designator t) (values))
(defknown apropos-list (string-designator &optional package-designator t) list
(defknown get-decoded-time ()
(values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
(defknown get-decoded-time ()
(values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
(main-vals (arg-info-default info))
(bind-vals n-val)))))
(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
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))
: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)
(last-entry (convert-optional-entry main-entry default-vars
(main-vals) () name)))
(setf (optional-dispatch-main-entry res)
:aux-vars aux-vars
:aux-vals aux-vals
:post-binding-lexenv post-binding-lexenv
: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)
:system-lambda system-lambda)))
(setf (optional-dispatch-main-entry res) fun)
(assert (verify-backtrace #'bt.2.3
'((bt.2.3 &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
(with-test (:name (:backtrace :varargs-entry))
(with-details t
(assert (verify-backtrace #'bt.3.1
- '(((sb-c::varargs-entry bt.3.1) :key nil))))
(assert (verify-backtrace #'bt.3.2
(assert (verify-backtrace #'bt.3.2
- '(((sb-c::varargs-entry bt.3.2) :key ?))))
(assert (verify-backtrace #'bt.3.3
(assert (verify-backtrace #'bt.3.3
- '(((sb-c::varargs-entry bt.3.3) &rest)))))
(with-details nil
(assert (verify-backtrace #'bt.3.1
'((bt.3.1 :key nil))))
(with-details nil
(assert (verify-backtrace #'bt.3.1
'((bt.3.1 :key nil))))
(assert (verify-backtrace #'bt.3.3
'((bt.3.3 &rest))))))
(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
(with-test (:name (:backtrace :hairy-args-processor))
(with-details t
(assert (verify-backtrace #'bt.4.1
- '(((sb-c::hairy-arg-processor bt.4.1) ?))))
(assert (verify-backtrace #'bt.4.2
(assert (verify-backtrace #'bt.4.2
- '(((sb-c::hairy-arg-processor bt.4.2) ?))))
(assert (verify-backtrace #'bt.4.3
(assert (verify-backtrace #'bt.4.3
- '(((sb-c::hairy-arg-processor bt.4.3) &rest)))))
(with-details nil
(assert (verify-backtrace #'bt.4.1
'((bt.4.1 ?))))
(with-details nil
(assert (verify-backtrace #'bt.4.1
'((bt.4.1 ?))))