module Data.LVar.SLMap
(
IMap,
newEmptyMap, newMap, newFromList,
insert,
getKey, waitSize, waitValue,
modify,
freezeMap,
traverseFrzn_,
forEach, forEachHP,
withCallbacksThenFreeze,
copy, traverseMap, traverseMap_,
traverseMapHP, traverseMapHP_, unionHP,
levelCounts
) where
import Control.Exception (throw)
import Control.Applicative
import Data.Concurrent.SkipListMap as SLM
import qualified Data.Map.Strict as M
import qualified Data.LVar.IVar as IV
import qualified Data.Foldable as F
import Data.IORef (readIORef)
import Data.UtilInternal (traverseWithKey_)
import Data.List (intersperse)
import Data.LVar.Generic
import Data.LVar.Generic.Internal (unsafeCoerceLVar)
import Control.Monad
import Control.Monad.IO.Class
import Control.LVish
import Control.LVish.DeepFrz.Internal
import Control.LVish.Internal as LI
import Control.LVish.SchedIdempotent (newLV, putLV, putLV_, getLV, freezeLV)
import qualified Control.LVish.SchedIdempotent as L
import System.IO.Unsafe (unsafeDupablePerformIO)
import GHC.Prim (unsafeCoerce#)
import Prelude
import Debug.Trace
#ifdef GENERIC_PAR
import qualified Control.Par.Class as PC
import Control.Par.Class.Unsafe (internalLiftIO)
import qualified Data.Splittable.Class as Sp
import Data.Par.Splittable (pmapReduceWith_, mkMapReduce)
#endif
data IMap k s v = Ord k => IMap !(LVar s (SLM.SLMap k v) (k,v))
instance Eq (IMap k s v) where
IMap lv1 == IMap lv2 = state lv1 == state lv2
instance LVarData1 (IMap k) where
freeze orig@(IMap (WrapLVar lv)) =
WrapPar$ do freezeLV lv; return (unsafeCoerceLVar orig)
sortFrzn = AFoldable
addHandler mh (IMap (WrapLVar lv)) callb = WrapPar $
L.addHandler mh lv globalCB (\(_k,v) -> return$ Just$ unWrapPar$ callb v)
where
globalCB slm =
unWrapPar $
SLM.foldlWithKey LI.liftIO
(\() _k v -> forkHP mh $ callb v) () slm
instance OrderedLVarData1 (IMap k) where
snapFreeze is = unsafeCoerceLVar <$> freeze is
instance DeepFrz a => DeepFrz (IMap k s a) where
type FrzType (IMap k s a) = IMap k Frzn (FrzType a)
frz = unsafeCoerceLVar
defaultLevels :: Int
defaultLevels = 8
newEmptyMap :: Ord k => Par d s (IMap k s v)
newEmptyMap = newEmptyMap_ defaultLevels
newEmptyMap_ :: Ord k => Int -> Par d s (IMap k s v)
newEmptyMap_ n = fmap (IMap . WrapLVar) $ WrapPar $ newLV $ SLM.newSLMap n
newMap :: Ord k => M.Map k v -> Par d s (IMap k s v)
newMap mp =
fmap (IMap . WrapLVar) $ WrapPar $ newLV $ do
slm <- SLM.newSLMap defaultLevels
traverseWithKey_ (\ k v -> do Added _ <- SLM.putIfAbsent slm k (return v)
return ()
) mp
return slm
newFromList :: (Ord k, Eq v) =>
[(k,v)] -> Par d s (IMap k s v)
newFromList ls = newFromList_ ls defaultLevels
newFromList_ :: Ord k => [(k,v)] -> Int -> Par d s (IMap k s v)
newFromList_ ls n = do
m@(IMap lv) <- newEmptyMap_ n
forM_ ls $ \(k,v) -> LI.liftIO $ SLM.putIfAbsent (state lv) k $ return v
return m
withCallbacksThenFreeze :: forall k v b s . Eq b =>
IMap k s v -> (k -> v -> QPar s ()) -> QPar s b -> QPar s b
withCallbacksThenFreeze (IMap lv) callback action = do
hp <- newPool
res <- IV.new
let deltCB (k,v) = return$ Just$ unWrapPar$ callback k v
initCB slm = do
unWrapPar $ do
SLM.foldlWithKey LI.liftIO
(\() k v -> forkHP (Just hp) $ callback k v) () slm
x <- action
IV.put_ res x
WrapPar $ L.addHandler (Just hp) (unWrapLVar lv) initCB deltCB
quiesce hp
IV.get res
forEachHP :: Maybe HandlerPool
-> IMap k s v
-> (k -> v -> Par d s ())
-> Par d s ()
forEachHP mh (IMap (WrapLVar lv)) callb = WrapPar $
L.addHandler mh lv globalCB (\(k,v) -> return$ Just$ unWrapPar$ callb k v)
where
gcallb k v = do
logDbgLn 5 " [SLMap] callback from global traversal "
callb k v
globalCB slm = do
unWrapPar $ do
logDbgLn 5 " [SLMap] Beginning fold to check for global-work"
SLM.foldlWithKey LI.liftIO (\() k v -> forkHP mh $ gcallb k v) () slm
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 slm = do
putRes <- SLM.putIfAbsent slm key $ return elm
case putRes of
Added _ -> return $ Just (key, elm)
Found _ -> throw$ ConflictingPutExn$ "Multiple puts to one entry in an IMap!"
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 (WrapLVar lv)) key newBottom fn = do
act <- WrapPar $ putLV_ lv putter
act
where putter slm = do
putRes <- unWrapPar $ SLM.putIfAbsent slm key newBottom
case putRes of
Added v -> return (Just (key,v), fn v)
Found v -> return (Nothing, fn v)
getKey :: Ord k => k -> IMap k s v -> Par d s v
getKey !key (IMap (WrapLVar lv)) = WrapPar$ getLV lv globalThresh deltaThresh
where
globalThresh slm _frzn = SLM.find slm key
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
deltaThresh (_,v) | v == val = return$ Just ()
| otherwise = return Nothing
globalThresh ref _frzn = do
let slm = L.state lv
let fn Nothing _k v | v == val = return $! Just ()
| otherwise = return $ Nothing
fn just _ _ = return $! just
SLM.foldlWithKey id fn Nothing slm
waitSize :: Int -> IMap k s v -> Par d s ()
waitSize !sz (IMap (WrapLVar lv)) = WrapPar $
getLV lv globalThresh deltaThresh
where
globalThresh slm _ = do
snapSize <- SLM.foldlWithKey id (\n _ _ -> return $ n+1) 0 slm
case snapSize >= sz of
True -> return (Just ())
False -> return (Nothing)
deltaThresh _ = globalThresh (L.state lv) False
freezeMap :: Ord k => IMap k s v -> QPar s (IMap k Frzn v)
freezeMap x@(IMap (WrapLVar lv)) = WrapPar $ do
freezeLV lv
return (unsafeCoerce# x)
traverseFrzn_ :: (Ord k) =>
(k -> a -> Par d s ()) -> IMap k Frzn a -> Par d s ()
traverseFrzn_ fn (IMap (WrapLVar lv)) =
SLM.foldlWithKey LI.liftIO
(\ () k v -> fn k v)
() (L.state lv)
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
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
levelCounts :: IMap k s a -> IO [Int]
levelCounts (IMap (WrapLVar lv)) =
let slm = L.state lv in
SLM.counts slm
instance F.Foldable (IMap k Frzn) where
foldr fn zer (IMap (WrapLVar lv)) =
unsafeDupablePerformIO $
SLM.foldlWithKey id (\ a _k v -> return (fn v a))
zer (L.state lv)
instance F.Foldable (IMap k Trvrsbl) where
foldr fn zer mp = F.foldr fn zer (castFrzn mp)
#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)) =
unsafeDupablePerformIO $
SLM.foldlWithKey id (\ a k v -> return $! fn a (k,v))
zer (L.state lv)
foldMP fn zer (IMap (WrapLVar lv)) =
SLM.foldlWithKey internalLiftIO (\ a k v -> fn a (k,v))
zer (L.state lv)
instance Show k => PC.ParFoldable (IMap k Frzn a) where
pmapFold mfn rfn initAcc (IMap lv) = do
let slm = state lv
slc = SLM.toSlice slm
splitter s =
case unsafeDupablePerformIO (SLM.splitSlice s) of
Nothing -> [s]
Just (s1,s2) -> [s1,s2]
seqfold fn zer (SLM.Slice slm st en) = do
internalLiftIO $ putStrLn $ "[DBG] dropping to seqfold.., st/en: "++show (st,en)
SLM.foldlWithKey internalLiftIO (\ a k v -> fn a (k,v)) zer slm
internalLiftIO $ putStrLn$ "[DBG] pmapFold on frzn IMap... calling mkMapReduce"
mkMapReduce splitter seqfold PC.spawn_
slc mfn rfn initAcc
instance F.Foldable (SLMapSlice k) where
#endif
instance (Show k, Show a) => Show (IMap k Frzn a) where
show (IMap (WrapLVar lv)) =
"{IMap: " ++
(concat $ intersperse ", " $
unsafeDupablePerformIO $
SLM.foldlWithKey id (\ acc k v -> return$ show (k, v) : acc)
[] (L.state lv)
) ++ "}"
instance (Show k, Show a) => Show (IMap k Trvrsbl a) where
show lv = show (castFrzn lv)
#if 0
instance PC.ParIMap (Par d s) where
type PC.IMap (Par d s) k = IMap k s
type PC.IMapContents (Par d s) k v = (Ord k, Eq v)
PC.waitSize = waitSize
PC.newEmptyMap = newEmptyMap
PC.insert = insert
PC.getKey = getKey
#endif