Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/pcl braid.lisp,1.53,1.54 slots-boot.lisp,1.23,1.24 std-class.lisp,1.89,1.90
|
From: Christophe R. <cr...@us...> - 2005-12-05 18:01:42
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31895/src/pcl Modified Files: braid.lisp slots-boot.lisp std-class.lisp Log Message: 0.9.7.16: More PCL smallification. ... the ACCESSOR-SLOT-VALUE optimization creates a generic function (using load-time-value) when it sees a form like (slot-value x 'constant). That's fine, but... ... these generic functions are also created at class initialization time, three per slot. This hurts now that we're creating classes eagerly (so that the mop functionality works) as even condition classes and structure classes cause these gfs to come into being. ... so, rearrange things so that only those generic functions which are needed are created. Never create one with a slot-missing method, as the automatically-generated method will fall through to the full call and get there eventually, anyway. ... this causes slot-missing from slot-value outside of methods to be slower if (and only if) no slot of that name exists in the image anywhere. We could potentially improve fall-through-to-slot-missing performance. (this shaves off 2.5Mb from sbcl.core on my x86) Index: braid.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v retrieving revision 1.53 retrieving revision 1.54 diff -u -d -r1.53 -r1.54 --- braid.lisp 2 Dec 2005 22:53:04 -0000 1.53 +++ braid.lisp 5 Dec 2005 18:01:29 -0000 1.54 @@ -399,13 +399,7 @@ slot-name readers writers - nil) - (!bootstrap-accessor-definitions1 - 'slot-object - slot-name - (list (slot-reader-name slot-name)) - (list (slot-writer-name slot-name)) - (list (slot-boundp-name slot-name))))))))))) + nil))))))))) (defun !bootstrap-accessor-definition (class-name accessor-name slot-name type) (multiple-value-bind (accessor-class make-method-function arglist specls doc) Index: slots-boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v retrieving revision 1.23 retrieving revision 1.24 diff -u -d -r1.23 -r1.24 --- slots-boot.lisp 14 Jul 2005 19:45:42 -0000 1.23 +++ slots-boot.lisp 5 Dec 2005 18:01:29 -0000 1.24 @@ -24,72 +24,27 @@ (in-package "SB-PCL") (defun ensure-accessor (type fun-name slot-name) - (labels ((slot-missing-fun (slot-name type) - (let* ((method-type (ecase type - (slot-value 'reader-method) - (setf 'writer-method) - (slot-boundp 'boundp-method))) - (initargs - (copy-tree - (ecase type - (slot-value - (make-method-function - (lambda (obj) - (values - (slot-missing (class-of obj) obj slot-name - 'slot-value))))) - (slot-boundp - (make-method-function - (lambda (obj) - (not (not - (slot-missing (class-of obj) obj slot-name - 'slot-boundp)))))) - (setf - (make-method-function - (lambda (val obj) - (slot-missing (class-of obj) obj slot-name - 'setf val) - val))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) - (gensym)) - (list* :method-spec (list method-type 'slot-object slot-name) - initargs))) - (add-slot-missing-method (gf slot-name type) - (multiple-value-bind (class lambda-list specializers) - (ecase type - (slot-value - (values 'standard-reader-method - '(object) - (list *the-class-slot-object*))) - (slot-boundp - (values 'standard-boundp-method - '(object) - (list *the-class-slot-object*))) - (setf - (values 'standard-writer-method - '(new-value object) - (list *the-class-t* *the-class-slot-object*)))) - (add-method gf (make-a-method class - () - lambda-list - specializers - (slot-missing-fun slot-name type) - "generated slot-missing method" - slot-name))))) - (unless (fboundp fun-name) - (let ((gf (ensure-generic-function - fun-name - :lambda-list (ecase type - ((reader boundp) '(object)) - (writer '(new-value object)))))) + (unless (fboundp fun-name) + (multiple-value-bind (lambda-list specializers method-class initargs doc) (ecase type - (reader (add-slot-missing-method gf slot-name 'slot-value)) - (boundp (add-slot-missing-method gf slot-name 'slot-boundp)) - (writer (add-slot-missing-method gf slot-name 'setf))) - (setf (plist-value gf 'slot-missing-method) t)) - t))) + ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING + ;; behaviour for non-slot-objects too? + (reader + (values '(object) '(slot-object) 'standard-reader-method + (make-std-reader-method-function 'slot-object slot-name) + "automatically-generated reader method")) + (writer + (values '(new-value object) '(t slot-object) 'standard-writer-method + (make-std-writer-method-function 'slot-object slot-name) + "automatically-generated writer method")) + (boundp + (values '(object) '(slot-object) 'standard-boundp-method + (make-std-boundp-method-function 'slot-object slot-name) + "automatically-generated boundp method"))) + (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list))) + (add-method gf (make-a-method method-class () lambda-list specializers + initargs doc slot-name))))) + t) (defmacro accessor-slot-value (object slot-name) (aver (constantp slot-name)) @@ -530,18 +485,3 @@ (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) (list* :method-spec `(boundp-method ,class-name ,slot-name) initargs))) - -(defun initialize-internal-slot-gfs (slot-name &optional type) - (macrolet ((frob (type name-fun add-fun ll) - `(when (or (null type) (eq type ',type)) - (let* ((name (,name-fun slot-name)) - (gf (ensure-generic-function name - :lambda-list ',ll)) - (methods (generic-function-methods gf))) - (when (or (null methods) - (plist-value gf 'slot-missing-method)) - (setf (plist-value gf 'slot-missing-method) nil) - (,add-fun *the-class-slot-object* gf slot-name)))))) - (frob reader slot-reader-name add-reader-method (object)) - (frob writer slot-writer-name add-writer-method (new-value object)) - (frob boundp slot-boundp-name add-boundp-method (object)))) Index: std-class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v retrieving revision 1.89 retrieving revision 1.90 diff -u -d -r1.89 -r1.90 --- std-class.lisp 2 Dec 2005 22:53:04 -0000 1.89 +++ std-class.lisp 5 Dec 2005 18:01:29 -0000 1.90 @@ -83,8 +83,7 @@ (writer '(setf slot-value-using-class)) (boundp 'slot-boundp-using-class))) (gf (gdefinition gf-name))) - (compute-slot-accessor-info slotd type gf))) - (initialize-internal-slot-gfs name))) + (compute-slot-accessor-info slotd type gf))))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: ;;; @@ -364,7 +363,7 @@ (defmethod shared-initialize :after - ((class std-class) slot-names &key + ((class std-class) slot-names &key (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) (direct-default-initargs nil direct-default-initargs-p)) @@ -660,7 +659,7 @@ (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after - ((class structure-class) slot-names &key + ((class structure-class) slot-names &key (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) direct-default-initargs) |