1 -----------------------------------------------------------------------------
3 -- Module : Control.Concurrent.QSem
4 -- Copyright : (c) The University of Glasgow 2001
5 -- License : BSD-style (see the file libraries/base/LICENSE)
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable (concurrency)
11 -- Simple quantity semaphores.
13 -----------------------------------------------------------------------------
15 module Control.Concurrent.QSem
16 ( -- * Simple Quantity Semaphores
18 newQSem, -- :: Int -> IO QSem
19 waitQSem, -- :: QSem -> IO ()
20 signalQSem -- :: QSem -> IO ()
24 import Control.Concurrent.MVar
25 import Control.Exception ( block )
30 -- General semaphores are also implemented readily in terms of shared
31 -- @MVar@s, only have to catch the case when the semaphore is tried
32 -- waited on when it is empty (==0). Implement this in the same way as
33 -- shared variables are implemented - maintaining a list of @MVar@s
34 -- representing threads currently waiting. The counter is a shared
35 -- variable, ensuring the mutual exclusion on its access.
37 -- |A 'QSem' is a simple quantity semaphore, in which the available
38 -- \"quantity\" is always dealt with in units of one.
39 newtype QSem = QSem (MVar (Int, [MVar ()]))
41 INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
43 -- |Build a new 'QSem' with a supplied initial quantity.
44 -- The initial quantity must be at least 0.
45 newQSem :: Int -> IO QSem
48 then fail "newQSem: Initial quantity must be non-negative"
49 else do sem <- newMVar (initial, [])
52 -- |Wait for a unit to become available
53 waitQSem :: QSem -> IO ()
54 waitQSem (QSem sem) = block $ do
55 (avail,blocked) <- takeMVar sem -- gain ex. access
58 in avail' `seq` putMVar sem (avail',[])
62 Stuff the reader at the back of the queue,
63 so as to preserve waiting order. A signalling
64 process then only have to pick the MVar at the
65 front of the blocked list.
67 The version of waitQSem given in the paper could
70 putMVar sem (0, blocked++[b])
73 -- |Signal that a unit of the 'QSem' is available
74 signalQSem :: QSem -> IO ()
75 signalQSem (QSem sem) = block $ do
76 (avail,blocked) <- takeMVar sem
78 [] -> let avail' = avail+1
79 in avail' `seq` putMVar sem (avail',blocked)
82 putMVar sem (0,blocked')