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
110
111
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1995
%
\section[Semaphore]{Quantity semaphores}
General/quantity semaphores
\begin{code}
module Semaphore
(
{- abstract -}
QSem,
newQSem, -- :: Int -> IO QSem
waitQSem, -- :: QSem -> IO ()
signalQSem, -- :: QSem -> IO ()
{- abstract -}
QSemN,
newQSemN, -- :: Int -> IO QSemN
waitQSemN, -- :: QSemN -> Int -> IO ()
signalQSemN -- :: QSemN -> Int -> IO ()
) where
import PrelConc
\end{code}
General semaphores are also implemented readily in terms of shared
@MVar@s, only have to catch the case when the semaphore is tried
waited on when it is empty (==0). Implement this in the same way as
shared variables are implemented - maintaining a list of @MVar@s
representing threads currently waiting. The counter is a shared
variable, ensuring the mutual exclusion on its access.
\begin{code}
newtype QSem = QSem (MVar (Int, [MVar ()]))
newQSem :: Int -> IO QSem
newQSem init = do
sem <- newMVar (init,[])
return (QSem sem)
waitQSem :: QSem -> IO ()
waitQSem (QSem sem) = do
(avail,blocked) <- takeMVar sem -- gain ex. access
if avail > 0 then
putMVar sem (avail-1,[])
else do
block <- newEmptyMVar
{-
Stuff the reader at the back of the queue,
so as to preserve waiting order. A signalling
process then only have to pick the MVar at the
front of the blocked list.
The version of waitQSem given in the paper could
lead to starvation.
-}
putMVar sem (0, blocked++[block])
takeMVar block
signalQSem :: QSem -> IO ()
signalQSem (QSem sem) = do
(avail,blocked) <- takeMVar sem
case blocked of
[] -> putMVar sem (avail+1,[])
(block:blocked') -> do
putMVar sem (0,blocked')
putMVar block ()
\end{code}
\begin{code}
newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
newQSemN :: Int -> IO QSemN
newQSemN init = do
sem <- newMVar (init,[])
return (QSemN sem)
waitQSemN :: QSemN -> Int -> IO ()
waitQSemN (QSemN sem) sz = do
(avail,blocked) <- takeMVar sem -- gain ex. access
if (avail - sz) > 0 then
-- discharging 'sz' still leaves the semaphore
-- in an 'unblocked' state.
putMVar sem (avail-sz,[])
else do
block <- newEmptyMVar
putMVar sem (avail, blocked++[(sz,block)])
takeMVar block
signalQSemN :: QSemN -> Int -> IO ()
signalQSemN (QSemN sem) n = do
(avail,blocked) <- takeMVar sem
(avail',blocked') <- free (avail+n) blocked
putMVar sem (avail',blocked')
where
free avail [] = return (avail,[])
free avail ((req,block):blocked)
| avail >= req = do
putMVar block ()
free (avail-req) blocked
| otherwise = do
(avail',blocked') <- free avail blocked
return (avail',(req,block):blocked')
\end{code}
|
