From fbde18e9b7d8e67e24f628638be4f293cb128101 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 5 Dec 2005 18:01:27 +0000 Subject: [PATCH] 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) --- src/pcl/braid.lisp | 8 +--- src/pcl/slots-boot.lisp | 100 ++++++++++------------------------------------- src/pcl/std-class.lisp | 7 ++-- src/runtime/gc-common.c | 4 +- version.lisp-expr | 2 +- 5 files changed, 27 insertions(+), 94 deletions(-) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 3920052..4cf786b 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -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) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 66713bb..317ccca 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -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)))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index cf2eb6e..f7ee4f1 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -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) diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 0869cd9..abd1eae 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -188,7 +188,7 @@ scavenge(lispobj *start, long n_words) } } gc_assert_verbose(object_ptr == end, "Final object pointer %p, end %p\n", - object_ptr, end); + object_ptr, end); } static lispobj trans_fun_header(lispobj object); /* forward decls */ @@ -346,7 +346,7 @@ scav_code_header(lispobj *where, lispobj object) entry_point = function_ptr->next) { gc_assert_verbose(is_lisp_pointer(entry_point), "Entry point %lx\n", - (long)entry_point); + (long)entry_point); function_ptr = (struct simple_fun *) native_pointer(entry_point); gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG); diff --git a/version.lisp-expr b/version.lisp-expr index 8b84a19..52ca12e 100644 --- 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".) -"0.9.7.15" +"0.9.7.16" -- 1.7.10.4