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 {
queuedGlobals :: Queue (MVar ()),
queuedLocals :: [MVar ()],
nLocalLocks :: Int
}
newtype VSem = VSem (MVar VSemState)
newVSem :: IO VSem
newVSem =
do
mVar <- newMVar (VSemState {
queuedGlobals = emptyQ,
queuedLocals = [],
nLocalLocks = 0
})
return (VSem mVar)
synchronizeLocal :: VSem -> IO b -> IO b
synchronizeLocal vSem act =
do
acquireLocal vSem
finally act (releaseLocal vSem)
synchronizeGlobal :: VSem -> IO b -> IO b
synchronizeGlobal vSem act =
do
acquireGlobal vSem
finally act (releaseGlobal vSem)
vSemAct :: VSem -> (VSemState -> IO (VSemState,b)) -> IO b
vSemAct (VSem mVar) update =
modifyMVar mVar update
acquireLocal :: VSem -> IO ()
acquireLocal vSem =
do
act <- vSemAct vSem (\ vSemState ->
if nLocalLocks vSemState <0
then
do
mVar <- newEmptyMVar
return (vSemState {
queuedLocals = mVar : queuedLocals vSemState},
takeMVar mVar
)
else
return (vSemState {
nLocalLocks = nLocalLocks vSemState + 1},
done)
)
act
releaseLocal :: VSem -> IO ()
releaseLocal vSem =
vSemAct vSem (\ vSemState ->
do
let
nLocalLocks0 = nLocalLocks vSemState
nLocalLocks1 = nLocalLocks0 1
case (nLocalLocks1,removeQ (queuedGlobals vSemState)) of
(0,Just (mVar,queuedGlobals1)) ->
do
putMVar mVar ()
return (vSemState {nLocalLocks = 1,
queuedGlobals = queuedGlobals1
},())
_ -> return (vSemState {nLocalLocks = nLocalLocks1},())
)
acquireGlobal :: VSem -> IO ()
acquireGlobal vSem =
do
act <- vSemAct vSem (\ vSemState ->
do
let
nLocalLocks0 = nLocalLocks vSemState
if nLocalLocks0 == 0
then
return (vSemState {nLocalLocks = 1},done)
else
do
mVar <- newEmptyMVar
return (vSemState {
queuedGlobals
= insertQ (queuedGlobals vSemState) mVar},
takeMVar mVar
)
)
act
releaseGlobal :: VSem -> IO ()
releaseGlobal vSem =
vSemAct vSem (\ vSemState ->
case (removeQ (queuedGlobals vSemState),queuedLocals vSemState) of
(Just (mVar,queuedGlobals1),_) ->
do
putMVar mVar ()
return (vSemState {queuedGlobals = queuedGlobals1},())
(Nothing,queuedLocals0) ->
do
mapM_ (\ mVar -> putMVar mVar ()) queuedLocals0
return (vSemState {queuedLocals = [],
nLocalLocks = length queuedLocals0},())
)