[Git][ghc/ghc][wip/ioref-swap-xchg] 2 commits: compiler: Implement atomicSwapIORef with xchg

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/ioref-swap-xchg at Glasgow Haskell Compiler / GHC


Commits:
8fa3a169 by Ben Gamari at 2023-03-20T11:34:39-04:00
compiler: Implement atomicSwapIORef with xchg

- - - - -
3ecbf7a2 by Ben Gamari at 2023-03-20T11:34:39-04:00
testsuite: Add test for atomicSwapIORef#

- - - - -


8 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/base/GHC/IORef.hs
- + libraries/base/tests/AtomicSwapIORef.hs
- libraries/base/tests/all.T
- rts/PrimOps.cmm
- rts/include/Cmm.h


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2464,6 +2464,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


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1559,6 +1559,7 @@ emitPrimOp cfg primop =
   ResizeMutableByteArrayOp_Char -> alwaysExternal
   ShrinkSmallMutableArrayOp_Char -> alwaysExternal
   NewMutVarOp -> alwaysExternal
+  AtomicSwapMutVarOp -> alwaysExternal
   AtomicModifyMutVar2Op -> alwaysExternal
   AtomicModifyMutVar_Op -> alwaysExternal
   CasMutVarOp -> alwaysExternal


=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -859,6 +859,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"])


=====================================
libraries/base/GHC/IORef.hs
=====================================
@@ -127,12 +127,9 @@ 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
+  case atomicSwapMutVar# ref new s of
+    (# s', old #) -> (# s', old #)
 
 -- | Strict version of 'Data.IORef.atomicModifyIORef'. This forces both
 -- the value stored in the 'IORef' and the value returned. The new value


=====================================
libraries/base/tests/AtomicSwapIORef.hs
=====================================
@@ -0,0 +1,7 @@
+import Data.IORef
+
+main :: IO ()
+main = do
+    r <- newIORef 42 :: IO Int
+    atomicSwapIORef r 43
+    readIORef r >>= print


=====================================
libraries/base/tests/all.T
=====================================
@@ -296,3 +296,4 @@ test('T22816', normal, compile_and_run, [''])
 test('trace', normal, compile_and_run, [''])
 test('listThreads', js_broken(22261), compile_and_run, [''])
 test('inits1tails1', normal, compile_and_run, [''])
+test('AtomicSwapIORef', normal, compile_and_run, [''])


=====================================
rts/PrimOps.cmm
=====================================
@@ -689,6 +689,14 @@ stg_newMutVarzh ( gcptr init )
     return (mv);
 }
 
+stg_swapMutVarzh ( gcptr mv, gcptr old )
+ /* MutVar# s a -> a -> State# s -> (# State#, a #) */
+{
+    W_ new;
+    (new) = prim %xchgW(mv+OFFSET_StgMutVar_var, old);
+    return (new);
+}
+
 // 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


=====================================
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
 
 /* -----------------------------------------------------------------------------



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b59504e25aa116639c467a391ec4e1d6149388c...3ecbf7a2672d72182c552c9ba9ffb45be68080af

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b59504e25aa116639c467a391ec4e1d6149388c...3ecbf7a2672d72182c552c9ba9ffb45be68080af
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230320/1a9847ef/attachment-0001.html>