----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TSem -- Copyright : (c) The University of Glasgow 2012 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM) -- -- 'TSem': transactional semaphores. -- -- @since 2.4.2 ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} module Control.Concurrent.STM.TSem ( TSem , newTSem , waitTSem , signalTSem , signalTSemN ) where import Control.Concurrent.STM import Control.Monad import Data.Typeable import Numeric.Natural -- | 'TSem' is a transactional semaphore. It holds a certain number -- of units, and units may be acquired or released by 'waitTSem' and -- 'signalTSem' respectively. When the 'TSem' is empty, 'waitTSem' -- blocks. -- -- Note that 'TSem' has no concept of fairness, and there is no -- guarantee that threads blocked in `waitTSem` will be unblocked in -- the same order; in fact they will all be unblocked at the same time -- and will fight over the 'TSem'. Hence 'TSem' is not suitable if -- you expect there to be a high number of threads contending for the -- resource. However, like other STM abstractions, 'TSem' is -- composable. -- -- @since 2.4.2 newtype TSem = TSem (TVar Integer) deriving (TSem -> TSem -> Bool (TSem -> TSem -> Bool) -> (TSem -> TSem -> Bool) -> Eq TSem forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: TSem -> TSem -> Bool == :: TSem -> TSem -> Bool $c/= :: TSem -> TSem -> Bool /= :: TSem -> TSem -> Bool Eq, Typeable) -- | Construct new 'TSem' with an initial counter value. -- -- A positive initial counter value denotes availability of -- units 'waitTSem' can acquire. -- -- The initial counter value can be negative which denotes a resource -- \"debt\" that requires a respective amount of 'signalTSem' -- operations to counter-balance. -- -- @since 2.4.2 newTSem :: Integer -> STM TSem newTSem :: Integer -> STM TSem newTSem Integer i = (TVar Integer -> TSem) -> STM (TVar Integer) -> STM TSem forall a b. (a -> b) -> STM a -> STM b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap TVar Integer -> TSem TSem (Integer -> STM (TVar Integer) forall a. a -> STM (TVar a) newTVar (Integer -> STM (TVar Integer)) -> Integer -> STM (TVar Integer) forall a b. (a -> b) -> a -> b $! Integer i) -- NOTE: we can't expose a good `TSem -> STM Int' operation as blocked -- 'waitTSem' aren't reliably reflected in a negative counter value. -- | Wait on 'TSem' (aka __P__ operation). -- -- This operation acquires a unit from the semaphore (i.e. decreases -- the internal counter) and blocks (via 'retry') if no units are -- available (i.e. if the counter is /not/ positive). -- -- @since 2.4.2 waitTSem :: TSem -> STM () waitTSem :: TSem -> STM () waitTSem (TSem TVar Integer t) = do Integer i <- TVar Integer -> STM Integer forall a. TVar a -> STM a readTVar TVar Integer t Bool -> STM () -> STM () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Integer i Integer -> Integer -> Bool forall a. Ord a => a -> a -> Bool <= Integer 0) STM () forall a. STM a retry TVar Integer -> Integer -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Integer t (Integer -> STM ()) -> Integer -> STM () forall a b. (a -> b) -> a -> b $! (Integer iInteger -> Integer -> Integer forall a. Num a => a -> a -> a -Integer 1) -- Alternatively, the implementation could block (via 'retry') when -- the next increment would overflow, i.e. testing for 'maxBound' -- | Signal a 'TSem' (aka __V__ operation). -- -- This operation adds\/releases a unit back to the semaphore -- (i.e. increments the internal counter). -- -- @since 2.4.2 signalTSem :: TSem -> STM () signalTSem :: TSem -> STM () signalTSem (TSem TVar Integer t) = do Integer i <- TVar Integer -> STM Integer forall a. TVar a -> STM a readTVar TVar Integer t TVar Integer -> Integer -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Integer t (Integer -> STM ()) -> Integer -> STM () forall a b. (a -> b) -> a -> b $! Integer iInteger -> Integer -> Integer forall a. Num a => a -> a -> a +Integer 1 -- | Multi-signal a 'TSem' -- -- This operation adds\/releases multiple units back to the semaphore -- (i.e. increments the internal counter). -- -- > signalTSem == signalTSemN 1 -- -- @since 2.4.5 signalTSemN :: Natural -> TSem -> STM () signalTSemN :: Natural -> TSem -> STM () signalTSemN Natural 0 TSem _ = () -> STM () forall a. a -> STM a forall (m :: * -> *) a. Monad m => a -> m a return () signalTSemN Natural 1 TSem s = TSem -> STM () signalTSem TSem s signalTSemN Natural n (TSem TVar Integer t) = do Integer i <- TVar Integer -> STM Integer forall a. TVar a -> STM a readTVar TVar Integer t TVar Integer -> Integer -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Integer t (Integer -> STM ()) -> Integer -> STM () forall a b. (a -> b) -> a -> b $! Integer iInteger -> Integer -> Integer forall a. Num a => a -> a -> a +(Natural -> Integer forall a. Integral a => a -> Integer toInteger Natural n)