{-# LANGUAGE Safe #-}{-# LANGUAGE BangPatterns #-}------------------------------------------------------------------------------- |-- Module : Control.Concurrent.QSem-- Copyright : (c) The University of Glasgow 2001-- License : BSD-style (see the file libraries/base/LICENSE)---- Maintainer : libraries@haskell.org-- Stability : stable-- Portability : non-portable (concurrency)---- Simple quantity semaphores.-------------------------------------------------------------------------------moduleControl.Concurrent.QSem (-- * Simple Quantity SemaphoresQSem ,-- abstractnewQSem ,-- :: Int -> IO QSemwaitQSem ,-- :: QSem -> IO ()signalQSem -- :: QSem -> IO ())whereimportPrelude importGHC.Internal.Control.Concurrent.MVar (MVar ,newEmptyMVar ,takeMVar ,tryTakeMVar ,putMVar ,newMVar ,tryPutMVar )importGHC.Internal.Control.Exception importGHC.Internal.Data.Maybe -- | 'QSem' is a quantity semaphore in which the resource is acquired-- and released in units of one. It provides guaranteed FIFO ordering-- for satisfying blocked `waitQSem` calls.---- The pattern---- > bracket_ waitQSem signalQSem (...)---- is safe; it never loses a unit of the resource.--newtypeQSem =QSem (MVar (Int ,[MVar ()],[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 waitQSem.-- This means that when unblocking a thread in signalQSem we must-- first check whether the MVar is already full; the MVar lock on the-- semaphore itself resolves race conditions between signalQSem and a-- thread attempting to dequeue itself.-- |Build a new 'QSem' with a supplied initial quantity.-- The initial quantity must be at least 0.newQSem ::Int ->IO QSem newQSem :: Int -> IO QSem
newQSem Int
initial |Int
initial Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0=String -> IO QSem
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newQSem: Initial quantity must be non-negative"|Bool
otherwise =dosem <-(Int, [MVar ()], [MVar ()])
-> IO (MVar (Int, [MVar ()], [MVar ()]))
forall a. a -> IO (MVar a)
newMVar (Int
initial ,[],[])return (QSem sem )-- |Wait for a unit to become available.waitQSem ::QSem ->IO ()waitQSem :: QSem -> IO ()
waitQSem (QSem MVar (Int, [MVar ()], [MVar ()])
m )=IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do(i ,b1 ,b2 )<-MVar (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. MVar a -> IO a
takeMVar MVar (Int, [MVar ()], [MVar ()])
m ifi == 0thendob <-newEmptyMVar putMVar m (i ,b1 ,b : b2 )wait b elsedolet!z =Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1putMVar m (z ,b1 ,b2 )return ()wherewait :: MVar () -> IO ()
wait MVar ()
b =MVar () -> 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 ,b1 ,b2 )<-MVar (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. MVar a -> IO a
takeMVar MVar (Int, [MVar ()], [MVar ()])
m r <-tryTakeMVar b r' <-ifisJust r thensignal (i ,b1 ,b2 )elsedoputMVar b ();return (i ,b1 ,b2 )putMVar m r' )-- |Signal that a unit of the 'QSem' is available.signalQSem ::QSem ->IO ()signalQSem :: QSem -> IO ()
signalQSem (QSem MVar (Int, [MVar ()], [MVar ()])
m )=IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do-- Note [signal uninterruptible]r <-MVar (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. MVar a -> IO a
takeMVar MVar (Int, [MVar ()], [MVar ()])
m r' <-signal r putMVar m r' -- Note [signal uninterruptible]-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- If we have---- bracket waitQSem signalQSem (...)---- and an exception arrives at the signalQSem, then we must not lose-- the resource. The signalQSem is masked by bracket, but taking-- the MVar might block, and so it would be interruptible. Hence we-- need an uninterruptibleMask here.---- This isn't ideal: during high contention, some threads won't be-- interruptible. The QSemSTM implementation has better behaviour-- here, but it performs much worse than this one in some-- benchmarks.signal ::(Int ,[MVar ()],[MVar ()])->IO (Int ,[MVar ()],[MVar ()])signal :: (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
signal (Int
i ,[MVar ()]
a1 ,[MVar ()]
a2 )=ifInt
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0then[MVar ()] -> [MVar ()] -> IO (Int, [MVar ()], [MVar ()])
forall {a}.
Num a =>
[MVar ()] -> [MVar ()] -> IO (a, [MVar ()], [MVar ()])
loop [MVar ()]
a1 [MVar ()]
a2 elselet!z :: Int
z =Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1in(Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
z ,[MVar ()]
a1 ,[MVar ()]
a2 )whereloop :: [MVar ()] -> [MVar ()] -> IO (a, [MVar ()], [MVar ()])
loop [][]=(a, [MVar ()], [MVar ()]) -> IO (a, [MVar ()], [MVar ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
1,[],[])loop [][MVar ()]
b2 =[MVar ()] -> [MVar ()] -> IO (a, [MVar ()], [MVar ()])
loop ([MVar ()] -> [MVar ()]
forall a. [a] -> [a]
reverse [MVar ()]
b2 )[]loop (MVar ()
b : [MVar ()]
bs )[MVar ()]
b2 =dor <-MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
b ()ifr thenreturn (0,bs ,b2 )elseloop bs b2