[commit: ghc] atomics: Add PrimOp fetchAddIntArray# plus supporting C function atomic_inc_by. (8750d54)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : atomics
Link       : http://ghc.haskell.org/trac/ghc/changeset/8750d549d4d7aca3e397de3e217b7cca9e1c1d43/ghc

>---------------------------------------------------------------

commit 8750d549d4d7aca3e397de3e217b7cca9e1c1d43
Author: Ryan Newton <rrnewton at gmail.com>
Date:   Sat Aug 3 20:19:46 2013 -0400

    Add PrimOp fetchAddIntArray# plus supporting C function atomic_inc_by.


>---------------------------------------------------------------

8750d549d4d7aca3e397de3e217b7cca9e1c1d43
 compiler/prelude/primops.txt.pp |    7 +++++++
 includes/stg/MiscClosures.h     |    1 +
 includes/stg/SMP.h              |   32 ++++++++++++++++++++++++++++----
 rts/Linker.c                    |    1 +
 rts/PrimOps.cmm                 |   14 +++++++++++++-
 5 files changed, 50 insertions(+), 5 deletions(-)

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 6ee39c5..094c2f5 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/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"
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index ee973e4..876f39a 100644
--- a/includes/stg/MiscClosures.h
+++ b/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);
 
diff --git a/includes/stg/SMP.h b/includes/stg/SMP.h
index bfd6bbc..bdcaf55 100644
--- a/includes/stg/SMP.h
+++ b/includes/stg/SMP.h
@@ -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);
diff --git a/rts/Linker.c b/rts/Linker.c
index 0a0996a..92194df 100644
--- a/rts/Linker.c
+++ b/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)                                    \
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index cc22d22..b7177ca 100644
--- a/rts/PrimOps.cmm
+++ b/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;