1.0.20.8: ATOMIC-INCF implementation

 * Modular arithmetic on word-sized unsigned structure slots.

 * Uses XADD on x86 and x86-64, a simple lisp-level implementation elsewhere.

NEWS

@@ -1,4 +1,6 @@
 ;;;; -*- coding: utf-8; -*-
+  * new feature: SB-EXT:ATOMIC-INCF allows atomic incrementation of
+    appropriately typed structure slots without locking.
   * enhancement: reduced conservativism on GENCGC platforms: on
     average 45% less pages pinned (measured from SBCL self build).
   * bug fix: SB-EXT:COMPARE-AND-SWAP on SYMBOL-VALUE can no longer

package-data-list.lisp-expr

@@ -576,6 +576,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "POSIX-GETENV" "POSIX-ENVIRON"
 
                "COMPARE-AND-SWAP"
+               "ATOMIC-INCF"
 
                ;; People have various good reasons to mess with the GC.
                "*AFTER-GC-HOOKS*"
@@ -1266,6 +1267,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%RAW-SET-COMPLEX-DOUBLE" "%RAW-SET-COMPLEX-LONG"
                "%RAW-SET-COMPLEX-SINGLE" "%RAW-SET-DOUBLE"
                "%RAW-SET-LONG" "%RAW-SET-SINGLE" "%SCALB" "%SCALBN"
+               #!+(or x86 x86-64)
+               "%RAW-INSTANCE-ATOMIC-INCF/WORD"
                "%RAW-INSTANCE-REF/WORD" "%RAW-INSTANCE-SET/WORD"
                "%RAW-INSTANCE-REF/SINGLE" "%RAW-INSTANCE-SET/SINGLE"
                "%RAW-INSTANCE-REF/DOUBLE" "%RAW-INSTANCE-SET/DOUBLE"

src/code/late-extensions.lisp

@@ -160,6 +160,61 @@ EXPERIMENTAL: Interface subject to change."
   (def %compare-and-swap-symbol-value (symbol) symbol-value)
   (def %compare-and-swap-svref (vector index) svref))
 
+(defmacro atomic-incf (place &optional (diff 1) &environment env)
+  #!+sb-doc
+  "Atomically increments PLACE by DIFF, and returns the value of PLACE before
+the increment.
+
+The incrementation is done using word-size modular arithmetic: on 32 bit
+platforms ATOMIC-INCF of #xFFFFFFFF by one results in #x0 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.
+
+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)))
+    (let ((place (macroexpand place env)))
+      (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 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)))))))
+
 (defun call-hooks (kind hooks &key (on-error :error))
   (dolist (hook hooks)
     (handler-case

src/compiler/generic/vm-fndb.lisp

@@ -153,8 +153,11 @@
 (defknown %raw-instance-set/complex-double
     (instance index (complex double-float))
   (complex double-float)
-  (unsafe always-translatable))
-)
+  (unsafe always-translatable)))
+
+#!+(or x86 x86-64)
+(defknown %raw-instance-atomic-incf/word (instance index sb!vm:signed-word) sb!vm:word
+    (unsafe always-translatable))
 
 ;;; %RAW-{REF,SET}-FOO VOPs should be declared as taking a RAW-VECTOR
 ;;; as their first argument (clarity and to match these DEFKNOWNs).

src/compiler/x86-64/cell.lisp

@@ -624,6 +624,27 @@
   (:generator 4
     (inst mov (make-ea-for-raw-slot object index instance-length) value)))
 
+(define-vop (raw-instance-atomic-incf-c/word)
+  (:translate %raw-instance-atomic-incf/word)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (diff :scs (signed-reg) :target result))
+  (:arg-types * (:constant (load/store-index #.n-word-bytes
+                                             #.instance-pointer-lowtag
+                                             #.instance-slots-offset))
+              signed-num)
+  (:info index)
+  (:temporary (:sc unsigned-reg) tmp)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 4
+    (loadw tmp object 0 instance-pointer-lowtag)
+    (inst shr tmp n-widetag-bits)
+    #!+sb-thread
+    (inst lock)
+    (inst xadd (make-ea-for-raw-slot object index tmp) diff)
+    (move result diff)))
+
 (define-vop (raw-instance-ref/single)
   (:translate %raw-instance-ref/single)
   (:policy :fast-safe)

src/compiler/x86/cell.lisp

@@ -573,6 +573,27 @@
   (:generator 5
     (inst mov (make-ea-for-raw-slot object index instance-length 1) value)))
 
+(define-vop (raw-instance-atomic-incf/word)
+  (:translate %raw-instance-atomic-incf/word)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg immediate))
+         (diff :scs (signed-reg) :target result))
+  (:arg-types * tagged-num signed-num)
+  (:temporary (:sc unsigned-reg) tmp)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 5
+    (loadw tmp object 0 instance-pointer-lowtag)
+    (inst shr tmp n-widetag-bits)
+    (when (sc-is index any-reg)
+      (inst shl tmp 2)
+      (inst sub tmp index))
+    #!+sb-thread
+    (inst lock)
+    (inst xadd (make-ea-for-raw-slot object index tmp 1) diff)
+    (move result diff)))
+
 (define-vop (raw-instance-ref/single)
   (:translate %raw-instance-ref/single)
   (:policy :fast-safe)

tests/compare-and-swap.impure.lisp

@@ -104,3 +104,36 @@
        (handler-case
            (sb-ext:compare-and-swap (symbol-value name) t 42)
          (error () :error)))))
+
+;;;; ATOMIC-INCF (we should probably rename this file atomic-ops...)
+
+(defstruct box
+  (word 0 :type sb-vm:word))
+
+(defun inc-box (box n)
+  (declare (fixnum n) (box box))
+  (loop repeat n
+        do (sb-ext:atomic-incf (box-word box))))
+
+(defun dec-box (box n)
+  (declare (fixnum n) (box box))
+  (loop repeat n
+        do (sb-ext:atomic-incf (box-word box) -1)))
+
+(let ((box (make-box)))
+  (inc-box box 10000)
+  (assert (= 10000 (box-word box)))
+  (dec-box box 10000)
+  (assert (= 0 (box-word box))))
+
+#+sb-thread
+(let* ((box (make-box))
+       (threads (loop repeat 64
+                      collect (sb-thread:make-thread (lambda ()
+                                                       (inc-box box 1000)
+                                                       (dec-box box 10000)
+                                                       (inc-box box 10000)
+                                                       (dec-box box 1000))
+                                                     :name "inc/dec thread"))))
+  (mapc #'sb-thread:join-thread threads)
+  (assert (= 0 (box-word box))))

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.20.7"
+"1.0.20.8"