From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 27 Aug 2007 15:13:27 +0000 (+0000)
Subject: faster SLOT-VALUE &co with variable slot names
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=157e21959c8023f146d6b03206aea6daa60e7b0d;p=sbcl.git

faster SLOT-VALUE &co with variable slot names

* Cache the slot-location and typecheckfun in the class-slots-vector
  in addition to the slot-definition for STANDARD-CLASS and
  FUNCALLABLE-STANDARD-CLASS.

* New function CHECK-OBSOLETE-INSTANCE/CLASS-OF, which combines the
  two. Faster then calling both separately, since both need to grab
  the wrapper -- used by SLOT-VALUE &co.

* Unoptimized SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, and
  SLOT-MAKUNBOUND can now directly access instance and class slots the
  typecheckfun in normal cases, giving upto 20-25% performance boost
  for these functions.

* Obsolete-instance protocol tests using variable slot-names.
---

diff --git a/NEWS b/NEWS
index fc41d57..01c35ab 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,9 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-1.0.10 relative to sbcl-1.0.9:
+  * optimization: SLOT-VALUE and (SETF SLOT-VALUE) are now >20% faster
+    for variable slot names, when the class of the instance is
+    an instance of STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS, and not
+    any of their subclasses.
   * optimization: member type construction is now O(N) instead
     of O(N^2).
   * optimization: UNION and NUNION are now O(N+M) for large
diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 5fcad4d..3ae9be4 100644
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -310,7 +310,7 @@
                                  slot-class))
       (set-slot 'direct-slots direct-slots)
       (set-slot 'slots slots)
-      (set-slot 'slot-vector (make-slot-vector slots)))
+      (set-slot 'slot-vector (make-slot-vector class slots)))
 
     ;; For all direct superclasses SUPER of CLASS, make sure CLASS is
     ;; a direct subclass of SUPER.  Note that METACLASS-NAME doesn't
diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 9f416cf..36b70d9 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -529,14 +529,14 @@
 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
 ;;; list up to the desired one.
 ;;;
-;;; As of 1.0.7.26 SBCL hashes the effective slot definitions into a
-;;; simple-vector, with bucket chains made out of plists keyed by the
-;;; slot names. This fixes gives O(1) performance, and avoid the GF
-;;; calls.
+;;; Current SBCL hashes the effective slot definitions, and some
+;;; information pulled out from them into a simple-vector, with bucket
+;;; chains made out of plists keyed by the slot names. This fixes
+;;; gives O(1) performance, and avoid the GF calls.
 ;;;
 ;;; MAKE-SLOT-VECTOR constructs the hashed vector out of a list of
-;;; effective slot definitions, and FIND-SLOT-DEFINITION knows how to
-;;; look up slots in that vector.
+;;; effective slot definitions and the class they pertain to, and
+;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
 ;;;
 ;;; The only bit of cleverness in the implementation is to make the
 ;;; vectors fairly tight, but always longer then 0 elements:
@@ -549,6 +549,20 @@
 ;;; -- As long as the vector always has a length > 0
 ;;;    FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
 ;;;    empty vector separately: it just returns a NIL.
+;;;
+;;; In addition to the slot-definition we also store the slot-location
+;;; and type-check function for instances of standard metaclasses, so
+;;; that SLOT-VALUE &co using variable slot names can get at them
+;;; without additional GF calls.
+;;;
+;;; Notes:
+;;;   It would be probably better to store the vector in wrapper
+;;;   instead: one less memory indirection, one less CLOS slot
+;;;   access to get at it.
+;;;
+;;;   It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
+;;;   generic instead of checking versus STANDARD-CLASS and
+;;;   FUNCALLABLE-STANDARD-CLASS.
 
 (defun find-slot-definition (class slot-name)
   (declare (symbol slot-name))
@@ -561,16 +575,44 @@
       (let ((key (car plist)))
         (setf plist (cdr plist))
         (when (eq key slot-name)
+          (return (cddar plist)))))))
+
+(defun find-slot-cell (class slot-name)
+  (declare (symbol slot-name))
+  (let* ((vector (class-slot-vector class))
+         (index (rem (sxhash slot-name) (length vector))))
+    (declare (simple-vector vector) (index index)
+             (optimize (sb-c::insert-array-bounds-checks 0)))
+    (do ((plist (the list (svref vector index)) (cdr plist)))
+        ((not (consp plist)))
+      (let ((key (car plist)))
+        (setf plist (cdr plist))
+        (when (eq key slot-name)
           (return (car plist)))))))
 
-(defun make-slot-vector (slots)
+(defun make-slot-vector (class slots)
   (let* ((n (+ (length slots) 2))
-         (vector (make-array n :initial-element nil)))
+         (vector (make-array n :initial-element nil))
+         (save-slot-location-p
+          (when (eq 'complete *boot-state*)
+            (let ((metaclass (class-of class)))
+              (or (eq metaclass *the-class-standard-class*)
+                  (eq metaclass *the-class-funcallable-standard-class*)))))
+         (save-type-check-function-p (and save-slot-location-p (safe-p class))))
     (flet ((add-to-vector (name slot)
              (declare (symbol name)
                       (optimize (sb-c::insert-array-bounds-checks 0)))
-             (setf (svref vector (rem (sxhash name) n))
-                   (list* name slot (svref vector (rem (sxhash name) n))))))
+             (let ((index (rem (sxhash name) n)))
+               (setf (svref vector index)
+                     (list* name (list* (if save-slot-location-p
+                                            (slot-definition-location slot)
+                                            ;; T tells SLOT-VALUE & SET-SLOT-VALUE
+                                            ;; that this is a non-standard class.
+                                            t)
+                                        (when save-type-check-function-p
+                                          (slot-definition-type-check-function slot))
+                                        slot)
+                            (svref vector index))))))
       (if (eq 'complete *boot-state*)
          (dolist (slot slots)
            (add-to-vector (slot-definition-name slot) slot))
diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 0dcb87e..7fa3013 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -75,15 +75,49 @@
          (t
           (error "unrecognized instance type")))))
 
-;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP
+;;;; STANDARD-INSTANCE-ACCESS
+
+(declaim (inline standard-instance-access (setf standard-instance-access)
+                 funcallable-standard-instance-access
+                 (setf funcallable-standard-instance-access)))
+
+(defun standard-instance-access (instance location)
+  (clos-slots-ref (std-instance-slots instance) location))
+
+(defun (setf standard-instance-access) (new-value instance location)
+  (setf (clos-slots-ref (std-instance-slots instance) location) new-value))
+
+(defun funcallable-standard-instance-access (instance location)
+  (clos-slots-ref (fsc-instance-slots instance) location))
+
+(defun (setf funcallable-standard-instance-access) (new-value instance location)
+  (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
+
+;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
 
 (declaim (ftype (sfunction (t symbol) t) slot-value))
 (defun slot-value (object slot-name)
-  (let* ((class (class-of object))
-         (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-        (values (slot-missing class object slot-name 'slot-value))
-        (slot-value-using-class class object slot-definition))))
+  (let* ((class (check-obsolete-instance/class-of object))
+         (cell (find-slot-cell class slot-name))
+         (location (car cell))
+         (value
+          (cond ((fixnump location)
+                 (if (std-instance-p object)
+                     (standard-instance-access object location)
+                     (funcallable-standard-instance-access object location)))
+                ((consp location)
+                 (cdr location))
+                ((eq t location)
+                 (return-from slot-value
+                   (slot-value-using-class class object (cddr cell))))
+                ((not cell)
+                 (return-from slot-value
+                   (values (slot-missing class object slot-name 'slot-value))))
+                (t
+                 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
+    (if (eq +slot-unbound+ value)
+        (slot-unbound class object slot-name)
+        value)))
 
 (define-compiler-macro slot-value (&whole form object slot-name
                                    &environment env)
@@ -93,13 +127,26 @@
       form))
 
 (defun set-slot-value (object slot-name new-value)
-  (let* ((class (class-of object))
-         (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-        (progn (slot-missing class object slot-name 'setf new-value)
-               new-value)
-        (setf (slot-value-using-class class object slot-definition)
-              new-value))))
+  (let* ((class (check-obsolete-instance/class-of object))
+         (cell (find-slot-cell class slot-name))
+         (location (car cell))
+         (type-check-function (cadr cell)))
+    (when type-check-function
+      (funcall (the function type-check-function) new-value))
+    (cond ((fixnump location)
+           (if (std-instance-p object)
+               (setf (standard-instance-access object location) new-value)
+               (setf (funcallable-standard-instance-access object location)
+                     new-value)))
+          ((consp location)
+           (setf (cdr location) new-value))
+          ((eq t location)
+           (setf (slot-value-using-class class object (cddr cell)) new-value))
+          ((not cell)
+           (slot-missing class object slot-name 'setf new-value))
+          (t
+           (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
+  new-value)
 
 ;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
 ;;; check types when writing to slots:
@@ -122,13 +169,25 @@
       form))
 
 (defun slot-boundp (object slot-name)
-  (let* ((class (class-of object))
-         (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-        (not (not (slot-missing class object slot-name 'slot-boundp)))
-        (slot-boundp-using-class class object slot-definition))))
-
-(setf (gdefinition 'slot-boundp-normal) #'slot-boundp)
+  (let* ((class (check-obsolete-instance/class-of object))
+         (cell (find-slot-cell class slot-name))
+         (location (car cell))
+         (value
+          (cond ((fixnump location)
+                 (if (std-instance-p object)
+                     (standard-instance-access object location)
+                     (funcallable-standard-instance-access object location)))
+                ((consp location)
+                 (cdr location))
+                ((eq t location)
+                 (return-from slot-boundp
+                   (slot-boundp-using-class class object (cddr cell))))
+                ((not cell)
+                 (return-from slot-boundp
+                   (and (slot-missing class object slot-name 'slot-boundp) t)))
+                (t
+                 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
+    (not (eq +slot-unbound+ value))))
 
 (define-compiler-macro slot-boundp (&whole form object slot-name
                                     &environment env)
@@ -138,12 +197,23 @@
       form))
 
 (defun slot-makunbound (object slot-name)
-  (let* ((class (class-of object))
-         (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-        (slot-missing class object slot-name 'slot-makunbound)
-        (slot-makunbound-using-class class object slot-definition))
-    object))
+  (let* ((class (check-obsolete-instance/class-of object))
+         (cell (find-slot-cell class slot-name))
+         (location (car cell)))
+    (cond ((fixnump location)
+           (if (std-instance-p object)
+               (setf (standard-instance-access object location) +slot-unbound+)
+               (setf (funcallable-standard-instance-access object location)
+                     +slot-unbound+)))
+          ((consp location)
+           (setf (cdr location) +slot-unbound+))
+          ((eq t location)
+           (slot-makunbound-using-class class object (cddr cell)))
+          ((not cell)
+           (slot-missing class object slot-name 'slot-makunbound))
+          (t
+           (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
+  object)
 
 (defun slot-exists-p (object slot-name)
   (let ((class (class-of object)))
@@ -158,26 +228,12 @@
   (if (slot-boundp object slot-name)
       (slot-value object slot-name)
       default))
-
-(declaim (inline standard-instance-access (setf standard-instance-access)
-                 funcallable-standard-instance-access
-                 (setf funcallable-standard-instance-access)))
-
-(defun standard-instance-access (instance location)
-  (clos-slots-ref (std-instance-slots instance) location))
-
-(defun (setf standard-instance-access) (new-value instance location)
-  (setf (clos-slots-ref (std-instance-slots instance) location) new-value))
-
-(defun funcallable-standard-instance-access (instance location)
-  (clos-slots-ref (fsc-instance-slots instance) location))
-
-(defun (setf funcallable-standard-instance-access) (new-value instance location)
-  (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
 
 (defmethod slot-value-using-class ((class std-class)
                                    (object standard-object)
                                    (slotd standard-effective-slot-definition))
+  ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete
+  ;; instances. Are users allowed to call this directly?
   (check-obsolete-instance object)
   (let* ((location (slot-definition-location slotd))
          (value
@@ -204,6 +260,8 @@
            (new-value (class std-class)
                       (object standard-object)
                       (slotd standard-effective-slot-definition))
+  ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete
+  ;; instances. Are users allowed to call this directly?
   (check-obsolete-instance object)
   (let ((location (slot-definition-location slotd))
         (type-check-function
@@ -233,6 +291,8 @@
            ((class std-class)
             (object standard-object)
             (slotd standard-effective-slot-definition))
+  ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete
+  ;; instances. Are users allowed to call this directly?
   (check-obsolete-instance object)
   (let* ((location (slot-definition-location slotd))
          (value
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index cdffa52..fcb86c1 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -536,7 +536,7 @@
       (add-direct-subclasses class direct-superclasses)
       (let ((slots (compute-slots class)))
         (setf (slot-value class 'slots) slots
-              (slot-value class 'slot-vector) (make-slot-vector slots)))))
+              (slot-value class 'slot-vector) (make-slot-vector class slots)))))
   ;; Comment from Gerd's PCL, 2003-05-15:
   ;;
   ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
@@ -718,7 +718,7 @@
     (setf (slot-value class 'cpl-available-p) t)
     (let ((slots (compute-slots class)))
       (setf (slot-value class 'slots) slots
-            (slot-value class 'slot-vector) (make-slot-vector slots)))
+            (slot-value class 'slot-vector) (make-slot-vector class slots)))
     (let ((lclass (find-classoid (class-name class))))
       (setf (classoid-pcl-class lclass) class)
       (setf (slot-value class 'wrapper) (classoid-layout lclass)))
@@ -895,7 +895,7 @@
 
       (update-lisp-class-layout class nwrapper)
       (setf (slot-value class 'slots) eslotds
-            (slot-value class 'slot-vector) (make-slot-vector eslotds)
+            (slot-value class 'slot-vector) (make-slot-vector class eslotds)
             (wrapper-instance-slots-layout nwrapper) nlayout
             (wrapper-class-slots nwrapper) nwrapper-class-slots
             (layout-length nwrapper) nslots
diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index 1e8b2f8..ae181da 100644
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -187,6 +187,12 @@
 (defun check-obsolete-instance (instance)
   (when (invalid-wrapper-p (layout-of instance))
     (check-wrapper-validity instance)))
+
+(defun check-obsolete-instance/class-of (instance)
+  (let ((wrapper (wrapper-of instance)))
+    (when (invalid-wrapper-p wrapper)
+      (check-wrapper-validity instance))
+    (wrapper-class* wrapper)))
 
 ;;;  NIL: means nothing so far, no actual arg info has NILs in the
 ;;;  metatype.
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index d9155ef..e923afc 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -913,6 +913,31 @@
 (assert (= (slot-value *yao-super* 'obs) 3))
 (assert (= (slot-value *yao-sub* 'obs) 3))
 
+;;; one more MIO test: variable slot names
+(defclass mio () ((x :initform 42)))
+(defvar *mio-slot* 'x)
+(defparameter *mio-counter* 0)
+(defmethod update-instance-for-redefined-class ((instance mio) new old plist &key)
+  (incf *mio-counter*))
+
+(let ((x (make-instance 'mio)))
+  (make-instances-obsolete 'mio)
+  (slot-value x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+  (make-instances-obsolete 'mio)
+  (setf (slot-value x *mio-slot*) 13))
+
+(let ((x (make-instance 'mio)))
+  (make-instances-obsolete 'mio)
+  (slot-boundp x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+  (make-instances-obsolete 'mio)
+  (slot-makunbound x *mio-slot*))
+
+(assert (= 4 *mio-counter*))
+
 ;;; shared -> local slot transfers of inherited slots, reported by
 ;;; Bruno Haible
 (let (i)
diff --git a/version.lisp-expr b/version.lisp-expr
index d931dd8..ee9843f 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".)
-"1.0.9.1"
+"1.0.9.2"