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 qualified Control.LVish.Types as LV
import qualified Control.LVish.Basics as LV
import Control.LVish.DeepFrz.Internal
import qualified Control.LVish.Internal as I
import Control.LVish.Internal (Par(WrapPar), LVar(WrapLVar), Determinism(QuasiDet))
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 GENERIC_PAR
import qualified Control.Par.Class as PC
import qualified Control.Par.Class.Unsafe as PC
#endif
newtype IVar s a = IVar (LVar s (IORef (Maybe a)) a)
instance Eq (IVar s a) where
(==) (IVar lv1) (IVar lv2) = I.state lv1 == I.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 LVarWBottom IVar where
type LVContents IVar a = ()
newBottom = new
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 (I.state lv) of
Just x -> fn x zer
Nothing -> zer
instance (Show a) => Show (IVar Frzn a) where
show (IVar lv) =
show $ unsafeDupablePerformIO $ readIORef (I.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 -> I.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 (I.state lv)
whenFull :: Maybe LI.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 (I.unWrapPar (fn x)))
globalCB ref = do
mx <- LI.liftIO $ readIORef ref
case mx of
Nothing -> return ()
Just v -> I.unWrapPar$ fn v
spawn :: (Eq a, NFData a) => Par d s a -> Par d s (IVar s a)
spawn p = do r <- new; LV.fork (p >>= put r); return r
spawn_ :: Eq a => Par d s a -> Par d s (IVar s a)
spawn_ p = do r <- new; LV.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 GENERIC_PAR
instance PC.ParFuture (Par d s) where
type Future (Par d s) = IVar s
type FutContents (Par d s) a = (Eq a)
spawn_ = spawn_
get = get
instance PC.ParIVar (Par d s) where
put_ = put_
new = new
#endif