blob: c61d2896c22184288548a62d50b96e58e08d6052 (
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
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
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.List (sort)
new = newQSemN
wait = waitQSemN
signal = signalQSemN
--------
-- dummy test-framework
type Assertion = IO ()
x @?= y = when (x /= y) $ error (show x ++ " /= " ++ show y)
testCase :: String -> IO () -> IO ()
testCase n io = putStrLn ("test " ++ n) >> io
defaultMain = sequence
------
main = defaultMain tests
tests = [
testCase "semn" semn,
testCase "semn2" semn2,
testCase "semn3" semn3,
testCase "semn_kill" semn_kill,
testCase "semn_bracket" sem_bracket
]
semn :: Assertion
semn = do
c <- newEmptyMVar
q <- new 0
t1 <- forkIO $ do wait q 1; putMVar c 'a'
threadDelay 10000
t2 <- forkIO $ do wait q 2; putMVar c 'b'
threadDelay 10000
t3 <- forkIO $ do wait q 3; putMVar c 'c'
threadDelay 10000
signal q 1
a <- takeMVar c
signal q 2
b <- takeMVar c
signal q 3
c <- takeMVar c
[a,b,c] @?= "abc"
semn2 :: Assertion
semn2 = do
c <- newEmptyMVar
q <- new 0
t1 <- forkIO $ do wait q 1; putMVar c 'a'
threadDelay 10000
t2 <- forkIO $ do wait q 2; putMVar c 'b'
threadDelay 10000
t3 <- forkIO $ do wait q 3; putMVar c 'c'
threadDelay 10000
signal q 6
a <- takeMVar c
b <- takeMVar c
c <- takeMVar c
sort [a,b,c] @?= "abc"
semn3 :: Assertion
semn3 = do
c <- newEmptyMVar
q <- new 0
t1 <- forkIO $ do wait q 1; putMVar c 'a'
threadDelay 10000
t2 <- forkIO $ do wait q 2; putMVar c 'b'
threadDelay 10000
t3 <- forkIO $ do wait q 3; putMVar c 'c'
threadDelay 10000
signal q 3
a <- takeMVar c
b <- takeMVar c
threadDelay 10000
sort [a,b] @?= "ab"
d <- isEmptyMVar c
d @?= True
signal q 1
threadDelay 10000
d <- isEmptyMVar c
d @?= True
signal q 2
x <- takeMVar c
x @?= 'c'
semn_kill :: Assertion
semn_kill = do
q <- new 0
t <- forkIO $ do wait q 1
threadDelay 10000
killThread t
m <- newEmptyMVar
t <- forkIO $ do wait q 1; putMVar m ()
signal q 1
takeMVar m
sem_bracket :: Assertion
sem_bracket = do
q <- new 1
ts <- forM [1..100000] $ \n -> do
forkIO $ do bracket_ (wait q 1) (signal q 1) (return ())
mapM_ killThread ts
wait q 1
|
