[Sbcl-commits] CVS: sbcl/src/pcl combin.lisp, 1.37, 1.38 compiler-support.lisp, 1.21, 1.22 defclass.lisp, 1.45, 1.46 gray-streams.lisp, 1.19, 1.20

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv20814/src/pcl

Modified Files:
	combin.lisp compiler-support.lisp defclass.lisp 
	gray-streams.lisp 
Log Message:
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>)



Index: combin.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/combin.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- combin.lisp	30 Jul 2010 21:01:13 -0000	1.37
+++ combin.lisp	13 Sep 2010 11:04:01 -0000	1.38
@@ -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))

Index: compiler-support.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/compiler-support.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- compiler-support.lisp	6 Aug 2009 15:57:26 -0000	1.21
+++ compiler-support.lisp	13 Sep 2010 11:04:01 -0000	1.22
@@ -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)

Index: defclass.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defclass.lisp,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -d -r1.45 -r1.46
--- defclass.lisp	18 Sep 2009 09:42:39 -0000	1.45
+++ defclass.lisp	13 Sep 2010 11:04:01 -0000	1.46
@@ -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

Index: gray-streams.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/gray-streams.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- gray-streams.lisp	11 Jan 2007 21:43:06 -0000	1.19
+++ gray-streams.lisp	13 Sep 2010 11:04:01 -0000	1.20
@@ -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))
 
 (let ()
   (fmakunbound 'input-stream-p)