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)

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 3920052..4cf786b 100644 (file)
--- 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 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -24,72 +24,27 @@
 (in-package "SB-PCL")
 \f
 (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 (file)
--- 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 @@
 
 \f
 (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 (file)
--- 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 (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".)
-"0.9.7.15"
+"0.9.7.16"