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
|
{-# OPTIONS_GHC -fglasgow-exts #-}
import Test.QuickCheck
import Control.Monad
import Data.Maybe (fromJust, isJust)
import Data.List (sort)
import Test.IOSpec hiding (Data,putStrLn)
import Data.Dynamic
-- An implementation of channels using MVars. Simon Peyton Jones's
-- paper "Tackling the Awkward Squad" explains this implementation
-- of queues in a bit more detail.
data Data = Cell Int (MVar Data) deriving Typeable
type Channel = (MVar (MVar Data), MVar (MVar Data))
type IOConc a = IOSpec (MVarS :+: ForkS) a
newChan :: IOConc Channel
newChan = do read <- newEmptyMVar
write <- newEmptyMVar
hole <- newEmptyMVar
putMVar read hole
putMVar write hole
return (read,write)
putChan :: Channel -> Int -> IOConc ()
putChan (_,write) val =
do newHole <- newEmptyMVar
oldHole <- takeMVar write
putMVar write newHole
putMVar oldHole (Cell val newHole)
getChan :: Channel -> IOConc Int
getChan (read,write) =
do headVar <- takeMVar read
Cell val newHead <- takeMVar headVar
putMVar read newHead
return val
-- We can now check that data is never lost of duplicated. We fork
-- off n threads that write an integer to a channel, together with n
-- threads that read from the channel and record the read value in
-- an MVar. The main thread waits till all the threads have
-- successfully read a value. We can then check that the data
-- written to the channel is the same as the data read from it.
reader :: Channel -> MVar [Int] -> IOConc ()
reader channel var = do x <- getChan channel
xs <- takeMVar var
putMVar var (x:xs)
writer :: Channel -> Int -> IOConc ()
writer channel i = putChan channel i
chanTest :: [Int] -> IOConc [Int]
chanTest ints = do
ch <- newChan
result <- newEmptyMVar
putMVar result []
forM ints (\i -> forkIO (writer ch i))
replicateM (length ints) (forkIO (reader ch result))
wait result ints
wait :: MVar [Int] -> [Int] -> IOConc [Int]
wait var xs = do
res <- takeMVar var
if length res == length xs
then return res
else putMVar var res >> wait var xs
-- When do we consider two Effects equal? In this case, we want the
-- same final result, and no other visible effects.
(===) :: Eq a => Effect a -> Effect a -> Bool
Done x === Done y = x == y
_ === _ = False
-- To actually run concurrent programs, we must choose the scheduler
-- with which to run. At the moment, IOSpec provides a simple
-- round-robin scheduler; alternatively we can write our own
-- scheduler using "streamSched" that takes a stream of integers to
-- a scheduler.
-- Using QuickCheck to generate a random stream, we can use the
-- streamSched to implement a random scheduler -- thereby testing as
-- many interleavings as possible.
chanProp :: NonEmptyList Int -> Scheduler -> Bool
chanProp (NonEmpty ints) sched =
fmap sort (evalIOSpec (chanTest ints) sched)
=== Done (sort ints)
main = do putStrLn "Testing channels..."
quickCheck chanProp
|
