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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
module Examples.Test.Pool(main) where
import Examples.Util
import Development.Shake.Pool
import Control.Concurrent
import Control.Exception hiding (assert)
import Control.Monad
main = shaken test $ \args obj -> return ()
test build obj = do
let wait = sleep 0.01
forM_ [False,True] $ \deterministic -> do
-- check that it aims for exactly the limit
forM_ [1..6] $ \n -> do
var <- newMVar (0,0) -- (maximum, current)
runPool deterministic n $ \pool ->
forM_ [1..5] $ \i ->
addPool pool $ do
modifyMVar_ var $ \(mx,now) -> return (max (now+1) mx, now+1)
wait
modifyMVar_ var $ \(mx,now) -> return (mx,now-1)
res <- takeMVar var
res === (min n 5, 0)
-- check that exceptions are immediate
self <- myThreadId
handle (\(ErrorCall msg) -> msg === "pass") $
runPool deterministic 3 $ \pool -> do
addPool pool $ do
wait
error "pass"
addPool pool $ do
wait >> wait
throwTo self $ ErrorCall "fail"
wait >> wait -- give chance for a delayed exception
-- check blocking works
done <- newMVar False
runPool deterministic 1 $ \pool -> do
var <- newEmptyMVar
addPool pool $ do
addPool pool $ do
wait
putMVar var ()
blockPool pool $ fmap ((,) False) $ takeMVar var
modifyMVar_ done $ const $ return True
done <- readMVar done
assert done "Blocking"
-- check someone spawned when at zero todo still gets run
done <- newMVar False
runPool deterministic 1 $ \pool ->
addPool pool $ do
wait
addPool pool $ do
wait
modifyMVar_ done $ const $ return True
done <- readMVar done
assert done "Waiting on someone"
-- check that killing a thread pool stops the tasks, bug 545
thread <- newEmptyMVar
done <- newEmptyMVar
res <- newMVar True
t <- forkIO $ finally (putMVar done ()) $ runPool deterministic 1 $ \pool ->
addPool pool $ do
t <- takeMVar thread
killThread t
wait -- allow the thread to die first
modifyMVar_ res (const $ return False)
putMVar thread t
takeMVar done
wait >> wait >> wait -- allow the bad thread to continue
res <- readMVar res
assert res "Early termination"
|
