1.0.30.40: faster SLOT-VALUE on structures

[sbcl.git] / src / pcl / fixup.lisp

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"))))