{-# LANGUAGE DeriveDataTypeable #-}
module Control.Concurrent.MSemN2
(MSemN
,new
,with
,wait
,signal
,withF
,waitF
,signalF
,peekAvail
) where
import Prelude( Integral,Eq,IO,Int,Integer,Maybe(Just,Nothing),Num((+),(-)),Bool(False,True)
, return,const,fmap,snd,seq
, (.),(<=),($),($!) )
import Control.Concurrent.MVar( MVar
, withMVar,modifyMVar,newMVar
, newEmptyMVar,tryPutMVar,takeMVar,tryTakeMVar )
import Control.Exception(bracket,bracket_,uninterruptibleMask_,evaluate,mask_)
import Control.Monad(when,void)
import Data.Maybe(fromMaybe)
import Data.Typeable(Typeable)
import Data.Word(Word)
data MS i = MS { forall i. MS i -> i
avail :: !i
, forall i. MS i -> Maybe i
headWants :: !(Maybe i)
}
deriving (MS i -> MS i -> Bool
forall i. Eq i => MS i -> MS i -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MS i -> MS i -> Bool
$c/= :: forall i. Eq i => MS i -> MS i -> Bool
== :: MS i -> MS i -> Bool
$c== :: forall i. Eq i => MS i -> MS i -> Bool
Eq,Typeable)
data MSemN i = MSemN { forall i. MSemN i -> MVar (MS i)
quantityStore :: !(MVar (MS i))
, forall i. MSemN i -> MVar ()
queueWait :: !(MVar ())
, forall i. MSemN i -> MVar i
headWait :: !(MVar i)
}
deriving (MSemN i -> MSemN i -> Bool
forall i. MSemN i -> MSemN i -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MSemN i -> MSemN i -> Bool
$c/= :: forall i. MSemN i -> MSemN i -> Bool
== :: MSemN i -> MSemN i -> Bool
$c== :: forall i. MSemN i -> MSemN i -> Bool
Eq,Typeable)
new :: Integral i => i -> IO (MSemN i)
{-# SPECIALIZE new :: Int -> IO (MSemN Int) #-}
{-# SPECIALIZE new :: Word -> IO (MSemN Word) #-}
{-# SPECIALIZE new :: Integer -> IO (MSemN Integer) #-}
new :: forall i. Integral i => i -> IO (MSemN i)
new i
initial = do
MVar (MS i)
newMS <- forall a. a -> IO (MVar a)
newMVar forall a b. (a -> b) -> a -> b
$! (MS { avail :: i
avail = i
initial
, headWants :: Maybe i
headWants = forall a. Maybe a
Nothing })
MVar ()
newQueueWait <- forall a. a -> IO (MVar a)
newMVar ()
MVar i
newHeadWait <- forall a. IO (MVar a)
newEmptyMVar
forall (m :: * -> *) a. Monad m => a -> m a
return (MSemN { quantityStore :: MVar (MS i)
quantityStore = MVar (MS i)
newMS
, queueWait :: MVar ()
queueWait = MVar ()
newQueueWait
, headWait :: MVar i
headWait = MVar i
newHeadWait })
with :: Integral i => MSemN i -> i -> IO a -> IO a
{-# SPECIALIZE with :: MSemN Int -> Int -> IO a -> IO a #-}
{-# SPECIALIZE with :: MSemN Word -> Word -> IO a -> IO a #-}
{-# SPECIALIZE with :: MSemN Integer -> Integer -> IO a -> IO a #-}
with :: forall i a. Integral i => MSemN i -> i -> IO a -> IO a
with MSemN i
m i
wanted = seq :: forall a b. a -> b -> b
seq i
wanted forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall i. Integral i => MSemN i -> i -> IO ()
wait MSemN i
m i
wanted) (forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ forall i. Integral i => MSemN i -> i -> IO ()
signal MSemN i
m i
wanted)
withF :: Integral i
=> MSemN i
-> (i -> (i,b))
-> ((i,b) -> IO a)
-> IO a
{-# SPECIALIZE withF :: MSemN Int -> (Int -> (Int,b)) -> ((Int,b) -> IO a) -> IO a #-}
{-# SPECIALIZE withF :: MSemN Word -> (Word -> (Word,b)) -> ((Word,b) -> IO a) -> IO a #-}
{-# SPECIALIZE withF :: MSemN Integer -> (Integer -> (Integer,b)) -> ((Integer,b) -> IO a) -> IO a #-}
withF :: forall i b a.
Integral i =>
MSemN i -> (i -> (i, b)) -> ((i, b) -> IO a) -> IO a
withF MSemN i
m i -> (i, b)
f = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall i b. Integral i => MSemN i -> (i -> (i, b)) -> IO (i, b)
waitF MSemN i
m i -> (i, b)
f) (\(i
wanted,b
_) -> forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ forall i. Integral i => MSemN i -> i -> IO ()
signal MSemN i
m i
wanted)
wait :: Integral i => MSemN i -> i -> IO ()
{-# SPECIALIZE wait :: MSemN Int -> Int -> IO () #-}
{-# SPECIALIZE wait :: MSemN Word -> Word -> IO () #-}
{-# SPECIALIZE wait :: MSemN Integer -> Integer -> IO () #-}
wait :: forall i. Integral i => MSemN i -> i -> IO ()
wait MSemN i
m i
wanted = seq :: forall a b. a -> b -> b
seq i
wanted forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall i b. Integral i => MSemN i -> (i -> (i, b)) -> IO (i, b)
waitF MSemN i
m (forall a b. a -> b -> a
const (i
wanted,()))
waitF :: Integral i => MSemN i -> (i -> (i,b)) -> IO (i,b)
{-# SPECIALIZE waitF :: MSemN Int -> (Int -> (Int,b)) -> IO (Int,b) #-}
{-# SPECIALIZE waitF :: MSemN Word -> (Word -> (Word,b)) -> IO (Word,b) #-}
{-# SPECIALIZE waitF :: MSemN Integer -> (Integer -> (Integer,b)) -> IO (Integer,b) #-}
waitF :: forall i b. Integral i => MSemN i -> (i -> (i, b)) -> IO (i, b)
waitF MSemN i
m i -> (i, b)
f = seq :: forall a b. a -> b -> b
seq i -> (i, b)
f forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (forall i. MSemN i -> MVar ()
queueWait MSemN i
m) forall a b. (a -> b) -> a -> b
$ \ () -> do
((i, b)
out,Bool
mustWait) <- forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (forall i. MSemN i -> MVar (MS i)
quantityStore MSemN i
m) forall a b. (a -> b) -> a -> b
$ \ MS i
ms -> do
i
recovered <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe i
0) (forall a. MVar a -> IO (Maybe a)
tryTakeMVar (forall i. MSemN i -> MVar i
headWait MSemN i
m))
let total :: i
total = forall i. MS i -> i
avail MS i
ms forall a. Num a => a -> a -> a
+ i
recovered
outVal :: (i, b)
outVal@(i
wantedVal,b
_) = i -> (i, b)
f i
total
if i
wantedVal forall a. Ord a => a -> a -> Bool
<= i
total
then do
MS i
ms' <- forall a. a -> IO a
evaluate MS { avail :: i
avail = i
total forall a. Num a => a -> a -> a
- i
wantedVal, headWants :: Maybe i
headWants = forall a. Maybe a
Nothing }
forall (m :: * -> *) a. Monad m => a -> m a
return (MS i
ms', ((i, b)
outVal,Bool
False))
else do
MS i
ms' <- forall a. a -> IO a
evaluate MS { avail :: i
avail = i
total, headWants :: Maybe i
headWants = forall a. a -> Maybe a
Just i
wantedVal }
forall (m :: * -> *) a. Monad m => a -> m a
return (MS i
ms', ((i, b)
outVal,Bool
True))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mustWait (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. MVar a -> IO a
takeMVar (forall i. MSemN i -> MVar i
headWait MSemN i
m)))
forall (m :: * -> *) a. Monad m => a -> m a
return (i, b)
out
signal :: Integral i => MSemN i -> i -> IO ()
{-# SPECIALIZE signal :: MSemN Int -> Int -> IO () #-}
{-# SPECIALIZE signal :: MSemN Word -> Word -> IO () #-}
{-# SPECIALIZE signal :: MSemN Integer -> Integer -> IO () #-}
signal :: forall i. Integral i => MSemN i -> i -> IO ()
signal MSemN i
_ i
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
signal MSemN i
m i
size = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall i b. Integral i => MSemN i -> (i -> (i, b)) -> IO (i, b)
signalF MSemN i
m (forall a b. a -> b -> a
const (i
size,()))
signalF :: Integral i
=> MSemN i
-> (i -> (i,b))
-> IO (i,b)
{-# SPECIALIZE signalF :: MSemN Int -> (Int -> (Int,b)) -> IO (Int,b) #-}
{-# SPECIALIZE signalF :: MSemN Word -> (Word -> (Word,b)) -> IO (Word,b) #-}
{-# SPECIALIZE signalF :: MSemN Integer -> (Integer -> (Integer,b)) -> IO (Integer,b) #-}
signalF :: forall i b. Integral i => MSemN i -> (i -> (i, b)) -> IO (i, b)
signalF MSemN i
m i -> (i, b)
f = seq :: forall a b. a -> b -> b
seq i -> (i, b)
f forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (forall i. MSemN i -> MVar (MS i)
quantityStore MSemN i
m) forall a b. (a -> b) -> a -> b
$ \ MS i
ms -> do
let out :: (i, b)
out@(i
size,b
_) = i -> (i, b)
f (forall i. MS i -> i
avail MS i
ms)
MS i
ms' <- case forall i. MS i -> Maybe i
headWants MS i
ms of
Maybe i
Nothing -> forall a. a -> IO a
evaluate MS i
ms { avail :: i
avail = forall i. MS i -> i
avail MS i
ms forall a. Num a => a -> a -> a
+ i
size }
Just i
wantedVal -> do
let total :: i
total = forall i. MS i -> i
avail MS i
ms forall a. Num a => a -> a -> a
+ i
size
if i
wantedVal forall a. Ord a => a -> a -> Bool
<= i
total
then do
Bool
_didPlace <- forall a. MVar a -> a -> IO Bool
tryPutMVar (forall i. MSemN i -> MVar i
headWait MSemN i
m) i
wantedVal
forall a. a -> IO a
evaluate MS { avail :: i
avail = i
total forall a. Num a => a -> a -> a
- i
wantedVal, headWants :: Maybe i
headWants = forall a. Maybe a
Nothing }
else do
forall a. a -> IO a
evaluate MS i
ms { avail :: i
avail = i
total }
forall (m :: * -> *) a. Monad m => a -> m a
return (MS i
ms',(i, b)
out)
peekAvail :: Integral i => MSemN i -> IO i
{-# SPECIALIZE peekAvail :: MSemN Int -> IO Int #-}
{-# SPECIALIZE peekAvail :: MSemN Word -> IO Word #-}
{-# SPECIALIZE peekAvail :: MSemN Integer -> IO Integer #-}
peekAvail :: forall i. Integral i => MSemN i -> IO i
peekAvail MSemN i
m = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (forall i. MSemN i -> MVar (MS i)
quantityStore MSemN i
m) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. MS i -> i
avail)