compiler: Implement atomicSwapIORef with xchg

As requested by @treeowl in CLC#139.

8 files changed, 26 insertions, 6 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index c6f205c6a5..3d6ad24666 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2604,6 +2604,13 @@ primop  WriteMutVarOp "writeMutVar#"  GenPrimOp
    has_side_effects = True
    code_size = { primOpCodeSizeForeignCall } -- for the write barrier
 
+primop  AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp
+   MutVar# s v -> v -> State# s -> (# State# s, v #)
+   {Atomically exchange the value of a 'MutVar#'.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
 -- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- Looking at the type of atomicModifyMutVar2#, one might wonder why
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index d222c783b3..048da3c14f 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1562,6 +1562,7 @@ emitPrimOp cfg primop =
   ResizeMutableByteArrayOp_Char -> alwaysExternal
   ShrinkSmallMutableArrayOp_Char -> alwaysExternal
   NewMutVarOp -> alwaysExternal
+  AtomicSwapMutVarOp -> alwaysExternal
   AtomicModifyMutVar2Op -> alwaysExternal
   AtomicModifyMutVar_Op -> alwaysExternal
   CasMutVarOp -> alwaysExternal
diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs
index 1bed788899..36f12e3409 100644
--- a/compiler/GHC/StgToJS/Prim.hs
+++ b/compiler/GHC/StgToJS/Prim.hs
@@ -801,6 +801,8 @@ genPrim prof bound ty op = case op of
   AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f]
   AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f]
 
+  AtomicSwapMutVarOp    -> \[r] [mv,v] -> PrimInline $ mconcat
+                                                [ r |= mv .^ "val", mv .^ "val" |= v ]
   CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o)
                    (mconcat [status |= zero_, r |= n, mv .^ "val" |= n])
                    (mconcat [status |= one_ , r |= mv .^ "val"])
diff --git a/libraries/base/GHC/IORef.hs b/libraries/base/GHC/IORef.hs
index f451746dcb..fe65b669fd 100644
--- a/libraries/base/GHC/IORef.hs
+++ b/libraries/base/GHC/IORef.hs
@@ -127,12 +127,7 @@ atomicModifyIORef'_ ref f = do
 -- | Atomically replace the contents of an 'IORef', returning
 -- the old contents.
 atomicSwapIORef :: IORef a -> a -> IO a
--- Bad implementation! This will be a primop shortly.
-atomicSwapIORef (IORef (STRef ref)) new = IO $ \s ->
-  case atomicModifyMutVar2# ref (\_old -> Box new) s of
-    (# s', old, Box _new #) -> (# s', old #)
-
-data Box a = Box a
+atomicSwapIORef (IORef (STRef ref)) new = IO (atomicSwapMutVar# ref new)
 
 -- | A strict version of 'Data.IORef.atomicModifyIORef'.  This forces both the
 -- value stored in the 'IORef' and the value returned.
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 60d0dc2ccc..9e86a8e0a2 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -689,6 +689,17 @@ stg_newMutVarzh ( gcptr init )
     return (mv);
 }
 
+stg_atomicSwapMutVarzh ( gcptr mv, gcptr new )
+ /* MutVar# s a -> a -> State# s -> (# State#, a #) */
+{
+    W_ old;
+    (old) = prim %xchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, new);
+    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
+        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr", old "ptr");
+    }
+    return (old);
+}
+
 // 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
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index dee6c57f5e..ebf73a2b69 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -633,6 +633,7 @@ extern char **environ;
       SymI_HasDataProto(stg_writeIOPortzh)                                  \
       SymI_HasDataProto(stg_newIOPortzh)                                    \
       SymI_HasDataProto(stg_noDuplicatezh)                                  \
+      SymI_HasDataProto(stg_atomicSwapMutVarzh)                             \
       SymI_HasDataProto(stg_atomicModifyMutVar2zh)                          \
       SymI_HasDataProto(stg_atomicModifyMutVarzuzh)                         \
       SymI_HasDataProto(stg_casMutVarzh)                                    \
diff --git a/rts/include/Cmm.h b/rts/include/Cmm.h
index 15df6d0df1..a1cf44c31b 100644
--- a/rts/include/Cmm.h
+++ b/rts/include/Cmm.h
@@ -193,8 +193,10 @@
 
 #if SIZEOF_W == 4
 #define cmpxchgW cmpxchg32
+#define xchgW xchg32
 #elif SIZEOF_W == 8
 #define cmpxchgW cmpxchg64
+#define xchgW xchg64
 #endif
 
 /* -----------------------------------------------------------------------------
diff --git a/rts/include/stg/MiscClosures.h b/rts/include/stg/MiscClosures.h
index 8e50336e4a..da556870f1 100644
--- a/rts/include/stg/MiscClosures.h
+++ b/rts/include/stg/MiscClosures.h
@@ -481,6 +481,7 @@ RTS_FUN_DECL(stg_copySmallMutableArrayzh);
 RTS_FUN_DECL(stg_casSmallArrayzh);
 
 RTS_FUN_DECL(stg_newMutVarzh);
+RTS_FUN_DECL(stg_atomicSwapMutVarzh);
 RTS_FUN_DECL(stg_atomicModifyMutVar2zh);
 RTS_FUN_DECL(stg_atomicModifyMutVarzuzh);
 RTS_FUN_DECL(stg_casMutVarzh);