Add PrimOp fetchAddIntArray# plus supporting C function atomic_inc_by.

compiler/prelude/primops.txt.pp

@@ -1125,6 +1125,13 @@ primop CasByteArrayOp_Int "casIntArray#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
+primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) 
+   {Machine-level word-sized fetch-and-add within a ByteArray.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
 
 ------------------------------------------------------------------------
 section "Arrays of arrays"

includes/stg/MiscClosures.h

@@ -369,6 +369,7 @@ RTS_FUN_DECL(stg_newByteArrayzh);
 RTS_FUN_DECL(stg_newPinnedByteArrayzh);
 RTS_FUN_DECL(stg_newAlignedPinnedByteArrayzh);
 RTS_FUN_DECL(stg_casIntArrayzh);
+RTS_FUN_DECL(stg_fetchAddIntArrayzh);
 RTS_FUN_DECL(stg_newArrayzh);
 RTS_FUN_DECL(stg_newArrayArrayzh);
 

includes/stg/SMP.h

@@ -60,6 +60,16 @@ EXTERN_INLINE StgWord cas(StgVolatilePtr p, StgWord o, StgWord n);
  */
 EXTERN_INLINE StgWord atomic_inc(StgVolatilePtr p);
 
+/*
+ * Atomic addition by the provided quantity
+ *
+ * atomic_inc_by(p, n) {
+ *   return ((*p) += n);
+ * }
+ */
+EXTERN_INLINE StgWord atomic_inc_by(StgVolatilePtr p, StgWord n);
+
+
 /*
  * Atomic decrement
  *
@@ -236,27 +246,34 @@ cas(StgVolatilePtr p, StgWord o, StgWord n)
 #endif
 }
 
+// RRN: Added to enable general fetch-and-add in Haskell code (fetchAddIntArray#).
 EXTERN_INLINE StgWord
-atomic_inc(StgVolatilePtr p)
+atomic_inc_by(StgVolatilePtr p, StgWord incr)
 {
 #if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)
     StgWord r;
-    r = 1;
+    r = incr;
     __asm__ __volatile__ (
         "lock\nxadd %0,%1":
             "+r" (r), "+m" (*p):
     );
-    return r+1;
+    return r + incr;
 #else
     StgWord old, new;
     do {
         old = *p;
-        new = old + 1;
+        new = old + incr;
     } while (cas(p, old, new) != old);
     return new;
 #endif
 }
 
+EXTERN_INLINE StgWord
+atomic_inc(StgVolatilePtr p)
+{
+  return atomic_inc_by(p, 1);
+}
+
 EXTERN_INLINE StgWord
 atomic_dec(StgVolatilePtr p)
 {
@@ -396,6 +413,13 @@ atomic_inc(StgVolatilePtr p)
     return ++(*p);
 }
 
+INLINE_HEADER StgWord
+atomic_inc_by(StgVolatilePtr p, StgWord incr)
+{
+    return ((*p) += incr);
+}
+
+
 INLINE_HEADER StgWord
 atomic_dec(StgVolatilePtr p)
 {

rts/Linker.c

@@ -1148,6 +1148,7 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stg_newBCOzh)                                       \
       SymI_HasProto(stg_newByteArrayzh)                                 \
       SymI_HasProto(stg_casIntArrayzh)                                  \
+      SymI_HasProto(stg_fetchAddIntArrayzh)                             \
       SymI_HasProto_redirect(newCAF, newDynCAF)                         \
       SymI_HasProto(stg_newMVarzh)                                      \
       SymI_HasProto(stg_newMutVarzh)                                    \

rts/PrimOps.cmm

@@ -142,7 +142,6 @@ stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
 stg_casIntArrayzh( gcptr arr, W_ ind, W_ old, W_ new )
 /* MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) */
 {
-    W_ len;
     gcptr p,h;
 
     p = arr + SIZEOF_StgArrWords + WDS(ind);
@@ -151,6 +150,19 @@ stg_casIntArrayzh( gcptr arr, W_ ind, W_ old, W_ new )
     return(h);
 }
 
+
+stg_fetchAddIntArrayzh( gcptr arr, W_ ind, W_ incr )
+/* MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) */
+{
+    gcptr p, h;
+
+    p = arr + SIZEOF_StgArrWords + WDS(ind);
+    (h) = ccall atomic_inc_by(p, incr);
+
+    return(h);
+}
+
+
 stg_newArrayzh ( W_ n /* words */, gcptr init )
 {
     W_ words, size;