1.0.46.11: faster slot-accesses in the presence of SLOT-VALUE-USING-CLASS &co

[sbcl.git] / src / code / late-extensions.lisp

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index e72769f..5d2d598 100644 (file)
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -76,7 +76,7 @@
 (defmacro compare-and-swap (place old new &environment env)
   "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
 Two values are considered to match if they are EQ. Returns the previous value
 (defmacro compare-and-swap (place old new &environment env)
   "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
 Two values are considered to match if they are EQ. Returns the previous value

-of PLACE: if the returned value if EQ to OLD, the swap was carried out.
+of PLACE: if the returned value is EQ to OLD, the swap was carried out.

 
 PLACE must be an accessor form whose CAR is one of the following:
 
 
 PLACE must be an accessor form whose CAR is one of the following:
 

@@ -167,6 +167,87 @@ EXPERIMENTAL: Interface subject to change."
   (def %compare-and-swap-symbol-value (symbol) symbol-value)
   (def %compare-and-swap-svref (vector index) svref))
 
   (def %compare-and-swap-symbol-value (symbol) symbol-value)
   (def %compare-and-swap-svref (vector index) svref))
 

+(defun expand-atomic-frob (name place diff)
+  (flet ((invalid-place ()
+           (error "Invalid first argument to ~S: ~S" name place)))
+    (unless (consp place)
+      (invalid-place))
+    (destructuring-bind (op &rest args) place
+      (case op
+        (aref
+         (when (cddr args)
+           (invalid-place))
+         #!+(or x86 x86-64 ppc)
+         (with-unique-names (array)
+           `(let ((,array (the (simple-array sb!ext:word (*)) ,(car args))))
+              (%array-atomic-incf/word
+               ,array
+               (%check-bound ,array (array-dimension ,array 0) ,(cadr args))
+               (logand #.(1- (ash 1 sb!vm:n-word-bits))
+                       ,(ecase name
+                               (atomic-incf
+                                `(the sb!vm:signed-word ,diff))
+                               (atomic-decf
+                                `(- (the sb!vm:signed-word ,diff))))))))
+         #!-(or x86 x86-64 ppc)
+         (with-unique-names (array index old-value)
+           (let ((incremented-value
+                  (ecase name
+                         (atomic-incf
+                          `(+ ,old-value (the sb!vm:signed-word ,diff)))
+                         (atomic-decf
+                          `(- ,old-value (the sb!vm:signed-word ,diff))))))
+             `(sb!sys:without-interrupts
+               (let* ((,array ,(car args))
+                      (,index ,(cadr args))
+                      (,old-value (aref ,array ,index)))
+                 (setf (aref ,array ,index)
+                       (logand #.(1- (ash 1 sb!vm:n-word-bits))
+                               ,incremented-value))
+                 ,old-value)))))
+        (t
+         (when (cdr args)
+           (invalid-place))
+         (let ((dd (info :function :structure-accessor op)))
+           (if dd
+               (let* ((structure (dd-name dd))
+                      (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
+                      (index (dsd-index slotd))
+                      (type (dsd-type slotd)))
+                 (declare (ignorable structure index))
+                 (unless (and (eq 'sb!vm:word (dsd-raw-type slotd))
+                              (type= (specifier-type type) (specifier-type 'sb!vm:word)))
+                   (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S"
+                          name sb!vm:n-word-bits type place))
+                 (when (dsd-read-only slotd)
+                   (error "Cannot use ~S with structure accessor for a read-only slot: ~S"
+                          name place))
+                 #!+(or x86 x86-64 ppc)
+                 `(truly-the sb!vm:word
+                             (%raw-instance-atomic-incf/word
+                              (the ,structure ,@args) ,index
+                              (logand #.(1- (ash 1 sb!vm:n-word-bits))
+                                      ,(ecase name
+                                              (atomic-incf
+                                               `(the sb!vm:signed-word ,diff))
+                                              (atomic-decf
+                                               `(- (the sb!vm:signed-word ,diff)))))))
+                 ;; No threads outside x86 and x86-64 for now, so this is easy...
+                 #!-(or x86 x86-64 ppc)
+                 (with-unique-names (structure old)
+                                    `(sb!sys:without-interrupts
+                                      (let* ((,structure ,@args)
+                                             (,old (,op ,structure)))
+                                        (setf (,op ,structure)
+                                              (logand #.(1- (ash 1 sb!vm:n-word-bits))
+                                                      ,(ecase name
+                                                              (atomic-incf
+                                                               `(+ ,old (the sb!vm:signed-word ,diff)))
+                                                              (atomic-decf
+                                                               `(- ,old (the sb!vm:signed-word ,diff))))))
+                                        ,old))))
+             (invalid-place))))))))
+

 (defmacro atomic-incf (place &optional (diff 1))
   #!+sb-doc
   "Atomically increments PLACE by DIFF, and returns the value of PLACE before
 (defmacro atomic-incf (place &optional (diff 1))
   #!+sb-doc
   "Atomically increments PLACE by DIFF, and returns the value of PLACE before

@@ -178,48 +259,42 @@ PLACE.
 
 PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor
 whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms,
 
 PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor
 whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms,

-and (UNSIGNED-BYTE 64) on 64 bit platforms.
+and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY
+SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose.

 
 DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms,
 and (SIGNED-BYTE 64) on 64 bit platforms.
 
 EXPERIMENTAL: Interface subject to change."
 
 DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms,
 and (SIGNED-BYTE 64) on 64 bit platforms.
 
 EXPERIMENTAL: Interface subject to change."

-  (flet ((invalid-place ()
-           (error "Invalid first argument to ATOMIC-INCF: ~S" place)))
-    (unless (consp place)
-      (invalid-place))
-    (destructuring-bind (op &rest args) place
-      (when (cdr args)
-        (invalid-place))
-      (let ((dd (info :function :structure-accessor op)))
-        (if dd
-            (let* ((structure (dd-name dd))
-                   (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
-                   (index (dsd-index slotd))
-                   (type (dsd-type slotd)))
-              (declare (ignorable structure index))
-              (unless (and (eq 'sb!vm:word (dsd-raw-type slotd))
-                           (type= (specifier-type type) (specifier-type 'sb!vm:word)))
-                (error "ATOMIC-INCF requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S"
-                       sb!vm:n-word-bits type place))
-              (when (dsd-read-only slotd)
-                (error "Cannot use ATOMIC-INCF with structure accessor for a read-only slot: ~S"
-                       place))
-              #!+(or x86 x86-64)
-              `(truly-the sb!vm:word
-                          (%raw-instance-atomic-incf/word (the ,structure ,@args)
-                                                          ,index
-                                                          (the sb!vm:signed-word ,diff)))
-              ;; No threads outside x86 and x86-64 for now, so this is easy...
-              #!-(or x86 x86-64)
-              (with-unique-names (structure old)
-                `(sb!sys:without-interrupts
-                   (let* ((,structure ,@args)
-                          (,old (,op ,structure)))
-                     (setf (,op ,structure) (logand #.(1- (ash 1 sb!vm:n-word-bits))
-                                                    (+ ,old (the sb!vm:signed-word ,diff))))
-                     ,old))))
-            (invalid-place))))))
+  (expand-atomic-frob 'atomic-incf place diff))
+
+(defmacro atomic-decf (place &optional (diff 1))
+  #!+sb-doc
+  "Atomically decrements PLACE by DIFF, and returns the value of PLACE before
+the increment.
+
+The decrementation is done using word-size modular arithmetic: on 32 bit
+platforms ATOMIC-DECF of #x0 by one results in #xFFFFFFFF being stored in
+PLACE.
+
+PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor
+whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms,
+and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY
+SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose.
+
+DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms,
+and (SIGNED-BYTE 64) on 64 bit platforms.
+
+EXPERIMENTAL: Interface subject to change."
+  (expand-atomic-frob 'atomic-decf place diff))
+
+;; Interpreter stubs for ATOMIC-INCF.
+#!+(or x86 x86-64 ppc)
+(defun %array-atomic-incf/word (array index diff)
+  (declare (type (simple-array word (*)) array)
+           (fixnum index)
+           (type sb!vm:signed-word diff))
+  (%array-atomic-incf/word array index diff))

 
 (defun call-hooks (kind hooks &key (on-error :error))
   (dolist (hook hooks)
 
 (defun call-hooks (kind hooks &key (on-error :error))
   (dolist (hook hooks)