[commit: ghc] atomics: add casArray# primop, similar to casMutVar# but for array elements (3ca7ecb)

[git at git.haskell.org]

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

On branch  : atomics
Link       : http://ghc.haskell.org/trac/ghc/changeset/3ca7ecb57eefc43b4347e22ad2fd7a4962d84020/ghc

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

commit 3ca7ecb57eefc43b4347e22ad2fd7a4962d84020
Author: Ryan Newton <rrnewton at gmail.com>
Date:   Thu Mar 29 00:32:03 2012 -0400

    add casArray# primop, similar to casMutVar# but for array elements


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

3ca7ecb57eefc43b4347e22ad2fd7a4962d84020
 compiler/prelude/primops.txt.pp |    8 ++++++++
 includes/stg/MiscClosures.h     |    1 +
 rts/Linker.c                    |    1 +
 rts/PrimOps.cmm                 |   27 +++++++++++++++++++++++++++
 4 files changed, 37 insertions(+)

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index e275b23..6e25d65 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -794,6 +794,14 @@ primop  ThawArrayOp "thawArray#" GenPrimOp
   has_side_effects = True
   code_size = { primOpCodeSizeForeignCall + 4 }
 
+primop CasArrayOp  "casArray#" GenPrimOp
+   MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #)
+   {Unsafe, machine-level atomic compare and swap on an element within an Array.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
+
 ------------------------------------------------------------------------
 section "Byte Arrays"
 	{Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index b0ed03b..de5d322 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -364,6 +364,7 @@ RTS_FUN_DECL(stg_word64ToIntegerzh);
 #endif
 
 RTS_FUN_DECL(stg_unsafeThawArrayzh);
+RTS_FUN_DECL(stg_casArrayzh);
 RTS_FUN_DECL(stg_newByteArrayzh);
 RTS_FUN_DECL(stg_newPinnedByteArrayzh);
 RTS_FUN_DECL(stg_newAlignedPinnedByteArrayzh);
diff --git a/rts/Linker.c b/rts/Linker.c
index 0c7dfd2..1cb9b1f 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1144,6 +1144,7 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stg_labelThreadzh)                                  \
       SymI_HasProto(stg_newArrayzh)                                     \
       SymI_HasProto(stg_newArrayArrayzh)                                \
+      SymI_HasProto(stg_casArrayzh)                                     \
       SymI_HasProto(stg_newBCOzh)                                       \
       SymI_HasProto(stg_newByteArrayzh)                                 \
       SymI_HasProto_redirect(newCAF, newDynCAF)                         \
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index ced15ee..3bf5f37 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -206,6 +206,33 @@ stg_unsafeThawArrayzh ( gcptr arr )
   }
 }
 
+stg_casArrayzh
+/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) */
+{
+    W_ arr, p, ind, old, new, h, len;
+    arr = R1; // anything else?
+    ind = R2;
+    old = R3;
+    new = R4;
+
+    p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);
+    (h) = foreign "C" cas(p, old, new) [];
+    
+    if (h != old) {
+        // Failure, return what was there instead of 'old':
+        RET_NP(1,h);
+    } else {
+        // Compare and Swap Succeeded:
+        if (GET_INFO(arr) == stg_MUT_ARR_PTRS_CLEAN_info) {
+           SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
+           len = StgMutArrPtrs_ptrs(arr);
+           // The write barrier.  We must write a byte into the mark table:
+           I8[arr + SIZEOF_StgMutArrPtrs + WDS(len) + (ind >> MUT_ARR_PTRS_CARD_BITS )] = 1;
+        }
+        RET_NP(0,h);
+    }
+}
+
 stg_newArrayArrayzh ( W_ n /* words */ )
 {
     W_ words, size;