2 #ifdef __GLASGOW_HASKELL__
3 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
6 -----------------------------------------------------------------------------
8 -- Module : Control.Concurrent.QSemN
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 -- Quantity semaphores in which each thread may wait for an arbitrary
19 -----------------------------------------------------------------------------
21 module Control.Concurrent.QSemN
22 ( -- * General Quantity Semaphores
24 newQSemN, -- :: Int -> IO QSemN
25 waitQSemN, -- :: QSemN -> Int -> IO ()
26 signalQSemN -- :: QSemN -> Int -> IO ()
31 import Control.Concurrent.MVar
32 import Control.Exception ( mask_ )
37 -- |A 'QSemN' is a quantity semaphore, in which the available
38 -- \"quantity\" may be signalled or waited for in arbitrary amounts.
39 newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())])) deriving Eq
41 INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")
43 -- |Build a new 'QSemN' with a supplied initial quantity.
44 -- The initial quantity must be at least 0.
45 newQSemN :: Int -> IO QSemN
48 then fail "newQSemN: Initial quantity must be non-negative"
49 else do sem <- newMVar (initial, [])
52 -- |Wait for the specified quantity to become available
53 waitQSemN :: QSemN -> Int -> IO ()
54 waitQSemN (QSemN sem) sz = mask_ $ do
55 (avail,blocked) <- takeMVar sem -- gain ex. access
56 let remaining = avail - sz
57 if remaining >= 0 then
58 -- discharging 'sz' still leaves the semaphore
59 -- in an 'unblocked' state.
60 putMVar sem (remaining,blocked)
63 putMVar sem (avail, blocked++[(sz,b)])
66 -- |Signal that a given quantity is now available from the 'QSemN'.
67 signalQSemN :: QSemN -> Int -> IO ()
68 signalQSemN (QSemN sem) n = mask_ $ do
69 (avail,blocked) <- takeMVar sem
70 (avail',blocked') <- free (avail+n) blocked
71 avail' `seq` putMVar sem (avail',blocked')
73 free avail [] = return (avail,[])
74 free avail ((req,b):blocked)
77 free (avail-req) blocked
79 (avail',blocked') <- free avail blocked
80 return (avail',(req,b):blocked')