d439a8ac577d2ee9da4f5bc81bf1c42da5efddff
[packages/base.git] / Control / Concurrent / QSem.hs
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module : Control.Concurrent.QSem
4 -- Copyright : (c) The University of Glasgow 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
6 --
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable
10 --
11 -- General semaphores
12 --
13 -----------------------------------------------------------------------------
14
15 module Control.Concurrent.QSem
16 ( QSem, -- abstract
17 newQSem, -- :: Int -> IO QSem
18 waitQSem, -- :: QSem -> IO ()
19 signalQSem -- :: QSem -> IO ()
20 ) where
21
22 import Prelude
23 import Control.Concurrent.MVar
24
25 -- General semaphores are also implemented readily in terms of shared
26 -- @MVar@s, only have to catch the case when the semaphore is tried
27 -- waited on when it is empty (==0). Implement this in the same way as
28 -- shared variables are implemented - maintaining a list of @MVar@s
29 -- representing threads currently waiting. The counter is a shared
30 -- variable, ensuring the mutual exclusion on its access.
31
32 newtype QSem = QSem (MVar (Int, [MVar ()]))
33
34 newQSem :: Int -> IO QSem
35 newQSem init = do
36 sem <- newMVar (init,[])
37 return (QSem sem)
38
39 waitQSem :: QSem -> IO ()
40 waitQSem (QSem sem) = do
41 (avail,blocked) <- takeMVar sem -- gain ex. access
42 if avail > 0 then
43 putMVar sem (avail-1,[])
44 else do
45 block <- newEmptyMVar
46 {-
47 Stuff the reader at the back of the queue,
48 so as to preserve waiting order. A signalling
49 process then only have to pick the MVar at the
50 front of the blocked list.
51
52 The version of waitQSem given in the paper could
53 lead to starvation.
54 -}
55 putMVar sem (0, blocked++[block])
56 takeMVar block
57
58 signalQSem :: QSem -> IO ()
59 signalQSem (QSem sem) = do
60 (avail,blocked) <- takeMVar sem
61 case blocked of
62 [] -> putMVar sem (avail+1,[])
63
64 (block:blocked') -> do
65 putMVar sem (0,blocked')
66 putMVar block ()