Use MO_Cmpxchg in Primops.cmm instead of ccall cas(..)

Adjust `CmmParse.y` to parse the `cmpxchg{8, 16, 32, 64}` instructions
and use the 32 respectively the 64 bit variant in `Primops.cmm`. This
effectively eliminates the compare-and-swap ccall to the rts.

Based off the mailing list question from @osa1
(https://mail.haskell.org/pipermail/ghc-devs/2016-July/012506.html).

Reviewers: simonmar, austin, erikd, bgamari, trommler

Reviewed By: erikd, bgamari, trommler

Subscribers: carter, trommler, osa1, thomie

Differential Revision: https://phabricator.haskell.org/D2431

3 files changed, 21 insertions, 6 deletions

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 128cc4e4e1..b8c100a3c0 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -987,7 +987,12 @@ callishMachOps = listToUFM $
         ( "popcnt8",  (,) $ MO_PopCnt W8  ),
         ( "popcnt16", (,) $ MO_PopCnt W16 ),
         ( "popcnt32", (,) $ MO_PopCnt W32 ),
-        ( "popcnt64", (,) $ MO_PopCnt W64 )
+        ( "popcnt64", (,) $ MO_PopCnt W64 ),
+
+        ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
+        ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
+        ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
+        ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )
 
         -- ToDo: the rest, maybe
         -- edit: which rest?
diff --git a/includes/Cmm.h b/includes/Cmm.h
index 3b9a5a6794..9b7a4e4608 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -179,6 +179,16 @@
 #endif
 
 /* -----------------------------------------------------------------------------
+   Atomic memory operations.
+   -------------------------------------------------------------------------- */
+
+#if SIZEOF_W == 4
+#define cmpxchgW cmpxchg32
+#elif SIZEOF_W == 8
+#define cmpxchgW cmpxchg64
+#endif
+
+/* -----------------------------------------------------------------------------
    Heap/stack access, and adjusting the heap/stack pointers.
    -------------------------------------------------------------------------- */
 
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 60d8106983..b468c33df6 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -221,7 +221,7 @@ stg_casIntArrayzh( gcptr arr, W_ ind, W_ old, W_ new )
     W_ p, h;
 
     p = arr + SIZEOF_StgArrBytes + WDS(ind);
-    (h) = ccall cas(p, old, new);
+    (h) = prim %cmpxchgW(p, old, new);
 
     return(h);
 }
@@ -338,7 +338,7 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
     W_ p, len;
 
     p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);
-    (h) = ccall cas(p, old, new);
+    (h) = prim %cmpxchgW(p, old, new);
 
     if (h != old) {
         // Failure, return what was there instead of 'old':
@@ -490,7 +490,7 @@ stg_casSmallArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
     W_ p, len;
 
     p = arr + SIZEOF_StgSmallMutArrPtrs + WDS(ind);
-    (h) = ccall cas(p, old, new);
+    (h) = prim %cmpxchgW(p, old, new);
 
     if (h != old) {
         // Failure, return what was there instead of 'old':
@@ -530,7 +530,7 @@ stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
 {
     gcptr h;
 
-    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
+    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
     if (h != old) {
         return (1,h);
     } else {
@@ -606,7 +606,7 @@ stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
     x = StgMutVar_var(mv);
     StgThunk_payload(z,1) = x;
 #ifdef THREADED_RTS
-    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
+    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
     if (h != x) { goto retry; }
 #else
     StgMutVar_var(mv) = y;