module Util.VSem(
VSem,
newVSem,
synchronizeLocal,
synchronizeGlobal,
acquireLocal,
releaseLocal,
) where
import Control.Concurrent
import Control.Exception
import Util.Computation
import Util.Queue
data VSemState = VSemState {
VSemState -> Queue (MVar ())
queuedGlobals :: Queue (MVar ()),
VSemState -> [MVar ()]
queuedLocals :: [MVar ()],
VSemState -> Int
nLocalLocks :: Int
}
newtype VSem = VSem (MVar VSemState)
newVSem :: IO VSem
newVSem :: IO VSem
newVSem =
do
MVar VSemState
mVar <- VSemState -> IO (MVar VSemState)
forall a. a -> IO (MVar a)
newMVar (VSemState :: Queue (MVar ()) -> [MVar ()] -> Int -> VSemState
VSemState {
queuedGlobals :: Queue (MVar ())
queuedGlobals = Queue (MVar ())
forall a. Queue a
emptyQ,
queuedLocals :: [MVar ()]
queuedLocals = [],
nLocalLocks :: Int
nLocalLocks = Int
0
})
VSem -> IO VSem
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar VSemState -> VSem
VSem MVar VSemState
mVar)
synchronizeLocal :: VSem -> IO b -> IO b
synchronizeLocal :: VSem -> IO b -> IO b
synchronizeLocal VSem
vSem IO b
act =
do
VSem -> IO ()
acquireLocal VSem
vSem
IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
finally IO b
act (VSem -> IO ()
releaseLocal VSem
vSem)
synchronizeGlobal :: VSem -> IO b -> IO b
synchronizeGlobal :: VSem -> IO b -> IO b
synchronizeGlobal VSem
vSem IO b
act =
do
VSem -> IO ()
acquireGlobal VSem
vSem
IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
finally IO b
act (VSem -> IO ()
releaseGlobal VSem
vSem)
vSemAct :: VSem -> (VSemState -> IO (VSemState,b)) -> IO b
vSemAct :: VSem -> (VSemState -> IO (VSemState, b)) -> IO b
vSemAct (VSem MVar VSemState
mVar) VSemState -> IO (VSemState, b)
update =
MVar VSemState -> (VSemState -> IO (VSemState, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar VSemState
mVar VSemState -> IO (VSemState, b)
update
acquireLocal :: VSem -> IO ()
acquireLocal :: VSem -> IO ()
acquireLocal VSem
vSem =
do
IO ()
act <- VSem -> (VSemState -> IO (VSemState, IO ())) -> IO (IO ())
forall b. VSem -> (VSemState -> IO (VSemState, b)) -> IO b
vSemAct VSem
vSem (\ VSemState
vSemState ->
if VSemState -> Int
nLocalLocks VSemState
vSemState Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0
then
do
MVar ()
mVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
(VSemState, IO ()) -> IO (VSemState, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VSemState
vSemState {
queuedLocals :: [MVar ()]
queuedLocals = MVar ()
mVar MVar () -> [MVar ()] -> [MVar ()]
forall a. a -> [a] -> [a]
: VSemState -> [MVar ()]
queuedLocals VSemState
vSemState},
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mVar
)
else
(VSemState, IO ()) -> IO (VSemState, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VSemState
vSemState {
nLocalLocks :: Int
nLocalLocks = VSemState -> Int
nLocalLocks VSemState
vSemState Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1},
IO ()
forall (m :: * -> *). Monad m => m ()
done)
)
IO ()
act
releaseLocal :: VSem -> IO ()
releaseLocal :: VSem -> IO ()
releaseLocal VSem
vSem =
VSem -> (VSemState -> IO (VSemState, ())) -> IO ()
forall b. VSem -> (VSemState -> IO (VSemState, b)) -> IO b
vSemAct VSem
vSem (\ VSemState
vSemState ->
do
let
nLocalLocks0 :: Int
nLocalLocks0 = VSemState -> Int
nLocalLocks VSemState
vSemState
nLocalLocks1 :: Int
nLocalLocks1 = Int
nLocalLocks0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
case (Int
nLocalLocks1,Queue (MVar ()) -> Maybe (MVar (), Queue (MVar ()))
forall a. Queue a -> Maybe (a, Queue a)
removeQ (VSemState -> Queue (MVar ())
queuedGlobals VSemState
vSemState)) of
(Int
0,Just (MVar ()
mVar,Queue (MVar ())
queuedGlobals1)) ->
do
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mVar ()
(VSemState, ()) -> IO (VSemState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VSemState
vSemState {nLocalLocks :: Int
nLocalLocks = -Int
1,
queuedGlobals :: Queue (MVar ())
queuedGlobals = Queue (MVar ())
queuedGlobals1
},())
(Int, Maybe (MVar (), Queue (MVar ())))
_ -> (VSemState, ()) -> IO (VSemState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VSemState
vSemState {nLocalLocks :: Int
nLocalLocks = Int
nLocalLocks1},())
)
acquireGlobal :: VSem -> IO ()
acquireGlobal :: VSem -> IO ()
acquireGlobal VSem
vSem =
do
IO ()
act <- VSem -> (VSemState -> IO (VSemState, IO ())) -> IO (IO ())
forall b. VSem -> (VSemState -> IO (VSemState, b)) -> IO b
vSemAct VSem
vSem (\ VSemState
vSemState ->
do
let
nLocalLocks0 :: Int
nLocalLocks0 = VSemState -> Int
nLocalLocks VSemState
vSemState
if Int
nLocalLocks0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then
(VSemState, IO ()) -> IO (VSemState, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VSemState
vSemState {nLocalLocks :: Int
nLocalLocks = -Int
1},IO ()
forall (m :: * -> *). Monad m => m ()
done)
else
do
MVar ()
mVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
(VSemState, IO ()) -> IO (VSemState, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VSemState
vSemState {
queuedGlobals :: Queue (MVar ())
queuedGlobals
= Queue (MVar ()) -> MVar () -> Queue (MVar ())
forall a. Queue a -> a -> Queue a
insertQ (VSemState -> Queue (MVar ())
queuedGlobals VSemState
vSemState) MVar ()
mVar},
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mVar
)
)
IO ()
act
releaseGlobal :: VSem -> IO ()
releaseGlobal :: VSem -> IO ()
releaseGlobal VSem
vSem =
VSem -> (VSemState -> IO (VSemState, ())) -> IO ()
forall b. VSem -> (VSemState -> IO (VSemState, b)) -> IO b
vSemAct VSem
vSem (\ VSemState
vSemState ->
case (Queue (MVar ()) -> Maybe (MVar (), Queue (MVar ()))
forall a. Queue a -> Maybe (a, Queue a)
removeQ (VSemState -> Queue (MVar ())
queuedGlobals VSemState
vSemState),VSemState -> [MVar ()]
queuedLocals VSemState
vSemState) of
(Just (MVar ()
mVar,Queue (MVar ())
queuedGlobals1),[MVar ()]
_) ->
do
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mVar ()
(VSemState, ()) -> IO (VSemState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VSemState
vSemState {queuedGlobals :: Queue (MVar ())
queuedGlobals = Queue (MVar ())
queuedGlobals1},())
(Maybe (MVar (), Queue (MVar ()))
Nothing,[MVar ()]
queuedLocals0) ->
do
(MVar () -> IO ()) -> [MVar ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ MVar ()
mVar -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mVar ()) [MVar ()]
queuedLocals0
(VSemState, ()) -> IO (VSemState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VSemState
vSemState {queuedLocals :: [MVar ()]
queuedLocals = [],
nLocalLocks :: Int
nLocalLocks = [MVar ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MVar ()]
queuedLocals0},())
)