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