1.0.43.30: threads: Initial implementation of ATOMIC-INCF for arrays.

  * Teach SB-IMPL::EXPAND-ATOMIC-FROB to deal with unboxed
vectors of words as places.

  * Define SB-KERNEL:%ARRAY-ATOMIC-INCF/WORD by analogy to
SB-KERNEL:%RAW-INSTACE-ATOMIC-INCF/WORD.

  * Add SB-KERNEL:%ARRAY-ATOMIC-INCF/WORD to the VM fndb.

  * While we're here, define an interpreter stub for
%ARRAY-ATOMIC-INCF/WORD.  %RAW-INSTANCE-ATOMIC-INCF/WORD
still needs one, but that's out of scope right now.

  * Note that this is just the arch-independent parts of
ATOMIC-INCF for arrays, the per-arch parts will be separate
commits.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 2e60e4a..78c8b4b 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1223,6 +1223,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%ARRAY-DISPLACED-FROM"
                "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER"
                "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK"
+               #!+(or)
+               "%ARRAY-ATOMIC-INCF/WORD"
                "%ASSOC"
                "%ASSOC-EQ"
                "%ASSOC-IF"

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 0062618..77582d0 100644 (file)
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -173,47 +173,80 @@ EXPERIMENTAL: Interface subject to change."
     (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 "~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))))))
+      (case op
+        (aref
+         (when (cddr args)
+           (invalid-place))
+         #!+(or)
+         (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)
+         (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
@@ -226,8 +259,8 @@ 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 -- the type SB-EXT:WORD can be used
-for this purpose.
+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.
@@ -246,8 +279,8 @@ 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 -- the type SB-EXT:WORD can be used
-for this purpose.
+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.
@@ -255,6 +288,14 @@ 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)
+(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)
     (handler-case

diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 8976ed2..dd11795 100644 (file)
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -168,6 +168,9 @@
 #!+(or x86 x86-64 ppc)
 (defknown %raw-instance-atomic-incf/word (instance index sb!vm:word) sb!vm:word
     (unsafe always-translatable))
+#!+(or)
+(defknown %array-atomic-incf/word (t index sb!vm:word) sb!vm:word
+  (unsafe always-translatable))
 
 ;;; These two are mostly used for bit-bashing operations.
 (defknown %vector-raw-bits (t fixnum) sb!vm:word

diff --git a/version.lisp-expr b/version.lisp-expr
index c4eb71b..4b56650 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.43.29"
+"1.0.43.30"