[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:
e0483c86 by Ben Gamari at 2023-03-29T10:51:19-04:00
compiler: Implement atomicSwapIORef with xchg

- - - - -
5f22089b by Ben Gamari at 2023-03-29T10:51:19-04:00
Make atomicSwapMutVar# an inline primop

- - - - -


5 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/base/GHC/IORef.hs
- rts/include/Cmm.h


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2537,6 +2537,12 @@ 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
+   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
=====================================
@@ -297,16 +297,12 @@ emitPrimOp cfg primop =
     -- MutVar's value.
     emitPrimCall [] (MO_AtomicWrite (wordWidth platform) MemOrderRelease)
         [ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ]
+    emitDirtyMutVar mutv (CmmReg old_val)
 
-    platform <- getPlatform
-    mkdirtyMutVarCCall <- getCode $! emitCCall
-      [{-no results-}]
-      (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
-      [(baseExpr platform, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]
-    emit =<< mkCmmIfThen
-      (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel)
-       (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv))
-      mkdirtyMutVarCCall
+  AtomicSwapMutVarOp -> \[mutv, val] -> opIntoRegs $ \[res] -> do
+    let dst = cmmOffsetW platform mutv (fixedHdrSizeW profile)
+    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val]
+    emitDirtyMutVar mutv (CmmReg (CmmLocal res))
 
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = ((StgArrBytes *)(a))->bytes
@@ -3232,6 +3228,21 @@ doByteArrayBoundsCheck idx arr idx_ty elem_ty = do
           (elem_sz - 1)
     doBoundsCheck idx_bytes sz
 
+-- | Write barrier for @MUT_VAR@ modification.
+emitDirtyMutVar :: CmmExpr -> CmmExpr -> FCode ()
+emitDirtyMutVar mutvar old_val = do
+    cfg <- getStgToCmmConfig
+    platform <- getPlatform
+    mkdirtyMutVarCCall <- getCode $! emitCCall
+      [{-no results-}]
+      (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
+      [(baseExpr platform, AddrHint), (mutvar, AddrHint), (old_val, AddrHint)]
+
+    emit =<< mkCmmIfThen
+      (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel)
+       (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutvar))
+      mkdirtyMutVarCCall
+
 ---------------------------------------------------------------------------
 -- Pushing to the update remembered set
 ---------------------------------------------------------------------------


=====================================
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,8 @@ 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.


=====================================
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/271e8a2988add7df70c55c0b9dd37e1bb6f9781f...5f22089b1c8d7ade8dca8afdd71f11a3e780dc2c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/271e8a2988add7df70c55c0b9dd37e1bb6f9781f...5f22089b1c8d7ade8dca8afdd71f11a3e780dc2c
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/20230329/1996f369/attachment-0001.html>