[Git][ghc/ghc][wip/tsan/fixes-2] 2 commits: testsuite: Add AtomicModifyIORef test

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/tsan/fixes-2 at Glasgow Haskell Compiler / GHC


Commits:
b1bbaed6 by Ben Gamari at 2023-06-23T16:21:01-04:00
testsuite: Add AtomicModifyIORef test

- - - - -
0d2e7625 by Ben Gamari at 2023-06-23T16:21:01-04:00
fixup! Fix synchronization on thread blocking state

- - - - -


3 changed files:

- + libraries/base/tests/AtomicModifyIORef.hs
- libraries/base/tests/all.T
- rts/PrimOps.cmm


Changes:

=====================================
libraries/base/tests/AtomicModifyIORef.hs
=====================================
@@ -0,0 +1,21 @@
+import Control.Concurrent
+import Control.Monad
+import Data.IORef
+
+main :: IO ()
+main = do
+    let nThreads = 10
+        nIncrs = 10000000
+
+    ref <- newIORef (42 :: Int)
+    dones <- replicateM nThreads $ do
+        done <- newEmptyMVar
+        forkIO $ do
+           replicateM_ nIncrs $ atomicModifyIORef' ref $ \old -> (old + 1, ())
+           putMVar done ()
+        putStrLn "."
+        return done
+
+    mapM_ takeMVar dones
+    readIORef ref >>= print
+


=====================================
libraries/base/tests/all.T
=====================================
@@ -308,5 +308,6 @@ test('listThreads', expect_broken_for(23272, ['ghci-opt']), compile_and_run, [''
 test('listThreads1', omit_ghci, compile_and_run, [''])
 test('inits1tails1', normal, compile_and_run, [''])
 test('CLC149', normal, compile, [''])
+test('AtomicModifyIORef', normal, compile_and_run, [''])
 test('AtomicSwapIORef', normal, compile_and_run, [''])
 test('T23454', normal, compile_fail, [''])


=====================================
rts/PrimOps.cmm
=====================================
@@ -1731,15 +1731,11 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ )
         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
         StgMVarTSOQueue_tso(q)  = CurrentTSO;
         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
-        // Write barrier before we make the new MVAR_TSO_QUEUE
-        // visible to other cores.
-        // See Note [Heap memory barriers]
-        RELEASE_FENCE;
 
         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-            StgMVar_head(mvar) = q;
+            %release StgMVar_head(mvar) = q;
         } else {
-            StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
+            %release StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
             ccall recordClosureMutated(MyCapability() "ptr",
                                              StgMVar_tail(mvar));
         }
@@ -1900,13 +1896,11 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */
         StgMVarTSOQueue_tso(q)  = CurrentTSO;
 
         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
-        // See Note [Heap memory barriers]
-        RELEASE_FENCE;
 
         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-            StgMVar_head(mvar) = q;
+            %release StgMVar_head(mvar) = q;
         } else {
-            StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
+            %release StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
             ccall recordClosureMutated(MyCapability() "ptr",
                                              StgMVar_tail(mvar));
         }
@@ -2109,13 +2103,11 @@ stg_readMVarzh ( P_ mvar, /* :: MVar a */ )
         StgMVarTSOQueue_tso(q)  = CurrentTSO;
 
         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
-        // See Note [Heap memory barriers]
-        RELEASE_FENCE;
 
+        %release StgMVar_head(mvar) = q;
         StgTSO__link(CurrentTSO)       = q;
         StgTSO_block_info(CurrentTSO)  = mvar;
         %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16;
-        StgMVar_head(mvar) = q;
 
         if (StgMVar_tail(mvar) == stg_END_TSO_QUEUE_closure) {
             StgMVar_tail(mvar) = q;
@@ -2243,7 +2235,7 @@ stg_readIOPortzh ( P_ ioport /* :: IOPort a */ )
 
         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
 
-        StgMVar_head(ioport) = q;
+        %release StgMVar_head(ioport) = q;
         StgTSO__link(CurrentTSO)       = q;
         StgTSO_block_info(CurrentTSO)  = ioport;
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e10dfa4737d446b6cace5af9e0eefef689c4ca99...0d2e7625a71e9a29b32de05e06422f965a13661d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e10dfa4737d446b6cace5af9e0eefef689c4ca99...0d2e7625a71e9a29b32de05e06422f965a13661d
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/20230623/6d17eb23/attachment-0001.html>