From 81cfefd2cfb9d97a19d8e543130f94248e667330 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 15 Mar 2023 20:50:38 -0400
Subject: [PATCH] compiler: Implement atomicSwapIORef with xchg
As requested by @treeowl in CLC#139.
---
compiler/GHC/Builtin/primops.txt.pp | 7 +++++++
compiler/GHC/StgToCmm/Prim.hs | 1 +
compiler/GHC/StgToJS/Prim.hs | 2 ++
libraries/base/GHC/IORef.hs | 7 +------
rts/PrimOps.cmm | 11 +++++++++++
rts/RtsSymbols.c | 1 +
rts/include/Cmm.h | 2 ++
rts/include/stg/MiscClosures.h | 1 +
8 files changed, 26 insertions(+), 6 deletions(-)
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index c6f205c6a552..3d6ad24666c6 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 d222c783b376..048da3c14f76 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 1bed78889901..36f12e3409d9 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 f451746dcba7..fe65b669fdd5 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 60d0dc2cccef..9e86a8e0a26b 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 dee6c57f5ee3..ebf73a2b69c1 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 15df6d0df1c3..a1cf44c31b3d 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 8e50336e4a2d..da556870f152 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);
--
GitLab