-- | | Implements locks which can be locked "globally" or "locally".
--   A global lock prevents any other lock; a local lock allows other local
--   locks.
--
--   There are some subtle decisions to be made about when to give preference
--   to local, and when to global, locks.  There are two important cases:
--   (1) When we free a global lock, and there is another queued global lock,
--       we take that global lock (or the earliest for which someone is
--       waiting, if there's a choice), irrespective of whether anyone is
--       waiting for a local lock.
--   (2) When at least one local lock is held, we allow people to acquire
--       further local locks, even if there are queued global locks.
--
--   A bad consequence of (2) is that a global lock can be indefinitely not
--   satisfied by a carefully-timed sequence of finite local locks:
--
--   local locks : --- --- --- --- . . .
--                   --- --- ---   . . .
--   no global lock can be acquired at all.
--
--   However the alternative, of not permitting any fresh local locks when
--   a global lock is queued, is worse (in my opinion), since if a thread
--   attempts to acquire two local locks, one inside the other, and another
--   attempts to acquire a global lock, the whole thing can deadlock.
--
--   Thread 1  : acquire local lock                    attempt to acquire second local lock => DEADLOCK.
--   Thread 2  :                   wait for global lock
--
--   We could deal with this partially by allowing local locks for free
--   to a thread which already holds one, but this is more complicated and
--   I suspect theoretically dodgy.
--
--   A consequence of this decision is that threads should avoid creating
--   automated repeated sequences of local locks on the same VSem.
module Util.VSem(
   VSem,
   newVSem,

   synchronizeLocal,
   synchronizeGlobal,

   acquireLocal, -- :: VSem -> IO ()
   releaseLocal, -- :: VSem -> IO ()
   ) 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
      -- ^ -1 if the vSem is globally locked, otherwise the number of local
      -- locks.
   }

-- | A lock which can be globally or locally locked.
-- At any time, a @VSem@ is either globally locked once, or locally locked
-- zero or more times.  Global locks always take priority over local locks.
newtype VSem = VSem (MVar VSemState)

-- | Creates a 'VSem'.
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)

-- | Perform an action while locking a 'VSem' locally.
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)

-- | Perform an action while locking a 'VSem' globally.
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

-- | Acquire a local lock on a 'VSem'
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


-- | Release a local lock on a 'VSem'
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},())
      )


-- | Acquire a global lock on a 'VSem'
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


-- | Release a global lock on a 'VSem'
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},())
      )