2cc9f552bdccec8ce747e102f36bd7d135dde8ba
[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 -- $Id: QSem.hs,v 1.2 2001/07/04 11:30:52 simonmar Exp $
12 --
13 -- General semaphores
14 --
15 -----------------------------------------------------------------------------
16
17 module Control.Concurrent.QSem
18 ( QSem, -- abstract
19 newQSem, -- :: Int -> IO QSem
20 waitQSem, -- :: QSem -> IO ()
21 signalQSem -- :: QSem -> IO ()
22 ) where
23
24 import Prelude
25 import Control.Concurrent.MVar
26
27 -- General semaphores are also implemented readily in terms of shared
28 -- @MVar@s, only have to catch the case when the semaphore is tried
29 -- waited on when it is empty (==0). Implement this in the same way as
30 -- shared variables are implemented - maintaining a list of @MVar@s
31 -- representing threads currently waiting. The counter is a shared
32 -- variable, ensuring the mutual exclusion on its access.
33
34 newtype QSem = QSem (MVar (Int, [MVar ()]))
35
36 newQSem :: Int -> IO QSem
37 newQSem init = do
38 sem <- newMVar (init,[])
39 return (QSem sem)
40
41 waitQSem :: QSem -> IO ()
42 waitQSem (QSem sem) = do
43 (avail,blocked) <- takeMVar sem -- gain ex. access
44 if avail > 0 then
45 putMVar sem (avail-1,[])
46 else do
47 block <- newEmptyMVar
48 {-
49 Stuff the reader at the back of the queue,
50 so as to preserve waiting order. A signalling
51 process then only have to pick the MVar at the
52 front of the blocked list.
53
54 The version of waitQSem given in the paper could
55 lead to starvation.
56 -}
57 putMVar sem (0, blocked++[block])
58 takeMVar block
59
60 signalQSem :: QSem -> IO ()
61 signalQSem (QSem sem) = do
62 (avail,blocked) <- takeMVar sem
63 case blocked of
64 [] -> putMVar sem (avail+1,[])
65
66 (block:blocked') -> do
67 putMVar sem (0,blocked')
68 putMVar block ()