1
1
mirror of https://github.com/barrucadu/dejafu.git synced 2024-12-22 21:11:30 +03:00

Add some helpful CVar combinators

This commit is contained in:
Michael Walker 2014-12-21 09:38:25 +00:00
parent 6a3e5f50c2
commit 8b0f2763d3
3 changed files with 85 additions and 6 deletions

View File

@ -0,0 +1,80 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
-- | Combinators using @CVar@s. These provide many of the helpful
-- functions found in Control.Concurrent.MVar, but for @CVar@s. Note
-- that these do not in general mask exceptions, and are not atomic,
-- being implemented in terms of the primitives in the 'ConcFuture'
-- and 'ConcCVar' typeclasses.
module Control.Monad.Conc.CVar
( -- *Combinators
newCVar
, swapCVar
, isEmptyCVar
, withCVar
, modifyCVar
, modifyCVar_
-- * Binary semaphores
-- | A common use of @CVar@s is in making binary semaphores to
-- control mutual exclusion over a resource, so a couple of helper
-- functions are provided.
, lock
, unlock
) where
import Control.Monad (liftM, void)
import Control.Monad.Conc.Class
-- | Create a new @CVar@ containing a value.
newCVar :: ConcCVar cvar m => a -> m (cvar a)
newCVar a = do
cvar <- newEmptyCVar
putCVar cvar a
return cvar
-- | Swap the contents of a @CVar@, and return the value taken.
swapCVar :: ConcCVar cvar m => cvar a -> a -> m a
swapCVar cvar a = do
old <- takeCVar cvar
putCVar cvar a
return old
-- | Check if a @CVar@ is empty.
isEmptyCVar :: ConcCVar cvar m => cvar a -> m Bool
isEmptyCVar cvar = do
val <- tryTakeCVar cvar
case val of
Just val' -> putCVar cvar val' >> return True
Nothing -> return False
-- | Operate on the contents of a @CVar@, replacing the contents after
-- finishing.
withCVar :: ConcCVar cvar m => cvar a -> (a -> m b) -> m b
withCVar cvar f = do
val <- takeCVar cvar
out <- f val
putCVar cvar val
return out
-- | Apply a function to the value inside a @CVar@, and also return a
-- value.
modifyCVar :: ConcCVar cvar m => cvar a -> (a -> m (a, b)) -> m b
modifyCVar cvar f = do
val <- takeCVar cvar
(val', out) <- f val
putCVar cvar val'
return out
-- | Modify the contents of a @CVar@.
modifyCVar_ :: ConcCVar cvar m => cvar a -> (a -> m a) -> m ()
modifyCVar_ cvar f = modifyCVar cvar $ \a -> (, ()) `liftM` f a
-- | Put a @()@ into a @CVar@, claiming the lock. This is atomic.
lock :: ConcCVar cvar m => cvar () -> m ()
lock = flip putCVar ()
-- | Empty a @CVar@, releasing the lock. This is atomic.
unlock :: ConcCVar cvar m => cvar () -> m ()
unlock = takeCVar

View File

@ -8,16 +8,15 @@
-- update the shared variable, and release the locks. The main thread
-- waits for them both to terminate, and returns the final result.
--
-- > bad :: Conc t Int
-- > bad :: ConcCVar (cvar t) (m t) => m t Int
-- > bad = do
-- > a <- newEmptyCVar
-- > b <- newEmptyCVar
-- >
-- > c <- newEmptyCVar
-- > putCVar c 0
-- > c <- newCVar 0
-- >
-- > j1 <- spawn $ putCVar a () >> putCVar b () >> takeCVar c >>= putCVar c . succ >> takeCVar b >> takeCVar a
-- > j2 <- spawn $ putCVar b () >> putCVar a () >> takeCVar c >>= putCVar c . pred >> takeCVar a >> takeCVar b
-- > j1 <- spawn $ lock a >> lock b >> modifyCVar_ c (return . succ) >> unlock b >> unlock a
-- > j2 <- spawn $ lock b >> lock a >> modifyCVar_ c (return . pred) >> unlock a >> unlock b
-- >
-- > takeCVar j1
-- > takeCVar j2
@ -66,4 +65,3 @@ sctRandom :: RandomGen g => SCTScheduler g
sctRandom (g, log) _ threads = (tid, (g', log ++ [tid])) where
(choice, g') = randomR (0, length threads - 1) g
tid = threads !! choice

View File

@ -18,6 +18,7 @@ cabal-version: >=1.10
library
exposed-modules: Control.Monad.Conc.Class
, Control.Monad.Conc.CVar
, Control.Monad.Conc.Fixed
, Control.Monad.Conc.SCT
-- other-modules: