module Data.LVar.SLSet
(
ISet,
newEmptySet, newSet, newFromList,
insert, waitElem, waitSize,
member,
forEach, forEachHP,
freezeSetAfter, withCallbacksThenFreeze,
copy, traverseSet, traverseSet_, union, intersection,
cartesianProd, cartesianProds,
traverseSetHP, traverseSetHP_,
cartesianProdHP, cartesianProdsHP
) where
import Control.Applicative
import qualified Data.Foldable as F
import Data.Concurrent.SkipListMap as SLM
import Data.List (intersperse)
import qualified Data.Set as S
import qualified Data.LVar.IVar as IV
import Data.LVar.Generic
import Data.LVar.Generic.Internal (unsafeCoerceLVar)
import Control.Monad
import Control.LVish as LV
import Control.LVish.DeepFrz.Internal
import Control.LVish.Internal as LI
import Control.LVish.SchedIdempotent (newLV, putLV, getLV, freezeLV)
import qualified Control.LVish.SchedIdempotent as L
import System.IO.Unsafe (unsafeDupablePerformIO)
import Prelude hiding (insert)
data ISet s a = Ord a => ISet !(LVar s (SLM.SLMap a ()) a)
instance Eq (ISet s v) where
ISet slm1 == ISet slm2 = state slm1 == state slm2
instance LVarData1 ISet where
freeze orig@(ISet (WrapLVar lv)) =
WrapPar$ do freezeLV lv; return (unsafeCoerceLVar orig)
addHandler = forEachHP
sortFrzn (is :: ISet Frzn a) = AFoldable is
instance OrderedLVarData1 ISet where
snapFreeze is = unsafeCoerceLVar <$> freeze is
instance DeepFrz a => DeepFrz (ISet s a) where
type FrzType (ISet s a) = ISet Frzn (FrzType a)
frz = unsafeCoerceLVar
instance Show a => Show (ISet Frzn a) where
show lv = "{ISet: " ++
(concat $ intersperse ", " $ map show $
F.foldr (\ elm ls -> elm : ls) []
(unsafeCoerceLVar lv :: ISet Trvrsbl a)) ++ "}"
instance Show a => Show (ISet Trvrsbl a) where
show lv = show (castFrzn lv)
member :: a -> ISet Frzn a -> Bool
member elm (ISet (WrapLVar lv)) =
case unsafeDupablePerformIO (SLM.find (L.state lv) elm) of
Just () -> True
Nothing -> False
instance F.Foldable (ISet Frzn) where
foldr fn zer (ISet (WrapLVar lv)) =
unsafeDupablePerformIO $
SLM.foldlWithKey id (\ a k _v -> return (fn k a))
zer (L.state lv)
instance F.Foldable (ISet Trvrsbl) where
foldr fn zer mp = F.foldr fn zer (castFrzn mp)
defaultLevels :: Int
defaultLevels = 8
newEmptySet :: Ord a => Par d s (ISet s a)
newEmptySet = newEmptySet_ defaultLevels
newEmptySet_ :: Ord a => Int -> Par d s (ISet s a)
newEmptySet_ n = fmap (ISet . WrapLVar) $ WrapPar $ newLV $ SLM.newSLMap n
newSet :: Ord a => S.Set a -> Par d s (ISet s a)
newSet set =
fmap (ISet . WrapLVar) $ WrapPar $ newLV $ do
slm <- SLM.newSLMap defaultLevels
F.foldlM (\ () elm -> do
SLM.Added _ <- SLM.putIfAbsent slm elm (return ())
return ()
) () set
return slm
newFromList :: Ord a => [a] -> Par d s (ISet s a)
newFromList ls = newFromList_ ls defaultLevels
newFromList_ :: Ord a => [a] -> Int -> Par d s (ISet s a)
newFromList_ ls n = do
s@(ISet lv) <- newEmptySet_ n
LI.liftIO $ forM_ ls $ \x ->
SLM.putIfAbsent (state lv) x $ return ()
return s
freezeSetAfter :: ISet s a -> (a -> QPar s ()) -> QPar s ()
freezeSetAfter s f = withCallbacksThenFreeze s f (return ())
withCallbacksThenFreeze :: Eq b => ISet s a -> (a -> QPar s ()) -> QPar s b -> QPar s b
withCallbacksThenFreeze (ISet lv) callback action = do
hp <- newPool
res <- IV.new
let deltCB x = return$ Just$ unWrapPar$ callback x
initCB slm =
unWrapPar $ do
SLM.foldlWithKey LI.liftIO
(\() v () -> forkHP (Just hp) $ callback 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
-> ISet s a
-> (a -> Par d s ())
-> Par d s ()
forEachHP hp (ISet (WrapLVar lv)) callb = WrapPar $
L.addHandler hp lv globalCB (\x -> return$ Just$ unWrapPar$ callb x)
where
globalCB slm =
unWrapPar $
SLM.foldlWithKey LI.liftIO
(\() v () -> forkHP hp $ callb v) () slm
forEach :: ISet s a -> (a -> Par d s ()) -> Par d s ()
forEach = forEachHP Nothing
insert :: Ord a => a -> ISet s a -> Par d s ()
insert !elm (ISet lv) = WrapPar$ putLV (unWrapLVar lv) putter
where putter slm = do
putRes <- SLM.putIfAbsent slm elm $ return ()
case putRes of
Added _ -> return $ Just elm
Found _ -> return Nothing
waitElem :: Ord a => a -> ISet s a -> Par d s ()
waitElem !elm (ISet (WrapLVar lv)) = WrapPar $
getLV lv globalThresh deltaThresh
where
globalThresh slm _frzn = SLM.find slm elm
deltaThresh e2 | e2 == elm = return $ Just ()
| otherwise = return Nothing
waitSize :: Int -> ISet s a -> Par d s ()
waitSize !sz (ISet (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
copy :: Ord a => ISet s a -> Par d s (ISet s a)
copy = traverseSet return
traverseSet :: Ord b => (a -> Par d s b) -> ISet s a -> Par d s (ISet s b)
traverseSet f s = traverseSetHP Nothing f s
traverseSet_ :: Ord b => (a -> Par d s b) -> ISet s a -> ISet s b -> Par d s ()
traverseSet_ f s o = traverseSetHP_ Nothing f s o
union :: Ord a => ISet s a -> ISet s a -> Par d s (ISet s a)
union = unionHP Nothing
intersection :: Ord a => ISet s a -> ISet s a -> Par d s (ISet s a)
intersection = intersectionHP Nothing
cartesianProd :: (Ord a, Ord b) => ISet s a -> ISet s b -> Par d s (ISet s (a,b))
cartesianProd s1 s2 = cartesianProdHP Nothing s1 s2
cartesianProds :: Ord a => [ISet s a] -> Par d s (ISet s [a])
cartesianProds ls = cartesianProdsHP Nothing ls
traverseSetHP :: Ord b => Maybe HandlerPool -> (a -> Par d s b) -> ISet s a ->
Par d s (ISet s b)
traverseSetHP mh fn set = do
os <- newEmptySet
traverseSetHP_ mh fn set os
return os
traverseSetHP_ :: Ord b => Maybe HandlerPool -> (a -> Par d s b) -> ISet s a -> ISet s b ->
Par d s ()
traverseSetHP_ mh fn set os = do
forEachHP mh set $ \ x -> do
x' <- fn x
insert x' os
unionHP :: Ord a => Maybe HandlerPool -> ISet s a -> ISet s a -> Par d s (ISet s a)
unionHP mh s1 s2 = do
os <- newEmptySet
forEachHP mh s1 (`insert` os)
forEachHP mh s2 (`insert` os)
return os
intersectionHP :: Ord a => Maybe HandlerPool -> ISet s a -> ISet s a -> Par d s (ISet s a)
intersectionHP mh s1 s2 = do
os <- newEmptySet
forEachHP mh s1 (fn os s2)
forEachHP mh s2 (fn os s1)
return os
where
fn outSet other@(ISet lv) elm = do
peek <- LI.liftIO $ SLM.find (state lv) elm
case peek of
Just _ -> insert elm outSet
Nothing -> return ()
cartesianProdHP :: (Ord a, Ord b) => Maybe HandlerPool -> ISet s a -> ISet s b ->
Par d s (ISet s (a,b))
cartesianProdHP mh s1 s2 = do
os <- newEmptySet
forEachHP mh s1 (fn os s2 (\ x y -> (x,y)))
forEachHP mh s2 (fn os s1 (\ x y -> (y,x)))
return os
where
fn outSet other@(ISet lv) cmbn elm1 =
SLM.foldlWithKey LI.liftIO
(\() elm2 () -> insert (cmbn elm1 elm2) outSet) () (state lv)
cartesianProdsHP :: Ord a => Maybe HandlerPool -> [ISet s a] ->
Par d s (ISet s [a])
cartesianProdsHP mh [] = newEmptySet
cartesianProdsHP mh ls = do
#if 1
let loop [lst] = traverseSetHP mh (\x -> return [x]) lst
loop (nxt:rst) = do
partial <- loop rst
p1 <- cartesianProdHP mh nxt partial
traverseSetHP mh (\ (x,tl) -> return (x:tl)) p1
loop ls
#else
os <- newEmptySet
let loop done [] acc = acc
loop done (nxt:rest) acc =
addHandler hp nxt (fn os done rest)
return os
where
fn outSet left right newElm = do
peeksL <- liftIO$ mapM (readIORef . state . unISet) left
peeksR <- liftIO$ mapM (readIORef . state . unISet) right
return (error "FINISHME: set cartesianProdHP")
#endif