diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index c6f205c6a552d83f50cb8a798fd514b651a56d7a..3d6ad24666c614310119aad13e67ff69761c083e 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 d222c783b3761289c769848ba2a8adc846d69e34..048da3c14f76dad96eae41f4b48a94bae485e0b3 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 1bed7888990146d5c145f072fbfee1f97d5432bc..36f12e3409d9b320aa474b1c84b15d09fdd88bd6 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 f451746dcba78aa0f87b3d61e9e1af202613c0b6..fe65b669fdd5236c786870e848233e22407c97f0 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 60d0dc2cccefc971e2e35f1da84778df3388f687..9e86a8e0a26bce558bdc2eabf2dfa05913f229da 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 dee6c57f5ee381d8fdb1db29995f18433417ddd7..ebf73a2b69c1016216f13c78e2c6b24339774209 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 15df6d0df1c35c784da665bcf07e874d99f37f11..a1cf44c31b3d28ed963e032958dba4414afc6532 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 8e50336e4a2dc5c7cdc65856d3294b6cd637be33..da556870f152e4447f7f35fecad9443ef390d998 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);