1.0.13.38: final part of the debug-name improvements

 * Use NAME-LAMBDALIKE to construct the debug-name if :NAME is NIL.

 * Also make sure the SOURCE-NAME is not NIL, but .ANONYMOUS. if none
   is provided.

 * Correct handling of &OPTIONAL-PROCESSOR debug-names: the debug-name
   keyword is provided by the callers, so we cannot default it as part
   of the keyword parsing (in case it is NIL), additionally, even if
   we have a debug-name already, we still want to make up an
   &OPTIONAL-PROCESSOR debug-name.

 * Ensure (and strategically AVER) that we have a non-null debug-name
   for things which are .ANONYMOUS. -- by making up one using
   NAME-LAMBDALIKE if nothing else.

 * AVER that the second argument of DEBUG-NAME is not NIL.

 * Test that (COMPILE NIL '(LAMBDA ...)) doesn't make function which
   backtrace as NIL anymore.

diff --git a/NEWS b/NEWS
index badacbc..ad29cd8 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes in sbcl-1.0.14 relative to sbcl-1.0.13:
   * new feature: SB-EXT:*EXIT-HOOKS* are called when the process exits
     (see documentation for details.)
   * revived support for OpenBSD (contributed by Josh Elsasser)
+  * bug fix: functions compiled using (COMPILE NIL '(LAMBDA ...))
+    no longer appear as (NIL ...) frames in backtraces.
   * bug fix: ROOM no longer suffers from occasional (AVER (SAP=
     CURRENT END)) failures.
   * bug fix: RESOLVE-CONFLICT (and the other name conflict machinery)

diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp
index ace5c68..9df9131 100644 (file)
--- a/src/compiler/early-c.lisp
+++ b/src/compiler/early-c.lisp
@@ -219,6 +219,8 @@ convention (names like *FOO*) for special variables" symbol))
       *debug-name-ellipsis* (make-debug-name-marker))
 
 (defun debug-name (type thing)
+  ;; We can _always_ do better thing NIL for this.
+  (aver thing)
   (let ((*debug-name-punt* nil))
     (labels ((walk (x)
                (typecase x

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 5c51389..bd8f75a 100644 (file)
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -773,6 +773,7 @@
   (declare (type optional-dispatch res)
            (list default-vars default-vals entry-vars entry-vals vars body
                  aux-vars aux-vals))
+  (aver (or debug-name (neq '.anonymous. source-name)))
   (cond ((not vars)
          (if (optional-dispatch-keyp res)
              ;; Handle &KEY with no keys...
@@ -858,17 +859,17 @@
 ;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we
 ;;; figure out the MIN-ARGS and MAX-ARGS.
 (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals
-                                      &key
-                                      post-binding-lexenv
-                                      (source-name '.anonymous.)
-                                      (debug-name
-                                       (debug-name '&optional-dispatch vars)))
+                                 &key post-binding-lexenv
+                                 (source-name '.anonymous.)
+                                 debug-name)
   (declare (list body vars aux-vars aux-vals))
+  (aver (or debug-name (neq '.anonymous. source-name)))
   (let ((res (make-optional-dispatch :arglist vars
                                      :allowp allowp
                                      :keyp keyp
                                      :%source-name source-name
-                                     :%debug-name debug-name
+                                     :%debug-name (debug-name '&optional-dispatch
+                                                              (or debug-name source-name))
                                      :plist `(:ir1-environment
                                               (,*lexenv*
                                                ,*current-path*))))
@@ -899,7 +900,8 @@
     (compiler-error
      "The lambda expression has a missing or non-list lambda list:~%  ~S"
      form))
-
+  (unless (or debug-name (neq '.anonymous. source-name))
+    (setf debug-name (name-lambdalike form)))
   (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
       (make-lambda-vars (cadr form))
     (multiple-value-bind (forms decls) (parse-body (cddr form))
@@ -970,6 +972,8 @@
                                &key
                                (source-name '.anonymous.)
                                debug-name)
+  (when (and (not debug-name) (eq '.anonymous. source-name))
+    (setf debug-name (name-lambdalike thing)))
   (ecase (car thing)
     ((lambda)
      (ir1-convert-lambda thing
@@ -1016,6 +1020,8 @@
                                   (source-name '.anonymous.)
                                   debug-name
                                   system-lambda)
+  (when (and (not debug-name) (eq '.anonymous. source-name))
+    (setf debug-name (name-lambdalike fun)))
   (destructuring-bind (decls macros symbol-macros &rest body)
       (if (eq (car fun) 'lambda-with-lexenv)
           (cdr fun)

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 9ee255c..0c1ce53 100644 (file)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -973,7 +973,7 @@
                            (maybe-frob (optional-dispatch-main-entry f)))
                          result))))
 
-(defun make-functional-from-toplevel-lambda (definition
+(defun make-functional-from-toplevel-lambda (lambda-expression
                                              &key
                                              name
                                              (path
@@ -983,17 +983,15 @@
                                               (missing-arg)))
   (let* ((*current-path* path)
          (component (make-empty-component))
-         (*current-component* component))
-    (setf (component-name component)
-          (debug-name 'initial-component name))
-    (setf (component-kind component) :initial)
+         (*current-component* component)
+         (debug-name-tail (or name (name-lambdalike lambda-expression)))
+         (source-name (or name '.anonymous.)))
+    (setf (component-name component) (debug-name 'initial-component debug-name-tail)
+          (component-kind component) :initial)
     (let* ((locall-fun (let ((*allow-instrumenting* t))
                          (funcall #'ir1-convert-lambdalike
-                                  definition
-                                  :source-name name)))
-           (debug-name (debug-name 'tl-xep
-                                   (or name
-                                       (functional-%source-name locall-fun))))
+                                  lambda-expression
+                                  :source-name source-name)))
            ;; Convert the XEP using the policy of the real
            ;; function. Otherwise the wrong policy will be used for
            ;; deciding whether to type-check the parameters of the
@@ -1002,8 +1000,8 @@
            (*lexenv* (make-lexenv :policy (lexenv-policy
                                            (functional-lexenv locall-fun))))
            (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
-                                    :source-name (or name '.anonymous.)
-                                    :debug-name debug-name)))
+                                    :source-name source-name
+                                    :debug-name (debug-name 'tl-xep debug-name-tail))))
       (when name
         (assert-global-function-definition-type name locall-fun))
       (setf (functional-entry-fun fun) locall-fun

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 5d52ddc..8b27b70 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -92,17 +92,17 @@
         (handler-bind
             ((error (lambda (condition)
                       ;; find the part of the backtrace we're interested in
-                      (let ((backtrace (progn
-                                         ;; (backtrace 13)
-                                         (member (caar frame-specs)
-                                                 (sb-debug:backtrace-as-list)
-                                                 :key #'car
-                                                 :test #'equal))))
-
+                      (let* ((full-backtrace (sb-debug:backtrace-as-list))
+                             (backtrace (member (caar frame-specs) full-backtrace
+                                                :key #'car
+                                                :test #'equal)))
+                        
                         (setf result condition)
 
                         (unless backtrace
-                          (print :missing-backtrace)
+                          (format t "~&//~S not in backtrace:~%   ~S~%" 
+                                  (caar frame-specs)
+                                  full-backtrace)
                           (setf result nil))
 
                         ;; check that we have all the frames we wanted
@@ -252,107 +252,111 @@
 (defbt 5 (&optional (opt (oops)))
   (list opt))
 
+(defmacro with-details (bool &body body)
+  `(let ((sb-debug:*show-entry-point-details* ,bool))
+     ,@body))
+
 ;;; FIXME: This test really should be broken into smaller pieces
 (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))
-                 ,@body)))
-
-    ;; TL-XEP
-    (print :tl-xep)
-    (with-details t
-      (assert (verify-backtrace #'namestring
-                                '(((sb-c::tl-xep namestring) 0 ?)))))
-    (with-details nil
-      (assert (verify-backtrace #'namestring
-                                '((namestring)))))
-
-
-    ;; &MORE-PROCESSOR
-    (with-details t
-      (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 (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)))))
-
-    ;; XEP
-    (print :xep)
-    (with-details t
-      (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 #'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.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.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.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.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.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.1
-                                '((bt.5.1))))
-      (assert (verify-backtrace #'bt.5.2
-                                '((bt.5.2 &rest))))
-      (assert (verify-backtrace #'bt.5.3
-                                '((bt.5.3 &rest)))))))
+            :fails-on '(or (and :x86 (or :sunos)) (and :x86-64 :darwin)))
+  (write-line "//tl-xep")
+  (with-details t
+    (assert (verify-backtrace #'namestring
+                              '(((sb-c::tl-xep namestring) 0 ?)))))
+  (with-details nil
+    (assert (verify-backtrace #'namestring
+                              '((namestring)))))
+
+  ;; &MORE-PROCESSOR
+  (with-details t
+    (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 (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)))))
+
+  ;; XEP
+  (write-line "//xep")
+  (with-details t
+    (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 #'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
+  (write-line "//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
+                              '(((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.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
+  (write-line "//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
+                              '(((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.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
+  (write-line "//optional-processor")
+  (with-details t
+    (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.1
+                              '((bt.5.1))))
+    (assert (verify-backtrace #'bt.5.2
+                              '((bt.5.2 &rest))))
+    (assert (verify-backtrace #'bt.5.3
+                              '((bt.5.3 &rest))))))
+
+(write-line "//compile nil")
+(defvar *compile-nil-error* (compile nil '(lambda (x) (cons (when x (error "oops")) nil))))
+(defvar *compile-nil-non-tc* (compile nil '(lambda (y) (cons (funcall *compile-nil-error* y) nil))))
+(assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
+                          '(((lambda (x)) 13)
+                            ((lambda (y)) 13))))
 
 ;;;; test TRACE
 
@@ -415,6 +419,7 @@
   ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
   ;; to halt, it produces so much garbage that's hard to suppress that
   ;; it is tested only once
+  (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
   (let ((*debugger-hook* #'erroring-debugger-hook))
     (loop repeat 1 do
           (let ((error-counter 0)
@@ -425,7 +430,8 @@
                    (catch 'sb-impl::toplevel-catcher
                      (nest-errors 20 (error "infinite error ~s"
                                             (incf error-counter)))
-                     :normal-exit))))))))
+                     :normal-exit)))))))
+  (write-line "--END OF H-B-A-B--"))
 
 (enable-debugger)
 

diff --git a/version.lisp-expr b/version.lisp-expr
index f010578..fc09100 100644 (file)
--- 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".)
-"1.0.13.37"
+"1.0.13.38"