blob: 0088c6e9895b890d16460d21c9ec28042858f9a1 (
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
|
import Control.Concurrent.QSem as OldQ
import Control.Concurrent.Chan
import Control.Concurrent (forkIO, threadDelay, killThread, yield)
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
new = newQSem
wait = waitQSem
signal = signalQSem
--------
-- 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 "sem1" sem1,
testCase "sem2" sem2,
testCase "sem_kill" sem_kill,
testCase "sem_fifo" sem_fifo,
testCase "sem_bracket" sem_bracket
]
sem1 :: Assertion
sem1 = do
q <- new 0
signal q
wait q
sem2 :: Assertion
sem2 = do
q <- new 0
signal q
signal q
wait q
wait q
sem_fifo :: Assertion
sem_fifo = do
c <- newChan
q <- new 0
t1 <- forkIO $ do wait q; writeChan c 'a'
threadDelay 10000
t2 <- forkIO $ do wait q; writeChan c 'b'
threadDelay 10000
t3 <- forkIO $ do wait q; writeChan c 'c'
threadDelay 10000
signal q
a <- readChan c
signal q
b <- readChan c
signal q
c <- readChan c
[a,b,c] @?= "abc"
sem_kill :: Assertion
sem_kill = do
q <- new 0
t <- forkIO $ do wait q
threadDelay 100000
killThread t
m <- newEmptyMVar
t <- forkIO $ do wait q; putMVar m ()
signal q
takeMVar m
sem_bracket :: Assertion
sem_bracket = do
q <- new 1
ts <- forM [1..100000] $ \n -> do
forkIO $ do bracket_ (wait q) (signal q) (return ())
mapM_ killThread ts
wait q
|
