{-# 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
(MS i -> MS i -> Bool) -> (MS i -> MS i -> Bool) -> Eq (MS i)
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
(MSemN i -> MSemN i -> Bool)
-> (MSemN i -> MSemN i -> Bool) -> Eq (MSemN i)
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 <- MS i -> IO (MVar (MS i))
forall a. a -> IO (MVar a)
newMVar (MS i -> IO (MVar (MS i))) -> MS i -> IO (MVar (MS i))
forall a b. (a -> b) -> a -> b
$! (MS :: forall i. i -> Maybe i -> MS i
MS { avail :: i
avail = i
initial
, headWants :: Maybe i
headWants = Maybe i
forall a. Maybe a
Nothing })
MVar ()
newQueueWait <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
MVar i
newHeadWait <- IO (MVar i)
forall a. IO (MVar a)
newEmptyMVar
MSemN i -> IO (MSemN i)
forall (m :: * -> *) a. Monad m => a -> m a
return (MSemN :: forall i. MVar (MS i) -> MVar () -> MVar i -> MSemN i
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 = i -> (IO a -> IO a) -> IO a -> IO a
seq i
wanted ((IO a -> IO a) -> IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (MSemN i -> i -> IO ()
forall i. Integral i => MSemN i -> i -> IO ()
wait MSemN i
m i
wanted) (IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MSemN i -> i -> IO ()
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 = IO (i, b) -> ((i, b) -> IO ()) -> ((i, b) -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (MSemN i -> (i -> (i, b)) -> IO (i, b)
forall i b. Integral i => MSemN i -> (i -> (i, b)) -> IO (i, b)
waitF MSemN i
m i -> (i, b)
f) (\(i
wanted,b
_) -> IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MSemN i -> i -> IO ()
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 = i -> IO () -> IO ()
seq i
wanted (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ((i, ()) -> ()) -> IO (i, ()) -> IO ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (i, ()) -> ()
forall a b. (a, b) -> b
snd (IO (i, ()) -> IO ()) -> IO (i, ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MSemN i -> (i -> (i, ())) -> IO (i, ())
forall i b. Integral i => MSemN i -> (i -> (i, b)) -> IO (i, b)
waitF MSemN i
m ((i, ()) -> i -> (i, ())
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 = (i -> (i, b)) -> IO (i, b) -> IO (i, b)
seq i -> (i, b)
f (IO (i, b) -> IO (i, b)) -> IO (i, b) -> IO (i, b)
forall a b. (a -> b) -> a -> b
$ IO (i, b) -> IO (i, b)
forall a. IO a -> IO a
mask_ (IO (i, b) -> IO (i, b))
-> ((() -> IO (i, b)) -> IO (i, b))
-> (() -> IO (i, b))
-> IO (i, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> (() -> IO (i, b)) -> IO (i, b)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (MSemN i -> MVar ()
forall i. MSemN i -> MVar ()
queueWait MSemN i
m) ((() -> IO (i, b)) -> IO (i, b)) -> (() -> IO (i, b)) -> IO (i, b)
forall a b. (a -> b) -> a -> b
$ \ () -> do
((i, b)
out,Bool
mustWait) <- MVar (MS i)
-> (MS i -> IO (MS i, ((i, b), Bool))) -> IO ((i, b), Bool)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (MSemN i -> MVar (MS i)
forall i. MSemN i -> MVar (MS i)
quantityStore MSemN i
m) ((MS i -> IO (MS i, ((i, b), Bool))) -> IO ((i, b), Bool))
-> (MS i -> IO (MS i, ((i, b), Bool))) -> IO ((i, b), Bool)
forall a b. (a -> b) -> a -> b
$ \ MS i
ms -> do
i
recovered <- (Maybe i -> i) -> IO (Maybe i) -> IO i
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (i -> Maybe i -> i
forall a. a -> Maybe a -> a
fromMaybe i
0) (MVar i -> IO (Maybe i)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (MSemN i -> MVar i
forall i. MSemN i -> MVar i
headWait MSemN i
m))
let total :: i
total = MS i -> i
forall i. MS i -> i
avail MS i
ms i -> i -> i
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 i -> i -> Bool
forall a. Ord a => a -> a -> Bool
<= i
total
then do
MS i
ms' <- MS i -> IO (MS i)
forall a. a -> IO a
evaluate MS :: forall i. i -> Maybe i -> MS i
MS { avail :: i
avail = i
total i -> i -> i
forall a. Num a => a -> a -> a
- i
wantedVal, headWants :: Maybe i
headWants = Maybe i
forall a. Maybe a
Nothing }
(MS i, ((i, b), Bool)) -> IO (MS i, ((i, b), Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return (MS i
ms', ((i, b)
outVal,Bool
False))
else do
MS i
ms' <- MS i -> IO (MS i)
forall a. a -> IO a
evaluate MS :: forall i. i -> Maybe i -> MS i
MS { avail :: i
avail = i
total, headWants :: Maybe i
headWants = i -> Maybe i
forall a. a -> Maybe a
Just i
wantedVal }
(MS i, ((i, b), Bool)) -> IO (MS i, ((i, b), Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return (MS i
ms', ((i, b)
outVal,Bool
True))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mustWait (IO i -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar i -> IO i
forall a. MVar a -> IO a
takeMVar (MSemN i -> MVar i
forall i. MSemN i -> MVar i
headWait MSemN i
m)))
(i, b) -> IO (i, b)
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 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
signal MSemN i
m i
size = ((i, ()) -> ()) -> IO (i, ()) -> IO ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (i, ()) -> ()
forall a b. (a, b) -> b
snd (IO (i, ()) -> IO ()) -> IO (i, ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MSemN i -> (i -> (i, ())) -> IO (i, ())
forall i b. Integral i => MSemN i -> (i -> (i, b)) -> IO (i, b)
signalF MSemN i
m ((i, ()) -> i -> (i, ())
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 = (i -> (i, b)) -> IO (i, b) -> IO (i, b)
seq i -> (i, b)
f (IO (i, b) -> IO (i, b)) -> IO (i, b) -> IO (i, b)
forall a b. (a -> b) -> a -> b
$ IO (i, b) -> IO (i, b)
forall a. IO a -> IO a
mask_ (IO (i, b) -> IO (i, b))
-> ((MS i -> IO (MS i, (i, b))) -> IO (i, b))
-> (MS i -> IO (MS i, (i, b)))
-> IO (i, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (MS i) -> (MS i -> IO (MS i, (i, b))) -> IO (i, b)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (MSemN i -> MVar (MS i)
forall i. MSemN i -> MVar (MS i)
quantityStore MSemN i
m) ((MS i -> IO (MS i, (i, b))) -> IO (i, b))
-> (MS i -> IO (MS i, (i, b))) -> IO (i, b)
forall a b. (a -> b) -> a -> b
$ \ MS i
ms -> do
let out :: (i, b)
out@(i
size,b
_) = i -> (i, b)
f (MS i -> i
forall i. MS i -> i
avail MS i
ms)
MS i
ms' <- case MS i -> Maybe i
forall i. MS i -> Maybe i
headWants MS i
ms of
Maybe i
Nothing -> MS i -> IO (MS i)
forall a. a -> IO a
evaluate MS i
ms { avail :: i
avail = MS i -> i
forall i. MS i -> i
avail MS i
ms i -> i -> i
forall a. Num a => a -> a -> a
+ i
size }
Just i
wantedVal -> do
let total :: i
total = MS i -> i
forall i. MS i -> i
avail MS i
ms i -> i -> i
forall a. Num a => a -> a -> a
+ i
size
if i
wantedVal i -> i -> Bool
forall a. Ord a => a -> a -> Bool
<= i
total
then do
Bool
_didPlace <- MVar i -> i -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar (MSemN i -> MVar i
forall i. MSemN i -> MVar i
headWait MSemN i
m) i
wantedVal
MS i -> IO (MS i)
forall a. a -> IO a
evaluate MS :: forall i. i -> Maybe i -> MS i
MS { avail :: i
avail = i
total i -> i -> i
forall a. Num a => a -> a -> a
- i
wantedVal, headWants :: Maybe i
headWants = Maybe i
forall a. Maybe a
Nothing }
else do
MS i -> IO (MS i)
forall a. a -> IO a
evaluate MS i
ms { avail :: i
avail = i
total }
(MS i, (i, b)) -> IO (MS i, (i, b))
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 = MVar (MS i) -> (MS i -> IO i) -> IO i
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (MSemN i -> MVar (MS i)
forall i. MSemN i -> MVar (MS i)
quantityStore MSemN i
m) (i -> IO i
forall (m :: * -> *) a. Monad m => a -> m a
return (i -> IO i) -> (MS i -> i) -> MS i -> IO i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MS i -> i
forall i. MS i -> i
avail)