2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
4 \section[Semaphore]{Quantity semaphores}
6 General/quantity semaphores
15 newQSem, --:: Int -> IO QSem
16 waitQSem, --:: QSem -> IO ()
17 signalQSem, --:: QSem -> IO ()
21 newQSemN, --:: Int -> IO QSemN
22 waitQSemN, --:: QSemN -> Int -> IO ()
23 signalQSemN --:: QSemN -> Int -> IO ()
28 import PreludePrimIO ( newEmptyMVar, newMVar, putMVar,
29 readMVar, takeMVar, _MVar
33 General semaphores are also implemented readily in terms of shared @MVar@s,
34 only have to catch the case when the semaphore is tried waited on
35 when it is empty (==0). Implement this in the same way as shared variables are
36 implemented - maintaining a list of @MVar@s representing threads currently
37 waiting. The counter is a shared variable, ensuring the mutual exclusion on its access.
41 data QSem = QSem (_MVar (Int, [_MVar ()]))
43 newQSem :: Int -> IO QSem
45 = newMVar (init,[]) >>= \ sem ->
48 waitQSem :: QSem -> IO ()
50 = takeMVar sem >>= \ (avail,blocked) -> -- gain ex. access
52 putMVar sem (avail-1,[]) >>
55 newEmptyMVar >>= \ block ->
57 Stuff the reader at the back of the queue,
58 so as to preserve waiting order. A signalling
59 process then only have to pick the MVar at the
60 front of the blocked list.
62 The version of waitQSem given in the paper could
65 putMVar sem (0, blocked++[block]) >>
66 takeMVar block >>= \ v ->
69 signalQSem :: QSem -> IO ()
71 = takeMVar sem >>= \ (avail,blocked) ->
73 [] -> putMVar sem (avail+1,[]) >>
76 putMVar sem (0,blocked') >>
85 = QSemN (_MVar (Int,[(Int,_MVar ())]))
87 newQSemN :: Int -> IO QSemN
89 = newMVar (init,[]) >>= \ sem ->
92 waitQSemN :: QSemN -> Int -> IO ()
93 waitQSemN (QSemN sem) sz
94 = takeMVar sem >>= \ (avail,blocked) -> -- gain ex. access
96 putMVar sem (avail-1,[]) >>
99 newEmptyMVar >>= \ block ->
100 putMVar sem (0, blocked++[(sz,block)]) >>
105 signalQSemN :: QSemN -> Int -> IO ()
106 signalQSemN (QSemN sem) n
107 = takeMVar sem >>= \ (avail,blocked) ->
108 free (avail+n) blocked >>= \ (avail',blocked') ->
109 putMVar sem (avail',blocked') >>
112 free avail [] = return (avail,[])
113 free avail ((req,block):blocked) =
116 free (avail-req) blocked
118 free avail blocked >>= \ (avail',blocked') ->
119 return (avail',(req,block):blocked')