1.0.30.40: faster SLOT-VALUE on structures

 * Replace the SLOT-VALUE and SET-SLOT-VALUE compiler macros
   with deftransforms once PCL has been built, and if the type
   is known to be a structure and the slot name maps cleanly
   to an accessor we can use it.

diff --git a/NEWS b/NEWS
index c1e06eb..5eff26d 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,8 @@ changes relative to sbcl-1.0.30:
     constant two has been optimized.
   * optimization: ARRAY-IN-BOUNDS-P is resolved at compile-time when
     sufficient type information is available. (thanks to Leslie Polzer)
+  * optimization: SLOT-VALUE and (SETF SLOT-VALUE) with constant slot names on
+    known structure objects are as efficient as defstruct generated accessors.
   * optimization: unused vector creation can now be optimized away.
   * improvement: ASDF systems can now depends on SB-INTROSPECT.
   * improvement: a STYLE-WARNING is signalled when a generic function

diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp
index 5dcd8c6..cec722e 100644 (file)
--- a/src/pcl/compiler-support.lisp
+++ b/src/pcl/compiler-support.lisp
@@ -92,43 +92,3 @@
            (sb-pcl::fsc-instance-p class-or-name))
        (values t nil)))))
 
-;;;; SLOT-VALUE optimizations
-
-(defknown slot-value (t symbol) t (any))
-(defknown sb-pcl::set-slot-value (t symbol t) t (any))
-
-(defun pcl-boot-state-complete-p ()
-  (eq 'sb-pcl::complete sb-pcl::*boot-state*))
-
-;;; These essentially duplicate what the compiler-macros in slots.lisp
-;;; do, but catch more cases. We retain the compiler-macros since they
-;;; can be used during the build, and because they catch common cases
-;;; slightly more cheaply then the transforms. (Transforms add new
-;;; lambdas, which requires more work by the compiler.)
-
-(deftransform slot-value ((object slot-name))
-  "optimize"
-  (let (c-slot-name)
-    (if (and (pcl-boot-state-complete-p)
-             (constant-lvar-p slot-name)
-             (setf c-slot-name (lvar-value slot-name))
-             (sb-pcl::interned-symbol-p c-slot-name))
-        `(sb-pcl::accessor-slot-value object ',c-slot-name)
-        (give-up-ir1-transform "Slot name is not constant."))))
-
-(deftransform sb-pcl::set-slot-value ((object slot-name new-value)
-                                      (t symbol t) t
-                                      ;; Safe code wants to check the
-                                      ;; type, and the global accessor
-                                      ;; won't do that. Also see the
-                                      ;; comment in the
-                                      ;; compiler-macro.
-                                      :policy (< safety 3))
-  "optimize"
-  (let (c-slot-name)
-    (if (and (pcl-boot-state-complete-p)
-             (constant-lvar-p slot-name)
-             (setf c-slot-name (lvar-value slot-name))
-             (sb-pcl::interned-symbol-p c-slot-name))
-        `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value)
-        (give-up-ir1-transform "Slot name is not constant."))))

diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp
index 2ea6fb9..a43c5e6 100644 (file)
--- a/src/pcl/fixup.lisp
+++ b/src/pcl/fixup.lisp
@@ -34,3 +34,46 @@
 (defun print-std-instance (instance stream depth)
   (declare (ignore depth))
   (print-object instance stream))
+
+(setf (compiler-macro-function 'slot-value) nil)
+(setf (compiler-macro-function 'set-slot-value) nil)
+
+(in-package "SB-C")
+
+(defknown slot-value (t symbol) t (any))
+(defknown sb-pcl::set-slot-value (t symbol t) t (any))
+
+(deftransform slot-value ((object slot-name) (t (constant-arg symbol)))
+  (let ((c-slot-name (lvar-value slot-name)))
+    (if (sb-pcl::interned-symbol-p c-slot-name)
+        (let* ((type (lvar-type object))
+               (dd (when (structure-classoid-p type)
+                     (find-defstruct-description
+                      (sb-kernel::structure-classoid-name type))))
+               (dsd (when dd
+                      (find c-slot-name (dd-slots dd) :key #'dsd-name))))
+          (if dsd
+              `(,(dsd-accessor-name dsd) object)
+              `(sb-pcl::accessor-slot-value object ',c-slot-name)))
+        (give-up-ir1-transform "slot name is not an interned symbol"))))
+
+(deftransform sb-pcl::set-slot-value ((object slot-name new-value)
+                                      (t (constant-arg symbol) t)
+                                      * :node node)
+  (let ((c-slot-name (lvar-value slot-name)))
+    (if (sb-pcl::interned-symbol-p c-slot-name)
+        (let* ((type (lvar-type object))
+               (dd (when (structure-classoid-p type)
+                     (find-defstruct-description
+                      (sb-kernel::structure-classoid-name type))))
+               (dsd (when dd
+                      (find c-slot-name (dd-slots dd) :key #'dsd-name))))
+          (if dsd
+              `(setf (,(dsd-accessor-name dsd) object) new-value)
+              (if (policy node (= safety 3))
+                  ;; Safe code wants to check the type, and the global
+                  ;; accessor won't do that. Also see the comment in the
+                  ;; compiler-macro.
+                  (abort-ir1-transform "cannot use optimized accessor in safe code")
+                  `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value))))
+        (give-up-ir1-transform "slot name is not an interned symbol"))))

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 2768a42..7350196 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -111,6 +111,8 @@
         (slot-unbound (wrapper-class* wrapper) object slot-name)
         value)))
 
+;;; This is used during the PCL build, but gets replaced by a deftransform
+;;; in fixup.lisp.
 (define-compiler-macro slot-value (&whole form object slot-name
                                    &environment env)
   (if (and (constantp slot-name env)
@@ -148,6 +150,8 @@
 (defun safe-set-slot-value (object slot-name new-value)
   (set-slot-value object slot-name new-value))
 
+;;; This is used during the PCL build, but gets replaced by a deftransform
+;;; in fixup.lisp.
 (define-compiler-macro set-slot-value (&whole form object slot-name new-value
                                       &environment env)
   (if (and (constantp slot-name env)

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index f24c436..1affc40 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -19,6 +19,7 @@
   (sb-ext:quit :unix-status 104))
 
 (load "test-util.lisp")
+(load "compiler-test-util.lisp")
 (load "assertoid.lisp")
 (use-package "TEST-UTIL")
 (use-package "ASSERTOID")
@@ -1145,6 +1146,19 @@
                   (make-array 3 :element-type 'single-float) (coerce pi 'single-float))))
   ;; Same bug manifests in COMPLEX-ATANH as well.
   (assert (= (atanh #C(-0.7d0 1.1d0)) #C(-0.28715567731069275d0 0.9394245539093365d0))))
+
+(with-test (:name :slot-value-on-structure)
+  (let ((f (compile nil `(lambda (x a b)
+                           (declare (something-known-to-be-a-struct x))
+                           (setf (slot-value x 'x) a
+                                 (slot-value x 'y) b)
+                           (list (slot-value x 'x)
+                                 (slot-value x 'y))))))
+    (assert (equal '(#\x #\y)
+                   (funcall f
+                            (make-something-known-to-be-a-struct :x "X" :y "Y")
+                            #\x #\y)))
+    (assert (not (ctu:find-named-callees f)))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

diff --git a/version.lisp-expr b/version.lisp-expr
index 936421e..ada1c4c 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".)
-"1.0.30.39"
+"1.0.30.40"