git.iko.soy/distributed-process
on 42ba2b9 help sign in
distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hs
61 lines 1.7 kB history raw
1-- | Like Control.Concurrent.MVar.Strict but reduce to HNF, not NF
2{-# LANGUAGE MagicHash, UnboxedTuples #-}
3module Control.Distributed.Process.Internal.StrictMVar
4 ( StrictMVar(StrictMVar)
5 , newEmptyMVar
6 , newMVar
7 , takeMVar
8 , putMVar
9 , withMVar
10 , modifyMVar_
11 , modifyMVar
12 , mkWeakMVar
13 ) where
15import Control.Applicative ((<$>))
16import Control.Monad ((>=>))
17import Control.Exception (evaluate)
18import qualified Control.Concurrent.MVar as MVar
19 ( MVar
20 , newEmptyMVar
21 , newMVar
22 , takeMVar
23 , putMVar
24 , withMVar
25 , modifyMVar_
26 , modifyMVar
27 )
28import GHC.MVar (MVar(MVar))
29import GHC.IO (IO(IO))
30import GHC.Prim (mkWeak#)
31import GHC.Weak (Weak(Weak))
33newtype StrictMVar a = StrictMVar (MVar.MVar a)
35newEmptyMVar :: IO (StrictMVar a)
36newEmptyMVar = StrictMVar <$> MVar.newEmptyMVar
38newMVar :: a -> IO (StrictMVar a)
39newMVar x = evaluate x >> StrictMVar <$> MVar.newMVar x
41takeMVar :: StrictMVar a -> IO a
42takeMVar (StrictMVar v) = MVar.takeMVar v
44putMVar :: StrictMVar a -> a -> IO ()
45putMVar (StrictMVar v) x = evaluate x >> MVar.putMVar v x
47withMVar :: StrictMVar a -> (a -> IO b) -> IO b
48withMVar (StrictMVar v) = MVar.withMVar v
50modifyMVar_ :: StrictMVar a -> (a -> IO a) -> IO ()
51modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate)
53modifyMVar :: StrictMVar a -> (a -> IO (a, b)) -> IO b
54modifyMVar (StrictMVar v) f = MVar.modifyMVar v (f >=> evaluateFst)
55 where
56 evaluateFst :: (a, b) -> IO (a, b)
57 evaluateFst (x, y) = evaluate x >> return (x, y)
59mkWeakMVar :: StrictMVar a -> IO () -> IO (Weak (StrictMVar a))
60mkWeakMVar m@(StrictMVar (MVar m#)) f = IO $ \s ->
61 case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)