module Data.LVar.PureMap
(
IMap(..),
newEmptyMap, newMap, newFromList,
insert,
getKey, waitValue, waitSize, modify,
gmodify, getOrInit,
forEach, forEachHP,
withCallbacksThenFreeze,
freezeMap, fromIMap,
traverseFrzn_,
copy, traverseMap, traverseMap_, union,
traverseMapHP, traverseMapHP_, unionHP
) where
import Control.LVish.DeepFrz.Internal
import Control.LVish
import Control.LVish.Internal as LI
import Control.LVish.SchedIdempotent (newLV, putLV, putLV_, getLV, freezeLV, freezeLVAfter)
import qualified Control.LVish.SchedIdempotent as L
import qualified Data.LVar.IVar as IV
import Data.LVar.Generic as G
import Data.LVar.PureMap.Unsafe
import Data.UtilInternal (traverseWithKey_)
import Control.Exception (throw)
import Data.IORef
import qualified Data.Map.Strict as M
import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
import System.Mem.StableName (makeStableName, hashStableName)
#ifdef GENERIC_PAR
import Data.Par.Map ()
import qualified Control.Par.Class as PC
import Control.Par.Class.Unsafe (internalLiftIO)
#endif
newEmptyMap :: Par d s (IMap k s v)
newEmptyMap = WrapPar$ fmap (IMap . WrapLVar) $ newLV$ newIORef M.empty
newMap :: M.Map k v -> Par d s (IMap k s v)
newMap m = WrapPar$ fmap (IMap . WrapLVar) $ newLV$ newIORef m
newFromList :: (Ord k, Eq v) =>
[(k,v)] -> Par d s (IMap k s v)
newFromList = newMap . M.fromList
withCallbacksThenFreeze :: forall k v b s . Eq b =>
IMap k s v -> (k -> v -> QPar s ()) -> QPar s b -> QPar s b
withCallbacksThenFreeze (IMap (WrapLVar lv)) callback action =
do hp <- newPool
res <- IV.new
WrapPar$ freezeLVAfter lv (initCB hp res) deltaCB
quiesce hp
IV.get res
where
deltaCB (k,v) = return$ Just$ unWrapPar $ callback k v
initCB :: HandlerPool -> IV.IVar s b -> (IORef (M.Map k v)) -> L.Par ()
initCB hp resIV ref = do
mp <- L.liftIO $ readIORef ref
unWrapPar $ do
traverseWithKey_ (\ k v -> forkHP (Just hp)$ callback k v) mp
res <- action
IV.put_ resIV res
forEach :: IMap k s v -> (k -> v -> Par d s ()) -> Par d s ()
forEach = forEachHP Nothing
insert :: (Ord k, Eq v) =>
k -> v -> IMap k s v -> Par d s ()
insert !key !elm (IMap (WrapLVar lv)) = WrapPar$ putLV lv putter
where putter ref = atomicModifyIORef' ref update
update mp =
let mp' = M.insertWith fn key elm mp
fn v1 v2 | v1 == v2 = v1
| otherwise = throw$ ConflictingPutExn$ "Multiple puts to one entry in an IMap!"
in
if M.size mp' > M.size mp
then (mp',Just (key,elm))
else (mp, Nothing)
modify :: forall f a b d s key . (Ord key, LVarData1 f, Show key, Ord a) =>
IMap key s (f s a)
-> key
-> (Par d s (f s a))
-> (f s a -> Par d s b)
-> Par d s b
modify (IMap lv) key newBottom fn = WrapPar $ do
let ref = state lv
mp <- L.liftIO$ readIORef ref
case M.lookup key mp of
Just lv2 -> do L.logStrLn 3 $ " [Map.modify] key already present: "++show key++
" adding to inner "++show(unsafeName lv2)
unWrapPar$ fn lv2
Nothing -> do
bot <- unWrapPar newBottom :: L.Par (f s a)
L.logStrLn 3$ " [Map.modify] allocated new inner "++show(unsafeName bot)
let putter _ = L.liftIO$ atomicModifyIORef' ref $ \ mp2 ->
case M.lookup key mp2 of
Just lv2 -> (mp2, (Nothing, unWrapPar$ fn lv2))
Nothing -> (M.insert key bot mp2,
(Just (key, bot),
do L.logStrLn 3$ " [Map.modify] key absent, adding the new one."
unWrapPar$ fn bot))
act <- putLV_ (unWrapLVar lv) putter
act
gmodify :: forall f a b d s key . (Ord key, LVarData1 f, LVarWBottom f, LVContents f a, Show key, Ord a) =>
IMap key s (f s a)
-> key
-> (f s a -> Par d s b)
-> Par d s b
gmodify map key fn = modify map key G.newBottom fn
getOrInit :: forall f a b d s key . (Ord key, LVarData1 f, LVarWBottom f, LVContents f a, Show key, Ord a) =>
key -> IMap key s (f s a) -> Par d s (f s a)
getOrInit key mp = gmodify mp key return
getKey :: Ord k => k -> IMap k s v -> Par d s v
getKey !key (IMap (WrapLVar lv)) = WrapPar$ getLV lv globalThresh deltaThresh
where
globalThresh ref _frzn = do
mp <- readIORef ref
return (M.lookup key mp)
deltaThresh (k,v) | k == key = return$ Just v
| otherwise = return Nothing
waitValue :: (Ord k, Eq v) => v -> IMap k s v -> Par d s ()
waitValue !val (IMap (WrapLVar lv)) = WrapPar$ getLV lv globalThresh deltaThresh
where
globalThresh ref _frzn = do
mp <- readIORef ref
let fn Nothing v | v == val = Just ()
| otherwise = Nothing
fn just _ = just
return $! M.foldl fn Nothing mp
deltaThresh (_,v) | v == val = return$ Just ()
| otherwise = return Nothing
waitSize :: Int -> IMap k s v -> Par d s ()
waitSize !sz (IMap (WrapLVar lv)) = WrapPar $
getLV lv globalThresh deltaThresh
where
globalThresh ref _frzn = do
mp <- readIORef ref
case M.size mp >= sz of
True -> return (Just ())
False -> return (Nothing)
deltaThresh _ = globalThresh (L.state lv) False
freezeMap :: IMap k s v -> QPar s (M.Map k v)
freezeMap (IMap (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
fromIMap :: IMap k Frzn a -> M.Map k a
fromIMap (IMap lv) = unsafeDupablePerformIO (readIORef (state lv))
traverseFrzn_ :: (Ord k) =>
(k -> a -> Par d s ()) -> IMap k Frzn a -> Par d s ()
traverseFrzn_ fn mp =
traverseWithKey_ fn (fromIMap mp)
traverseMap :: (Ord k, Eq b) =>
(k -> a -> Par d s b) -> IMap k s a -> Par d s (IMap k s b)
traverseMap f s = traverseMapHP Nothing f s
traverseMap_ :: (Ord k, Eq b) =>
(k -> a -> Par d s b) -> IMap k s a -> IMap k s b -> Par d s ()
traverseMap_ f s o = traverseMapHP_ Nothing f s o
union :: (Ord k, Eq a) => IMap k s a -> IMap k s a -> Par d s (IMap k s a)
union = unionHP Nothing
copy :: (Ord k, Eq v) => IMap k s v -> Par d s (IMap k s v)
copy = traverseMap (\ _ x -> return x)
traverseMapHP :: (Ord k, Eq b) =>
Maybe HandlerPool -> (k -> a -> Par d s b) -> IMap k s a ->
Par d s (IMap k s b)
traverseMapHP mh fn set = do
os <- newEmptyMap
traverseMapHP_ mh fn set os
return os
traverseMapHP_ :: (Ord k, Eq b) =>
Maybe HandlerPool -> (k -> a -> Par d s b) -> IMap k s a -> IMap k s b ->
Par d s ()
traverseMapHP_ mh fn set os = do
forEachHP mh set $ \ k x -> do
x' <- fn k x
insert k x' os
unionHP :: (Ord k, Eq a) => Maybe HandlerPool ->
IMap k s a -> IMap k s a -> Par d s (IMap k s a)
unionHP mh m1 m2 = do
os <- newEmptyMap
forEachHP mh m1 (\ k v -> insert k v os)
forEachHP mh m2 (\ k v -> insert k v os)
return os
unsafeName :: a -> Int
unsafeName x = unsafePerformIO $ do
sn <- makeStableName x
return (hashStableName sn)
#ifdef GENERIC_PAR
#warning "Creating instances for generic programming with IMaps"
instance PC.Generator (IMap k Frzn a) where
type ElemOf (IMap k Frzn a) = (k,a)
fold fn zer (IMap (WrapLVar lv)) = PC.fold fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv
foldM fn zer (IMap (WrapLVar lv)) = PC.foldM fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv
foldMP fn zer (IMap (WrapLVar lv)) = PC.foldMP fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv
#endif