[commit: ghc] atomics: Add PrimOp: casIntArray#. Modify casMutVar# for 'ticketed' style. (fa27838)

[git at git.haskell.org]

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

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

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

commit fa278381cca92c895ddf14e6a92f78e9786fec48
Author: Ryan Newton <rrnewton at gmail.com>
Date:   Sat Aug 3 02:35:11 2013 -0400

    Add PrimOp: casIntArray#.  Modify casMutVar# for 'ticketed' style.


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

fa278381cca92c895ddf14e6a92f78e9786fec48
 compiler/prelude/primops.txt.pp |    8 ++++++++
 includes/stg/MiscClosures.h     |    1 +
 rts/Linker.c                    |    1 +
 rts/PrimOps.cmm                 |   24 ++++++++++++++++++++++--
 4 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 6e25d65..6ee39c5 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -1118,6 +1118,14 @@ primop  SetByteArrayOp "setByteArray#" GenPrimOp
   code_size = { primOpCodeSizeForeignCall + 4 }
   can_fail = True
 
+primop CasByteArrayOp_Int "casIntArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #)
+   {Machine-level atomic compare and swap on a word within a ByteArray.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
+
 ------------------------------------------------------------------------
 section "Arrays of arrays"
 	{Operations on {\tt ArrayArray\#}. An {\tt ArrayArray\#} contains references to {\em unpointed}
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index de5d322..ee973e4 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -368,6 +368,7 @@ RTS_FUN_DECL(stg_casArrayzh);
 RTS_FUN_DECL(stg_newByteArrayzh);
 RTS_FUN_DECL(stg_newPinnedByteArrayzh);
 RTS_FUN_DECL(stg_newAlignedPinnedByteArrayzh);
+RTS_FUN_DECL(stg_casIntArrayzh);
 RTS_FUN_DECL(stg_newArrayzh);
 RTS_FUN_DECL(stg_newArrayArrayzh);
 
diff --git a/rts/Linker.c b/rts/Linker.c
index 1cb9b1f..0a0996a 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1147,6 +1147,7 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stg_casArrayzh)                                     \
       SymI_HasProto(stg_newBCOzh)                                       \
       SymI_HasProto(stg_newByteArrayzh)                                 \
+      SymI_HasProto(stg_casIntArrayzh)                                  \
       SymI_HasProto_redirect(newCAF, newDynCAF)                         \
       SymI_HasProto(stg_newMVarzh)                                      \
       SymI_HasProto(stg_newMutVarzh)                                    \
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 7103307..cc22d22 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -137,6 +137,20 @@ stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
     return (p);
 }
 
+// RRN: This one does not use the "ticketing" approach because it
+// deals in unboxed scalars, not heap pointers.
+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);
+    (h) = ccall cas(p, old, new);
+
+    return(h);
+}
+
 stg_newArrayzh ( W_ n /* words */, gcptr init )
 {
     W_ words, size;
@@ -206,6 +220,7 @@ stg_unsafeThawArrayzh ( gcptr arr )
   }
 }
 
+// RRN: Uses the ticketed approach; see casMutVar
 stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
 /* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) */
 {
@@ -224,7 +239,7 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
 	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;
-        return (0,h);
+        return (0,new);
     }
 }
 
@@ -284,6 +299,11 @@ stg_newMutVarzh ( gcptr init )
     return (mv);
 }
 
+// RRN: To support the "ticketed" approach, we return the NEW rather
+// than old value if the CAS is successful.  This is received in an
+// opaque form in the Haskell code, preventing the compiler from
+// changing its pointer identity.  The ticket can then be safely used
+// in future CAS operations.
 stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
  /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, a #) */
 {
@@ -297,7 +317,7 @@ stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
         if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
         }
-        return (0,h);
+        return (0,new);
     }
 }