1.0.42.37: use more NAMED-LAMBDAs in PCL generated code

 Previously backtraces and profiles showed eg.

   (LAMBDA (.ARG0. .ARG1. .ARG2.))

 for effective method functions, and

   (LAMBDA (VALUE))

 for slot typechecking functions.

 Use NAMED-LAMBDA to name these sensibly:

  (DFUN <generic-function-name>)

  (SLOT-TYPECHECK <class-name> <slot-name>)

diff --git a/NEWS b/NEWS
index b24dc75..6e88fdd 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,8 @@
 changes relative to sbcl-1.0.42
   * enhancement: SB-EXT:WORD type is provided for use with SB-EXT:ATOMIC-INCF
     &co.
+  * enhancement: CLOS effective method functions and defclass slot typechecking
+    function now have debug names for use in backtraces and profiles.
   * enhancement: ASDF has been updated to version 2.004. (lp#605260, thanks to
     Faré Rideau)
   * enhancement: symbols are printed using fully qualified names in several

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index be7a9a8..8128f53 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -229,18 +229,19 @@
              ;; Otherwise the METHOD-COMBINATION slot is not bound.
              (let ((combin (generic-function-method-combination gf)))
                (and (long-method-combination-p combin)
-                    (long-method-combination-args-lambda-list combin))))))
+                    (long-method-combination-args-lambda-list combin)))))
+          (name `(emf ,(generic-function-name gf))))
       (cond
         (error-p
-         `(lambda (.pv. .next-method-call. &rest .args.)
-           (declare (ignore .pv. .next-method-call.))
-           (declare (ignorable .args.))
-           (flet ((%no-primary-method (gf args)
-                    (call-no-primary-method gf args))
-                  (%invalid-qualifiers (gf combin method)
-                    (invalid-qualifiers gf combin method)))
-             (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
-             ,effective-method)))
+         `(named-lambda ,name (.pv. .next-method-call. &rest .args.)
+            (declare (ignore .pv. .next-method-call.))
+            (declare (ignorable .args.))
+            (flet ((%no-primary-method (gf args)
+                     (call-no-primary-method gf args))
+                   (%invalid-qualifiers (gf combin method)
+                     (invalid-qualifiers gf combin method)))
+              (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
+              ,effective-method)))
         (mc-args-p
          (let* ((required (make-dfun-required-args nreq))
                 (gf-args (if applyp
@@ -250,17 +251,17 @@
                                       (the (and unsigned-byte fixnum)
                                         .dfun-more-count.)))
                              `(list ,@required))))
-           `(lambda ,ll
-             (declare (ignore .pv. .next-method-call.))
-             (let ((.gf-args. ,gf-args))
-               (declare (ignorable .gf-args.))
-               ,@check-applicable-keywords
-               ,effective-method))))
+           `(named-lambda ,name ,ll
+              (declare (ignore .pv. .next-method-call.))
+              (let ((.gf-args. ,gf-args))
+                (declare (ignorable .gf-args.))
+                ,@check-applicable-keywords
+                ,effective-method))))
         (t
-         `(lambda ,ll
-           (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.))))
-           ,@check-applicable-keywords
-           ,effective-method))))))
+         `(named-lambda ,name ,ll
+            (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.))))
+            ,@check-applicable-keywords
+            ,effective-method))))))
 
 (defun expand-emf-call-method (gf form metatypes applyp env)
   (declare (ignore gf metatypes applyp env))

diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp
index cec722e..846f82a 100644 (file)
--- a/src/pcl/compiler-support.lisp
+++ b/src/pcl/compiler-support.lisp
@@ -64,9 +64,9 @@
 
 (defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil)
 
-(defmacro define-internal-pcl-function-name-syntax (name &body body)
+(defmacro define-internal-pcl-function-name-syntax (name (var) &body body)
   `(progn
-     (define-function-name-syntax ,name ,@body)
+     (define-function-name-syntax ,name (,var) ,@body)
      (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*)))
 
 (define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list)

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 638f561..de39bc3 100644 (file)
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -234,10 +234,11 @@
         (let* ((type-check-function
                 (if (eq type t)
                     nil
-                    `('type-check-function (lambda (value)
-                                             (declare (type ,type value)
-                                                      (optimize (sb-c:store-coverage-data 0)))
-                                             value))))
+                    `('type-check-function
+                      (named-lambda (slot-typecheck ,class-name ,name) (value)
+                        (declare (type ,type value)
+                                 (optimize (sb-c:store-coverage-data 0)))
+                        value))))
                (canon `(:name ',name :readers ',readers :writers ',writers
                               :initargs ',initargs
                               ,@type-check-function

diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp
index 7498eea..38eb79e 100644 (file)
--- a/src/pcl/gray-streams.lisp
+++ b/src/pcl/gray-streams.lisp
@@ -88,7 +88,13 @@
   (setf (stream-open-p stream) nil)
   t)
 
-(setf (fdefinition 'close) #'pcl-close)
+(progn
+  ;; KLUDGE: Get in a call to PCL-CLOSE with a string-output-stream before
+  ;; setting it as CLOSE. Otherwise using NAMED-LAMBDAs as DFUNs causes a
+  ;; vicious metacircle from FORMAT NIL somewhere in the compiler. This is
+  ;; enough to get the dispatch settled down before we need it.
+  (pcl-close (make-string-output-stream))
+  (setf (fdefinition 'close) #'pcl-close))
 \f
 (let ()
   (fmakunbound 'input-stream-p)

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 27283ae..d54308c 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -366,6 +366,26 @@
                           '(((lambda (x)) 13)
                             ((lambda (y)) 13))))
 
+(with-test (:name :clos-slot-typecheckfun-named)
+  (assert
+   (verify-backtrace
+    (lambda ()
+      (eval `(locally (declare (optimize safety))
+               (defclass clos-typecheck-test ()
+                 ((slot :type fixnum)))
+               (setf (slot-value (make-instance 'clos-typecheck-test) 'slot) t))))
+    '(((sb-pcl::slot-typecheck clos-typecheck-test slot) t)))))
+
+(with-test (:name :clos-emf-named)
+  (assert
+   (verify-backtrace
+    (lambda ()
+      (eval `(progn
+               (defmethod clos-emf-named-test ((x symbol)) x)
+               (defmethod clos-emf-named-test :before (x) (assert x))
+               (clos-emf-named-test nil))))
+    '(((sb-pcl::emf clos-emf-named-test) ? ? nil)))))
+
 ;;;; test TRACE
 
 (defun trace-this ()

diff --git a/version.lisp-expr b/version.lisp-expr
index 9bc051c..641b796 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.42.36"
+"1.0.42.37"