module Data.LVar.IVar
(
IVar(..),
new, get, put, put_,
spawn, spawn_, spawnP,
freezeIVar, fromIVar, whenFull)
where
import Data.IORef
import Control.DeepSeq
import System.Mem.StableName (makeStableName, hashStableName)
import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
import qualified Data.Foldable as F
import Control.Exception (throw)
import Control.LVish as LV
import Control.LVish.DeepFrz.Internal
import Control.LVish.Internal as I
import Control.LVish.SchedIdempotent (newLV, putLV, getLV, freezeLV)
import qualified Control.LVish.SchedIdempotent as LI
import Data.LVar.Generic
import Data.LVar.Generic.Internal (unsafeCoerceLVar)
import GHC.Prim (unsafeCoerce#)
#ifdef USE_ABSTRACT_PAR
import qualified Control.Monad.Par.Class as PC
#endif
newtype IVar s a = IVar (LVar s (IORef (Maybe a)) a)
instance Eq (IVar s a) where
(==) (IVar lv1) (IVar lv2) = state lv1 == state lv2
instance LVarData1 IVar where
freeze :: IVar s a -> Par QuasiDet s (IVar Frzn a)
freeze orig@(IVar (WrapLVar lv)) = WrapPar $ do
freezeLV lv
return (unsafeCoerceLVar orig)
addHandler = whenFull
instance DeepFrz a => DeepFrz (IVar s a) where
type FrzType (IVar s a) = IVar Frzn (FrzType a)
frz = unsafeCoerceLVar
instance F.Foldable (IVar Trvrsbl) where
foldr fn zer (IVar lv) =
case unsafeDupablePerformIO$ readIORef (state lv) of
Just x -> fn x zer
Nothing -> zer
instance (Show a) => Show (IVar Frzn a) where
show (IVar lv) =
show $ unsafeDupablePerformIO $ readIORef (state lv)
instance Show a => Show (IVar Trvrsbl a) where
show = show . castFrzn
new :: Par d s (IVar s a)
new = WrapPar$ fmap (IVar . WrapLVar) $
newLV $ newIORef Nothing
get :: IVar s a -> Par d s a
get (IVar (WrapLVar iv)) = WrapPar$ getLV iv globalThresh deltaThresh
where globalThresh ref _ = readIORef ref
deltaThresh x = return $ Just x
put_ :: Eq a => IVar s a -> a -> Par d s ()
put_ (IVar (WrapLVar iv)) !x = WrapPar $ putLV iv putter
where putter ref = atomicModifyIORef ref update
update (Just y) | x == y = (Just y, Nothing)
| otherwise = unsafePerformIO $
do n1 <- fmap hashStableName $ makeStableName x
n2 <- fmap hashStableName $ makeStableName y
throw (LV.ConflictingPutExn$ "Multiple puts to an IVar! (obj "++show n2++" was "++show n1++")")
update Nothing = (Just x, Just x)
freezeIVar :: IVar s a -> LV.Par QuasiDet s (Maybe a)
freezeIVar (IVar (WrapLVar lv)) = WrapPar $
do freezeLV lv
getLV lv globalThresh deltaThresh
where
globalThresh _ False = return Nothing
globalThresh ref True = fmap Just $ readIORef ref
deltaThresh _ = return Nothing
fromIVar :: IVar Frzn a -> Maybe a
fromIVar (IVar lv) = unsafeDupablePerformIO $ readIORef (state lv)
whenFull :: Maybe HandlerPool -> IVar s a -> (a -> Par d s ()) -> Par d s ()
whenFull mh (IVar (WrapLVar lv)) fn =
WrapPar (LI.addHandler mh lv globalCB fn')
where
fn' x = return (Just (unWrapPar (fn x)))
globalCB ref = do
mx <- readIORef ref
case mx of
Nothing -> return Nothing
Just v -> fn' v
spawn :: (Eq a, NFData a) => Par d s a -> Par d s (IVar s a)
spawn p = do r <- new; fork (p >>= put r); return r
spawn_ :: Eq a => Par d s a -> Par d s (IVar s a)
spawn_ p = do r <- new; fork (p >>= put_ r); return r
spawnP :: (Eq a, NFData a) => a -> Par d s (IVar s a)
spawnP a = spawn (return a)
put :: (Eq a, NFData a) => IVar s a -> a -> Par d s ()
put v a = deepseq a (put_ v a)
#ifdef USE_ABSTRACT_PAR
#warning "Using the latest version of abstract par to activate ParFuture/IVar instances."
instance PC.ParFuture (IVar s) (Par d s) where
spawn_ = spawn_
get = get
instance PC.ParIVar (IVar s) (Par d s) where
fork = fork
put_ = put_
new = new
#endif