blob: 6cc5f8b44a555638d1bb8d44e900f1df57284c50 (
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
52
|
{-# LANGUAGE ForeignFunctionInterface #-}
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.Exit
import System.Timeout
foreign import ccall safe "pause_resume.h pauseAndResume"
safe_pauseAndResume_c :: CBool -> Ptr CUInt -> IO ()
-- Test that concurrent calls to rts_pause()/rts_resume() doesn't cause deadlock.
main :: IO ()
main = do
alloca $ \countPtr -> do
poke countPtr 0
-- forever increment count. Changes will be observed from the c code.
sequence_ $ replicate 4 $ forkIO $ forever $ do
count <- peek countPtr
poke countPtr (count + 1)
threadDelay 10000 -- 10 milliseconds
-- Note that each call blocks for about a second, so this will take 5
-- seconds to complete.
let n = 5
mvars <- sequence $ replicate n newEmptyMVar
forM_ mvars $ \mvar -> forkIO $ do
safe_pauseAndResume_c
-- Don't check rts_isPaused() before rts_pause nore after rts_resume
-- because we're doing this concurrently so that would introduce a race
-- condition.
cFalse
countPtr
putMVar mvar ()
-- Wait (at least 2n seconds to be safe) for all threads to finish.
result <- timeout (2 * n * 1000000) (mapM_ takeMVar mvars)
case result of
Nothing -> do
putStrLn "Not all rts_pause/rts_resume threads have finished. Assuming deadlocked and failing test."
exitFailure
Just () -> do
putStrLn "All threads finished"
exitSuccess
cFalse :: CBool
cFalse = 0
|
