Add PrimOp fetchAddIntArray# plus supporting C function atomic_inc_by.
authorRyan Newton <rrnewton@gmail.com>
Sun, 4 Aug 2013 00:19:46 +0000 (20:19 -0400)
committerRyan Newton <rrnewton@gmail.com>
Wed, 21 Aug 2013 04:02:30 +0000 (00:02 -0400)
compiler/prelude/primops.txt.pp
includes/stg/MiscClosures.h
includes/stg/SMP.h
rts/Linker.c
rts/PrimOps.cmm

index 6ee39c5..094c2f5 100644 (file)
@@ -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"
index ee973e4..876f39a 100644 (file)
@@ -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);
 
index bfd6bbc..bdcaf55 100644 (file)
@@ -61,6 +61,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
  *
  * atomic_dec(p) {
@@ -236,28 +246,35 @@ 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)
 {
 #if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)
@@ -397,6 +414,13 @@ atomic_inc(StgVolatilePtr p)
 }
 
 INLINE_HEADER StgWord
+atomic_inc_by(StgVolatilePtr p, StgWord incr)
+{
+    return ((*p) += incr);
+}
+
+
+INLINE_HEADER StgWord
 atomic_dec(StgVolatilePtr p)
 {
     return --(*p);
index 0a0996a..92194df 100644 (file)
@@ -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)                                    \
index cc22d22..b7177ca 100644 (file)
@@ -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;