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:
parent
6a3e5f50c2
commit
8b0f2763d3
80
Control/Monad/Conc/CVar.hs
Normal file
80
Control/Monad/Conc/CVar.hs
Normal 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
|
@ -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
|
||||
|
||||
|
@ -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:
|
||||
|
Loading…
Reference in New Issue
Block a user