Speed up slot-value on any structure-object and non-const slot-name

According to a microbenchmark, STRUCTURE-SLOT-VALUE is as much as 3x faster
than SLOT-VALUE on a structure.

benchmarks/slot-value.lisp

@@ -0,0 +1,38 @@
+(defstruct (lottaslot
+             (:predicate is-a-lottaslot))
+  a b c d e f g h i j k l m n o p q r s t u v w x y z)
+
+(defun slow (instance slots)
+  (sb-int:dovector (x (the simple-vector slots))
+    (if (eq (slot-value instance (truly-the symbol x)) 'flerkin) (return t))))
+(defun fast (instance slots)
+  (declare (structure-object instance))
+  (sb-int:dovector (x (the simple-vector slots))
+    (if (eq (slot-value instance (truly-the symbol x)) 'flerkin) (return t))))
+
+(defun loopslow (n)
+  (let ((inst (make-lottaslot)))
+    (loop repeat (the fixnum n)
+          count (slow inst #(z q i j l c e g)))))
+(defun loopfast (n)
+  (let ((inst (make-lottaslot)))
+    (loop repeat (the fixnum n)
+          count (fast inst #(z q i j l c e g)))))
+
+#|
+* (time (loopslow 100000))
+Evaluation took:
+  0.012 seconds of real time
+  0.015585 seconds of total run time (0.015585 user, 0.000000 system)
+  133.33% CPU
+  42,017,049 processor cycles
+  0 bytes consed
+
+* (time (loopfast 100000))
+Evaluation took:
+  0.004 seconds of real time
+  0.007433 seconds of total run time (0.007433 user, 0.000000 system)
+  175.00% CPU
+  20,026,278 processor cycles
+  0 bytes consed
+|#

src/code/early-classoid.lisp

@@ -266,6 +266,8 @@
   ;; Could be the generalized function, or a type-specific one
   ;; if the defstruct was compiled in a policy of SPEED 3.
   (equalp-impl #'equalp-err :type (sfunction (t t) boolean) :read-only t)
+  ;; Information for the quicker variant of SLOT-VALUE on STRUCTURE-OBJECT
+  (struct-slot-map nil)
   ;; Information about slots in the class to PCL: this provides fast
   ;; access to slot-definitions and locations by name, etc.
   ;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details.

src/code/target-defstruct.lisp

@@ -487,5 +487,90 @@
              (format t "Layout flags = #b~10,'0b~%" flags)
              (setq prev flags)))
          (format t "  ~a~%" layout)))))
+
+(defconstant fast-slot-table-fixed-cells 3)
+
+;;; Optimizations to speed up slot-value on structure-object
+;;;  1. try to generate fewer collisions in the symbol -> index map
+;;;  2. use the fastrem-32 algorithm to compute FLOOR
+;;;  3. specialized function which doesn't check slot-unbound or whether the
+;;;     slot has :CLASS allocation (which it can't)
+;;; If "flexible" defstructs (multiple inheritance, standard-object ancestors) are ever
+;;; brought to life, these might be inadmissible. Probably we would not store the
+;;; fast map in such situations.
+#+64-bit
+(progn
+(defun best-slot-map-parameters (names)
+  (let* ((raw-hashes (mapcar (lambda (x) (sxhash (the symbol x))) names))
+         (n-names (length names))
+         (n-cells (logior n-names 1)) ; round to odd if not already
+         ;; remember the best N-COLLISIONS N-CELLS MASK C
+         (best))
+    (declare (type (unsigned-byte 32) n-cells))
+    ;; Unlike with package symbol tables, a slot table has a fixed set of symbols.
+    ;; Therefore we can try to produce the best hashing for that particular set.
+    (loop ; over increasing value of N-CELLS
+     (multiple-value-bind (mask c) (sb-impl::optimized-symtbl-remainder-params n-cells)
+       (loop for shift from 0 to 31
+             do
+             (let* ((indices
+                     (mapcar (lambda (hash)
+                               (let ((masked-hash (logand (ash hash (- shift)) mask)))
+                                 (sb-vm::fastrem-32 masked-hash c n-cells)))
+                             raw-hashes))
+                    (badness (- n-names (length (remove-duplicates indices)))))
+               (when (= badness 0)
+                 (return-from best-slot-map-parameters
+                   (list 0 n-cells shift mask c)))
+               (when (or (not best) (< badness (car best)))
+                 (setf best
+                       (list badness n-cells shift mask c))))))
+     (when (> n-cells (* 2 n-names))
+       (return best))
+     (incf n-cells 2))))
+
+;; The result is a vector:
+;;  #(SHIFT MASK C symbol .. symbol ... index .. index ...)
+;; The length of the vector implies the divisor.
+(defun make-struct-slot-map (dd)
+  (destructuring-bind (n-cells shift mask c)
+      (cdr (best-slot-map-parameters
+            (mapcar 'dsd-name (dd-slots dd))))
+    (let ((map (make-array (+ (* n-cells 2) fast-slot-table-fixed-cells)
+                           :initial-element 0)))
+      (setf (aref map 0) shift
+            (aref map 1) mask
+            (aref map 2) c)
+      (fill map nil :start (+ fast-slot-table-fixed-cells n-cells))
+      (dolist (dsd (dd-slots dd) map)
+        ;; minor kludge: skip raw slots for now, and let structure-slot-value
+        ;; fall back to the fully general SLOT-VALUE. A better solution would be
+        ;; to encode the raw-type into the value stored in the index vector.
+        (when (eq (dsd-raw-type dsd) t)
+          (binding*
+              ((hash (sxhash (dsd-name dsd)))
+                 (masked-hash (logand (ash hash (- shift)) mask))
+               (bin (truly-the index
+                               (+ (sb-vm::fastrem-32 masked-hash c n-cells)
+                                  fast-slot-table-fixed-cells)))
+               (dsd-index (dsd-index dsd))
+               (name (dsd-name dsd))
+               ((key value)
+                (cond ((eql (svref map bin) 0) ; empty, just store the name and dsd-index
+                       (values name dsd-index))
+                      ;; A bin with a collision is upgraded to a vector of the two entries
+                      ((symbolp (svref map bin))
+                       (values (vector (svref map bin) name)
+                               (vector (svref map (+ bin n-cells)) dsd-index)))
+                      ;; Multiple collisions
+                      (t
+                       (values (concatenate 'vector (svref map bin) (vector name))
+                               (concatenate 'vector
+                                            (svref map (+ bin n-cells))
+                                            (vector dsd-index)))))))
+              (setf (svref map bin) key
+                    (svref map (+ bin n-cells)) value)))))))
+) ; end PROGN
+
 
 (/show0 "target-defstruct.lisp end of file")

src/pcl/compiler-support.lisp

@@ -94,6 +94,13 @@
           (t (delay-ir1-transform node :constraint)
              `(sb-pcl::accessor-slot-makunbound object ',(lvar-value slot-name)))))
 
+  ;; this transform is tried LAST because we like to make things unintuitive
+  #+64-bit ; not really arch-specific but needs fastrem-32
+  (deftransform slot-value ((object slot-name) (structure-object symbol) *
+                            ;; safety 3 should check slot-unbound on structures
+                            :policy (< safety 3))
+    `(sb-pcl::structure-slot-value object slot-name))
+
   (deftransform slot-value ((object slot-name) (t (constant-arg symbol)) *
                             :node node)
     (acond ((always-bound-struct-accessor-p object slot-name)

src/pcl/slots.lisp

@@ -84,7 +84,64 @@
 
 ;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
 
+(macrolet
+    ((fast-get-dsd-index-by-name ()
+       ;; This macro is unhygienic, freely referencing MAP and SLOT-NAME
+       ;; from STRUCTURE-SLOT-VALUE or SLOT-VALUE.
+       `(let* ((shift (truly-the (integer 0 31) (svref map 0)))
+               (mask (truly-the (unsigned-byte 32) (svref map 1)))
+               (c (truly-the (unsigned-byte 32) (svref map 2)))
+               ;; elide the check for whether hash was precomputed. It has to have been,
+               ;; and even if it wasn't we'd just take the slow path, so no harm done.
+               (hash (logand (ash (sb-sys:%primitive sb-vm::symbol-hash
+                                                     (truly-the symbol slot-name))
+                                  (- shift))
+                             mask))
+               (n-cells
+                (truly-the (unsigned-byte 32)
+                           (ash (- (length map) sb-kernel::fast-slot-table-fixed-cells)
+                                -1)))
+               ;; Cribbed from SYMBOL-TABLE-HASH in src/code/target-package
+               (bin (+ (sb-vm::fastrem-32 hash c n-cells)
+                       sb-kernel::fast-slot-table-fixed-cells))
+               (entry (svref map bin)))
+          (cond ((eq entry slot-name)
+                 (svref map (+ bin n-cells))) ; skip over the fixed portion
+                ((eql entry 0) nil)
+                (t
+                 (let ((v (truly-the simple-vector entry)))
+                   ;; try to find slot-name in the collision vector
+                   (dotimes (i (length v))
+                     (when (eq (svref v i) slot-name)
+                       (let ((indices (svref map (+ bin n-cells))))
+                         (return (svref (truly-the simple-vector indices) i)))))))))))
+
+;;; Structure-slot-value is usually faster than our litle chunks of code that are
+;;; automatically cobbled together for SLOT-VALUE on an unknown type but constant slot name.
+;;; While the global generic for a specific slot might only need to invoke a type-check,
+;;; the dispatch function is not faster than this, if even as fast.
+#+64-bit
+(defun structure-slot-value (instance slot-name)
+  (declare (optimize (sb-c::insert-array-bounds-checks 0)))
+  (let* ((layout (%instance-layout (truly-the structure-object instance)))
+         (map (the simple-vector (sb-kernel::layout-struct-slot-map layout)))
+         (dsd-index (fast-get-dsd-index-by-name)))
+    ;; TODO: encode dsd-raw-type into the index, and handle all raw types here
+    (if dsd-index
+        ;; We don't transform SLOT-VALUE to STRUCTURE-SLOT-VALUE in safety 3,
+        ;; So this need not check for unbound-marker.
+        (%instance-ref instance (truly-the index dsd-index))
+        ;; not found, take the slow path
+        (locally (declare (notinline slot-value))
+          (slot-value instance slot-name)))))
+) ; end MACROLET
+
 (declaim (ftype (sfunction (t symbol) t) slot-value))
+;;; It would be nifty if this could utilize the LAYOUT-STRUCT-SLOT-MAP
+;;; to optimize for subtypes of STRUCTURE-OBJECT in here, but as currently
+;;; defined, STRUCTURE-SLOT-VALUE calls SLOT-VALUE when either it can't find
+;;; the slot or the slot is raw. Since that function punts to this as a fallback,
+;;; this can't utilize that or else they enter an infinite loop on failure.
 (defun slot-value (object slot-name)
   (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))

src/pcl/std-class.lisp

@@ -854,6 +854,8 @@
              (layout (classoid-layout lclass)))
         (setf (classoid-pcl-class lclass) class)
         (setf (slot-value class 'wrapper) layout)
+        (setf (sb-kernel::layout-struct-slot-map layout)
+              (sb-kernel::make-struct-slot-map (layout-dd layout)))
         (setf (layout-slot-table layout) (make-slot-table class slots))))
     (setf (slot-value class 'finalized-p) t)
     (add-slot-accessors class direct-slots)))

tests/slot-unbound.impure.lisp

@@ -47,6 +47,7 @@
 (with-test (:name (slot-unbound :struct-a))
   (setf *slot-unbounds* nil)
   (let ((struct-a (make-struct-a)))
+    (declare (optimize safety))
     (assert (eql (slot-value struct-a 'boxed) 0))
     (assert (eql (slot-value struct-a 'raw) 0.0d0))
     (assert (eql (slot-value struct-a 'unboundable) 42))

tests/slot-value.impure.lisp

@@ -33,3 +33,31 @@
 
 (with-test (:name (slot-value defmethod t))
   (assert (= (a-class-x-3 (make-instance 'a-class)) 123)))
+
+(defun read-slot-way1 (instance slot)
+  (slot-value instance slot))
+(defun read-slot-way2 (instance slot)
+  (slot-value (the structure-object instance) slot))
+(compile 'read-slot-way1)
+(compile 'read-slot-way2)
+
+;;; Collect up a bunch of instances that are subtypes of STRUCTURE-OBJECT
+(with-test (:name :fast-structure-slot-value)
+  (let ((instances
+         (sb-vm:list-allocated-objects
+          :all :type sb-vm:instance-widetag
+          :test (lambda (x)
+                  (and (typep x 'structure-object)
+                       ;; want to ensure the instances under test are mostly immutable.
+                       ;; This is no guarantee, but it works.
+                       (eq (sb-kernel:generation-of x)
+                           sb-vm:+pseudo-static-generation+)))
+          :count 10000)))
+    (dolist (x instances)
+      (let* ((layout (sb-kernel:%instance-layout x))
+             (dd (sb-kernel:layout-dd layout)))
+        (dolist (dsd (sb-kernel:dd-slots dd))
+          (let ((slot-name (sb-kernel:dsd-name dsd)))
+            ;; some slots may be raw, don't worry about being EQ
+            (assert (eql (read-slot-way1 x slot-name)
+                         (read-slot-way2 x slot-name)))))))))