From 796873d7b696e1079d2319844444040d18e0e2b1 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 6 Aug 2009 15:57:26 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ src/pcl/compiler-support.lisp | 40 -------------------------------------- src/pcl/fixup.lisp | 43 +++++++++++++++++++++++++++++++++++++++++ src/pcl/slots.lisp | 4 ++++ tests/compiler.impure.lisp | 14 ++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 64 insertions(+), 41 deletions(-) diff --git a/NEWS b/NEWS index c1e06eb..5eff26d 100644 --- 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 --- 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 --- 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 --- 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 --- 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))))) ;;;; 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 --- 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" -- 1.7.10.4