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)
|