{-# LANGUAGE Safe #-}------------------------------------------------------------------------------- |-- Module : Control.Concurrent.QSemN-- Copyright : (c) The University of Glasgow 2001-- License : BSD-style (see the file libraries/base/LICENSE)-- -- Maintainer : libraries@haskell.org-- Stability : experimental-- Portability : non-portable (concurrency)---- Quantity semaphores in which each thread may wait for an arbitrary-- \"amount\".-------------------------------------------------------------------------------moduleControl.Concurrent.QSemN(-- * General Quantity SemaphoresQSemN ,-- abstractnewQSemN ,-- :: Int -> IO QSemNwaitQSemN ,-- :: QSemN -> Int -> IO ()signalQSemN -- :: QSemN -> Int -> IO ())whereimportControl.Concurrent.MVar (MVar ,newEmptyMVar ,takeMVar ,tryTakeMVar ,putMVar ,newMVar ,tryPutMVar ,isEmptyMVar )importControl.Exception importData.Maybe -- | 'QSemN' is a quantity semaphore in which the resource is acquired-- and released in units of one. It provides guaranteed FIFO ordering-- for satisfying blocked `waitQSemN` calls.---- The pattern---- > bracket_ (waitQSemN n) (signalQSemN n) (...)---- is safe; it never loses any of the resource.--newtypeQSemN =QSemN (MVar (Int,[(Int,MVar ())],[(Int,MVar ())]))-- The semaphore state (i, xs, ys):---- i is the current resource value---- (xs,ys) is the queue of blocked threads, where the queue is-- given by xs ++ reverse ys. We can enqueue new blocked threads-- by consing onto ys, and dequeue by removing from the head of xs.---- A blocked thread is represented by an empty (MVar ()). To unblock-- the thread, we put () into the MVar.---- A thread can dequeue itself by also putting () into the MVar, which-- it must do if it receives an exception while blocked in waitQSemN.-- This means that when unblocking a thread in signalQSemN we must-- first check whether the MVar is already full; the MVar lock on the-- semaphore itself resolves race conditions between signalQSemN and a-- thread attempting to dequeue itself.-- |Build a new 'QSemN' with a supplied initial quantity.-- The initial quantity must be at least 0.newQSemN ::Int->IOQSemN newQSemN :: Int -> IO QSemN
newQSemN initial :: Int
initial |Int
initial Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<0=String -> IO QSemN
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "newQSemN: Initial quantity must be non-negative"|Bool
otherwise =doMVar (Int, [(Int, MVar ())], [(Int, MVar ())])
sem <-(Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]))
forall a. a -> IO (MVar a)
newMVar (Int
initial ,[],[])QSemN -> IO QSemN
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]) -> QSemN
QSemN MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
sem )-- |Wait for the specified quantity to become availablewaitQSemN ::QSemN ->Int->IO()waitQSemN :: QSemN -> Int -> IO ()
waitQSemN (QSemN m :: MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m )sz :: Int
sz =IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do(i :: Int
i ,b1 :: [(Int, MVar ())]
b1 ,b2 :: [(Int, MVar ())]
b2 )<-MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m letz :: Int
z =Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz ifInt
z Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<0thendoMVar ()
b <-IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int
i ,[(Int, MVar ())]
b1 ,(Int
sz ,MVar ()
b )(Int, MVar ()) -> [(Int, MVar ())] -> [(Int, MVar ())]
forall a. a -> [a] -> [a]
:[(Int, MVar ())]
b2 )MVar () -> IO ()
wait MVar ()
b elsedoMVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int
z ,[(Int, MVar ())]
b1 ,[(Int, MVar ())]
b2 )() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()wherewait :: MVar () -> IO ()
wait b :: MVar ()
b =doMVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
b IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` (IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do-- Note [signal uninterruptible](i :: Int
i ,b1 :: [(Int, MVar ())]
b1 ,b2 :: [(Int, MVar ())]
b2 )<-MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m Maybe ()
r <-MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
b (Int, [(Int, MVar ())], [(Int, MVar ())])
r' <-ifMaybe () -> Bool
forall a. Maybe a -> Bool
isJust Maybe ()
r thenInt
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal Int
sz (Int
i ,[(Int, MVar ())]
b1 ,[(Int, MVar ())]
b2 )elsedoMVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
b ();(Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i ,[(Int, MVar ())]
b1 ,[(Int, MVar ())]
b2 )MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int, [(Int, MVar ())], [(Int, MVar ())])
r' )-- |Signal that a given quantity is now available from the 'QSemN'.signalQSemN ::QSemN ->Int->IO()signalQSemN :: QSemN -> Int -> IO ()
signalQSemN (QSemN m :: MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m )sz :: Int
sz =IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do(Int, [(Int, MVar ())], [(Int, MVar ())])
r <-MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int, [(Int, MVar ())], [(Int, MVar ())])
r' <-Int
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal Int
sz (Int, [(Int, MVar ())], [(Int, MVar ())])
r MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int, [(Int, MVar ())], [(Int, MVar ())])
r' signal ::Int->(Int,[(Int,MVar ())],[(Int,MVar ())])->IO(Int,[(Int,MVar ())],[(Int,MVar ())])signal :: Int
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal sz0 :: Int
sz0 (i :: Int
i ,a1 :: [(Int, MVar ())]
a1 ,a2 :: [(Int, MVar ())]
a2 )=Int
-> [(Int, MVar ())]
-> [(Int, MVar ())]
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a.
(Num a, Ord a) =>
a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop (Int
sz0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i )[(Int, MVar ())]
a1 [(Int, MVar ())]
a2 whereloop :: a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop 0bs :: [(a, MVar ())]
bs b2 :: [(a, MVar ())]
b2 =(a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (0,[(a, MVar ())]
bs ,[(a, MVar ())]
b2 )loop sz :: a
sz [][]=(a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
sz ,[],[])loop sz :: a
sz []b2 :: [(a, MVar ())]
b2 =a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz ([(a, MVar ())] -> [(a, MVar ())]
forall a. [a] -> [a]
reverse [(a, MVar ())]
b2 )[]loop sz :: a
sz ((j :: a
j ,b :: MVar ()
b ):bs :: [(a, MVar ())]
bs )b2 :: [(a, MVar ())]
b2 |a
j a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
sz =doBool
r <-MVar () -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar ()
b ifBool
r then(a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
sz ,(a
j ,MVar ()
b )(a, MVar ()) -> [(a, MVar ())] -> [(a, MVar ())]
forall a. a -> [a] -> [a]
:[(a, MVar ())]
bs ,[(a, MVar ())]
b2 )elsea
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz [(a, MVar ())]
bs [(a, MVar ())]
b2 |Bool
otherwise =doBool
r <-MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
b ()ifBool
r thena
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop (a
sz a -> a -> a
forall a. Num a => a -> a -> a
- a
j )[(a, MVar ())]
bs [(a, MVar ())]
b2 elsea
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz [(a, MVar ())]
bs [(a, MVar ())]
b2