2 #ifdef __GLASGOW_HASKELL__
3 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
6 -----------------------------------------------------------------------------
8 -- Module : Control.Concurrent.QSem
9 -- Copyright : (c) The University of Glasgow 2001
10 -- License : BSD-style (see the file libraries/base/LICENSE)
12 -- Maintainer : libraries@haskell.org
13 -- Stability : experimental
14 -- Portability : non-portable (concurrency)
16 -- Simple quantity semaphores.
18 -----------------------------------------------------------------------------
20 module Control.Concurrent.QSem
21 ( -- * Simple Quantity Semaphores
23 newQSem, -- :: Int -> IO QSem
24 waitQSem, -- :: QSem -> IO ()
25 signalQSem -- :: QSem -> IO ()
29 import Control.Concurrent.MVar
30 import Control.Exception ( mask_ )
35 -- General semaphores are also implemented readily in terms of shared
36 -- @MVar@s, only have to catch the case when the semaphore is tried
37 -- waited on when it is empty (==0). Implement this in the same way as
38 -- shared variables are implemented - maintaining a list of @MVar@s
39 -- representing threads currently waiting. The counter is a shared
40 -- variable, ensuring the mutual exclusion on its access.
42 -- |A 'QSem' is a simple quantity semaphore, in which the available
43 -- \"quantity\" is always dealt with in units of one.
44 newtype QSem = QSem (MVar (Int, [MVar ()])) deriving Eq
46 INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
48 -- |Build a new 'QSem' with a supplied initial quantity.
49 -- The initial quantity must be at least 0.
50 newQSem :: Int -> IO QSem
53 then fail "newQSem: Initial quantity must be non-negative"
54 else do sem <- newMVar (initial, [])
57 -- |Wait for a unit to become available
58 waitQSem :: QSem -> IO ()
59 waitQSem (QSem sem) = mask_ $ do
60 (avail,blocked) <- takeMVar sem -- gain ex. access
63 in avail' `seq` putMVar sem (avail',[])
67 Stuff the reader at the back of the queue,
68 so as to preserve waiting order. A signalling
69 process then only have to pick the MVar at the
70 front of the blocked list.
72 The version of waitQSem given in the paper could
75 putMVar sem (0, blocked++[b])
78 -- |Signal that a unit of the 'QSem' is available
79 signalQSem :: QSem -> IO ()
80 signalQSem (QSem sem) = mask_ $ do
81 (avail,blocked) <- takeMVar sem
83 [] -> let avail' = avail+1
84 in avail' `seq` putMVar sem (avail',blocked)
87 putMVar sem (0,blocked')