Update Trac ticket URLs to point to GitLab
[ghc.git] / libraries / base / tests / T11760.hs
1 -- Written by Bertram Felgenhauer
2 --
3 -- https://gitlab.haskell.org/ghc/ghc/issues/11760#note_131217
4 --
5 -- Compile with -threaded -with-rtsopts=-N2
6
7 {-# LANGUAGE BangPatterns #-}
8 import Control.Concurrent
9 import Control.Monad
10 import Control.Monad.ST.Lazy
11 import Control.Exception
12 import Data.STRef
13 import Data.IORef
14 import Control.Concurrent.MVar
15 import Data.List
16
17 -- evil ST action that tries to synchronize (by busy waiting on the
18 -- shared STRef) with a concurrent evaluation
19 evil :: ST s [Int]
20 evil = do
21 r <- strictToLazyST $ newSTRef 0
22 replicateM 100 $ do
23 i <- strictToLazyST $ readSTRef r
24 let !j = i + 1
25 strictToLazyST $ writeSTRef r j
26 let go 0 = return ()
27 go n = do
28 i' <- strictToLazyST $ readSTRef r
29 when (j == i') $ go (n-1)
30 go 100
31 return j
32
33 main = do
34 let res = runST evil
35 s0 <- newIORef (map pred (0 : res))
36 s1 <- newIORef (map pred (1 : res))
37 m0 <- newMVar ()
38 m1 <- newMVar ()
39 forkIO $ do
40 putMVar m0 ()
41 readIORef s0 >>= evaluate . foldl' (+) 0
42 putMVar m0 ()
43 forkIO $ do
44 putMVar m1 ()
45 readIORef s1 >>= evaluate . foldl' (+) 0
46 putMVar m1 ()
47 threadDelay 10000
48 replicateM 3 $ takeMVar m0 >> takeMVar m1
49 v0 <- tail <$> readIORef s0
50 v1 <- tail <$> readIORef s1
51 print (v0 == v1)