diff --git a/Control/LVish/SchedIdempotent.hs b/Control/LVish/SchedIdempotent.hs --- a/Control/LVish/SchedIdempotent.hs +++ b/Control/LVish/SchedIdempotent.hs @@ -42,7 +42,7 @@ addHandler, liftIO, toss, -- * Internal, private bits. - mkPar, Status(..), sched, Listener(..) + mkPar, Status(..), sched, Listener(..), lvarDbgName ) where import Control.Monad hiding (sequence, join) @@ -226,6 +226,11 @@ ------------------------------------------------------------------------------ -- LVar operations ------------------------------------------------------------------------------ + +-- | Debugging only -- create some kind of printable identifier for +-- the LVar (uses StableName). +lvarDbgName :: LVar a d -> String +lvarDbgName (LVar {state, status}) = (show$ unsafeName state) -- | Create an LVar. newLV :: IO a -> Par (LVar a d) @@ -249,7 +254,7 @@ -- that, if we are not currently above the threshhold, we will have to poll -- /again/ after enrolling the callback. This race may also result in the -- continuation being executed twice, which is permitted by idempotence. - let uniqsuf = ", lv "++(show$ unsafeName state)++" on worker "++(show$ Sched.no q) + let uniqsuf = ", lv "++lvarDbgName lv++" on worker "++(show$ Sched.no q) logWith q 7$ " [dbg-lvish] getLV: first readIORef "++uniqsuf curStatus <- readIORef status @@ -268,7 +273,7 @@ onFreeze = unblockWhen $ globalThresh state True {-# INLINE unblockWhen #-} unblockWhen thresh tok q = do - let uniqsuf = ", lv "++(show$ unsafeName state)++" on worker "++(show$ Sched.no q) + let uniqsuf = ", lv "++(lvarDbgName lv)++" on worker "++(show$ Sched.no q) logWith q 7$ " [dbg-lvish] getLV (active): callback: check thresh"++uniqsuf tripped <- thresh whenJust tripped $ \b -> do @@ -361,8 +366,8 @@ -> (a -> Par (Maybe d, b)) -- ^ how to do the put, and whether the LVar's -- value changed -> Par b -putLV_ LVar {state, status, name} doPut = mkPar $ \k q -> do - let uniqsuf = ", lv "++(show$ unsafeName state)++" on worker "++(show$ Sched.no q) +putLV_ lv@(LVar {state, status, name}) doPut = mkPar $ \k q -> do + let uniqsuf = ", lv "++(lvarDbgName lv)++" on worker "++(show$ Sched.no q) putAfterFrzExn = E.throw$ PutAfterFreezeExn "Attempt to change a frozen LVar" logWith q 8 $ " [dbg-lvish] putLV: initial lvar status read"++uniqsuf fstStatus <- readIORef status @@ -400,8 +405,8 @@ -- | Freeze an LVar (introducing quasi-determinism). -- It is the data structure implementor's responsibility to expose this as quasi-deterministc. freezeLV :: LVar a d -> Par () -freezeLV LVar {name, status} = mkPar $ \k q -> do - let uniqsuf = ", lv "++(show$ unsafeName state)++" on worker "++(show$ Sched.no q) +freezeLV lv@(LVar {name, status}) = mkPar $ \k q -> do + let uniqsuf = ", lv "++(lvarDbgName lv)++" on worker "++(show$ Sched.no q) logWith q 5 $ " [dbg-lvish] freezeLV: atomic modify status to Freezing"++uniqsuf oldStatus <- atomicModifyIORef status $ \s -> (Freezing, s) case oldStatus of @@ -784,7 +789,7 @@ maxWait = 10000 -- nanoseconds timeOut = (3 * 1000 * 1000) -- three seconds, only for debugging. try bkoff | totalWait bkoff >= timeOut = do - error "OVER WAIT" +-- error "busyTakeMVar (debugging): time-out expired for waiting on MVar" -- when dbg $ do tid <- myThreadId -- After we've failed enough times, start complaining: diff --git a/Control/LVish/SchedIdempotentInternal.hs b/Control/LVish/SchedIdempotentInternal.hs --- a/Control/LVish/SchedIdempotentInternal.hs +++ b/Control/LVish/SchedIdempotentInternal.hs @@ -26,7 +26,7 @@ #ifdef CHASE_LEV #warning "Compiling with Chase-Lev work-stealing deque" -import Data.Concurrent.Deque.ChaseLev as CL +import qualified Data.Concurrent.Deque.ChaseLev as CL type Deque a = CL.ChaseLevDeque a newDeque = CL.newQ diff --git a/Data/Concurrent/SkipListMap.hs b/Data/Concurrent/SkipListMap.hs --- a/Data/Concurrent/SkipListMap.hs +++ b/Data/Concurrent/SkipListMap.hs @@ -353,7 +353,7 @@ ] ] loop (Index indm slm) = do ls <- LM.toList indm - strs <- forM [ (i,tup) | i <- [0..] | tup@(k,_) <- ls ] $ -- , startCheck k + strs <- forM [ (i,tup) | i <- [(0::Int)..] | tup@(k,_) <- ls ] $ -- , startCheck k \ (ix, (key, (shortcut::t, val))) -> do -- Peek at the next layer down: {- diff --git a/Data/LVar/CycGraph.hs b/Data/LVar/CycGraph.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/CycGraph.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE ScopedTypeVariables, DataKinds #-} +{-# LANGUAGE KindSignatures, EmptyDataDecls #-} +{-# LANGUAGE NamedFieldPuns, ParallelListComp #-} +{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -O2 #-} + +{-| + +In contrast with "Data.LVar.Memo", this module provides a way to run a computation +for each node of a graph WITH support for cycles. Cycles are explicitly recognized +and then may be handled in an application specific fashion. + + -} + +module Data.LVar.CycGraph + ( + -- * An idiom for fixed point computations + exploreGraph_seq, + Response(..), + + -- * A parallel version + exploreGraph, NodeValue(..), NodeAction, + + -- * Debugging aides + ShortShow(..), shortTwo + ) + where +-- Standard: +import Data.Set (Set) +import Control.Monad +import qualified Data.Set as S +import qualified Data.Map as M +import Data.IORef +import Data.Char (ord) +import Data.List (intersperse) +import Data.Int +import qualified Data.Foldable as F +import System.IO.Unsafe +import Debug.Trace + +-- LVish: +import Control.LVish +import qualified Control.LVish.Internal as LV +import qualified Control.LVish.SchedIdempotent as LI +import Data.LVar.PureSet as IS +import Data.LVar.IVar as IV +import qualified Data.Concurrent.SkipListMap as SLM +import qualified Data.Set as S +import qualified Data.LVar.PureMap as IM +-- import qualified Data.LVar.SLMap as IM +-- import qualified Data.LVar.PureSet as S + +----- For debugging: ---- +#ifdef DEBUG_MEMO +import System.Environment (getEnvironment) +import Data.Graph.Inductive.Graph as G +import Data.Graph.Inductive.PatriciaTree as G +import Data.GraphViz as GV +import qualified Data.GraphViz.Attributes.Complete as GA +import qualified Data.GraphViz.Attributes.Colors as GC +import Data.Text.Lazy (pack) +#endif +-------------------------------------------------------------------------------- +-- Simple atomic Set accumulators +-------------------------------------------------------------------------------- + +-- | Could use a more scalable structure here... but we need union as well as +-- elementwise insertion. +type SetAcc a = IORef (S.Set a) + +-- Here @SetAcc@s are LINKED to downstream SetAcc's which must receive all the same +-- inserts that they do. +-- newtype SetAcc a = SetAcc (IORef (S.Set a, [SetAcc a])) + +newSetAcc :: Par d s (SetAcc a) +newSetAcc = LV.WrapPar $ LI.liftIO $ newIORef S.empty +readSetAcc :: (SetAcc a) -> Par d s (S.Set a) +readSetAcc r = LV.WrapPar $ LI.liftIO $ readIORef r +insertSetAcc :: Ord a => a -> SetAcc a -> Par d s (S.Set a) +insertSetAcc x ref = LV.WrapPar $ LI.liftIO $ + atomicModifyIORef' ref (\ s -> let ss = S.insert x s in (ss,ss)) +unionSetAcc :: Ord a => Set a -> SetAcc a -> Par d s (S.Set a) +unionSetAcc x ref = LV.WrapPar $ LI.liftIO $ + atomicModifyIORef' ref (\ s -> let ss = S.union x s in (ss,ss)) + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +-- | A Memo-table that stores cached results of executing a `Par` computation. +-- +-- This, enhanced, version of the Memo-table also is required to track all the keys +-- that are reachable from each key (for cycle-detection). +data Memo (d::Determinism) s k v = + -- Here we keep both a Ivars of return values, and a set of keys whose computations + -- have traversed through THIS key. If we see a cycle there, we can catch it. +-- !(IM.IMap k s (SetAcc k, IVar s v)) + + Memo !(IS.ISet s k) + -- EXPENSIVE version: + !(IM.IMap k s (NodeRecord s k v)) + -- ^ Store all the keys that we know *can reach this key* + +-- | All the information associated with one node in the graph of keys. +data NodeRecord s k v = NodeRecord + { mykey :: k + , chldrn :: [k] + , reachme :: !(IS.ISet s k) -- ^ Which keys are upstream of me in the graph + , in_cycle :: !(IVar s Bool) -- ^ Does this node participate in any cycle? + , result :: !(IVar s v) -- ^ The result of the per-node computation. + } deriving (Eq) + +-------------------------------------------------------------------------------- +-- Cycle-detecting mapping of a computation over graph neighborhoods +-------------------------------------------------------------------------------- + +-- | A means of building a dynamic graph. The node computation returns a response +-- which may either be a final value, or a request to explore more nodes (together +-- with a continuation for the resulting value). +-- +-- Note that because only one key is requested at a time, this cannot express +-- parallel graph traversals. +data Response par key ans = + Done !ans + | Request !key (RequestCont par key ans) + +type RequestCont par key ans = (ans -> par (Response par key ans)) + +-------------------------------------------------------------------------------- +-- Sequential version: + +-- | This supercombinator does a parallel depth-first search of a dynamic graph, with +-- detection of cycles. +-- +-- Each node in the graph is a computation whose input is the `key` (the vertex ID). +-- Each such computation dynamically computes which other keys it depends on and +-- requests the values associated with those keys. +-- +-- This implementation uses a sequential depth-first-search (DFS), starting from the +-- initially requested key. One can picture this search as a directed tree radiating +-- from the starting key. When a cycle is detected at any leaf of this tree, an +-- alternate cycle handler is called instead of running the normal computation for +-- that key. +exploreGraph_seq :: forall d s k v . (Ord k, Eq v, Show k, Show v) => + (k -> Par d s (Response (Par d s) k v)) -- ^ The computation to perform for new requests + -> (k -> Par d s v) -- ^ Handler for a cycle on @k@. The + -- value it returns is in lieu of running + -- the main computation at this + -- particular node in the graph. + -> k -- ^ Key to lookup. + -> Par d s v +exploreGraph_seq initCont cycHndlr initKey = do + -- Start things off: + resp <- initCont initKey + v <- loop initKey (S.singleton initKey) resp return + return v + where + loop :: k -> S.Set k -> (Response (Par d s) k v) -> (v -> Par d s v) -> Par d s v + loop current hist resp kont = do + dbgPr (" [MemoFixedPoint] going around loop, key "++showID current++", hist size "++show (S.size hist)) + case resp of + Done ans -> do dbgPr (" !! Final result, answer "++show ans) + kont ans + Request key2 newCont + -- Here we have hit a cycle, and label it as such for the CURRENT node. + | S.member key2 hist -> do + dbgPr (" Stopping before hitting a cycle on "++showID key2++", call cycHndlr on "++showID current) + ans <- cycHndlr current + kont ans + | otherwise -> do + dbgPr (" Requesting child computation with key "++showWID key2) + resp' <- initCont key2 + loop key2 (S.insert key2 hist) resp' $ \ ans2 -> do + dbgPr (" DONE blocking on child key, cont invoked with answer: "++show ans2) + resp'' <- newCont ans2 + -- Popping back to processing the current key, which may not be finished. + loop current hist resp'' kont + +-- -- if wasloop then do +-- if False then do +-- -- Here the child computation ended up being processed as a cycle, so we must be as well: +-- dbgPr (" Child comp "++showID key2++" of "++showID current++" hit a cycle...") +-- ans3 <- cycHndlr current +-- kont (True,ans3) + + +-------------------------------------------------------------------------------- + +type IsCycle = Bool + +-- | The handler at a particular node (key) in the graph. This takes as argument a +-- key, along with a boolean indicating whether the current node has been found to +-- be part of a cycle. +-- +-- Also, for each child node, this handler is provided a way to demand the +-- resulting value of that child node, plus an indication of whether the child node +-- participates in a cycle. +-- +-- Finally, this handler is expected to produce a value which becomes associated +-- with the key. +type NodeAction d s k v = +-- Bool -> k -> [(Bool,Par d s v)] -> Par d s v + IsCycle -> k -> [(k,IsCycle,IV.IVar s v)] -> Par d s (NodeValue k v) + -- One thing that's missing here is WHICH child node(s) puts us in a cycle. + +-- | At the end of the handler execution, the value of a node is either ready, or it +-- is instead deferred to be exactly the value provided by another key. +data NodeValue k v = FinalValue !v | Defer k + deriving (Show,Eq,Ord) + + +-- | This combinator provides parallel exploration of a graph that contains cycles. +-- The limitation is that the work to be performed at each node (`NodeAction`) is not +-- invoked until the graph is fully traversed, i.e. after a barrier. Thus the graph +-- explored is not a "dynamic graph" in the sense of being computed on the fly by the +-- `NodeAction`. +-- +-- The algorithm used in this function is fairly expensive. For each node, it uses a +-- monotonic data structure to track the full set of other nodes that can reach it in +-- the graph. +#ifdef DEBUG_MEMO +exploreGraph :: forall s k v . (Ord k, Eq v, ShortShow k, Show v) => +#else +exploreGraph :: forall s k v . (Ord k, Eq v, Show k, Show v) => +#endif + (k -> Par QuasiDet s [k]) -- ^ Sketch the graph: map a key onto its children. + -> NodeAction QuasiDet s k v -- ^ The computation to run at each graph node. + -> k -- ^ The initial node (key) from which to explore. + -> Par QuasiDet s v +exploreGraph keyNbrs nodeHndlr initKey = do + + -- First: propogate key requests. + -- This will not diverge because the Set here suppressed duplicate callbacks: + set <- IS.newEmptySet + -- The map stores results: + mp <- IM.newEmptyMap + + keywalkHP <- newPool + + IS.forEachHP (Just keywalkHP) set $ \ key0 -> do + dbgPr ("![MemoFixedPoint] Start new key "++show key0) + -- Make some empty space for results: + key0_res <- IV.new + key0_cycle <- IV.new + key0_reach <- IS.newEmptySet + -- Next fetch the child node identities: + child_keys <- keyNbrs key0 + IM.insert key0 (NodeRecord key0 child_keys key0_reach key0_cycle key0_res) mp + dbgPr (" Computed nbrs of "++showID key0++" to be: "++ (showIDs child_keys)) + + case child_keys of + [] -> return () -- IV.put_ key0_cycle False + _ -> do + -- Spawn traversals of child nodes: + forM_ child_keys (`IS.insert` set) + + -- Establish the (expensive) cycle-checker handler: + IS.forEachHP (Just keywalkHP) key0_reach $ \ key1 -> + when (key1 == key0) $ do + dbgPr (" !! Cycle detected on key "++showID key0) + IV.put_ key0_cycle True + + -- Now we must wait for records to come up, and establish ourselves as upstream + -- of each child: + chldrecs <- forM child_keys $ \child -> do + nrec@NodeRecord{reachme} <- IM.getKey child mp + IS.insert key0 reachme -- Child is reachable from us. + -- Further, what reaches us, reaches the child: + copyTo keywalkHP key0_reach reachme + dbgPr (" Inserted ourselves ("++showID key0++") in reachme list of child: "++showID child) + return nrec + + -- If all our children are do not participate in a cycle, neither do we. + -- fork $ let loop [] = IV.put_ key0_cycle False + -- loop (NodeRecord{in_cycle}:tl) = do + -- bl <- IV.get in_cycle + -- case bl of + -- True -> return () + -- False -> loop tl + -- in loop chldrecs + -- FINISHME: If we have some cycle children and some leafish ones.... + -- then we may need to do an unsafe peek at our reachme set, no? + return () + + IS.insert initKey set + quiesce keywalkHP + -- fset <- IS.freezeSet set + frmap <- IM.freezeMap mp + + dbgPr ("Froze map: "++show (M.keys frmap)) + + -- TODO: need parallel traversable: + let getcyc vr = do mb <- IV.freezeIVar vr + if mb == Just True + then return True + else return False + showCyc bl = if bl then "cycle" else "Nocyc" + fn NodeRecord{mykey, chldrn, reachme,in_cycle=mecyc,result=myres} () = fork$ do + bl <- getcyc mecyc + bls <- mapM (getcyc . in_cycle . (frmap #)) chldrn + dbgPr (" !! Invoking node handler at key "++showID mykey++" "++ + showCyc bl ++" chldrn "++concat (intersperse " "$ map showCyc bls)) + x <- nodeHndlr bl mykey [ (k, b, result (frmap # k)) | b <- bls + | k <- chldrn ] + case x of + FinalValue vv -> do + dbgPr (" !! Writing result into key "++showID mykey++" value: "++show x) + IV.put_ myres vv + Defer tokey -> do dbgPr (" !! No result yet on key "++showID mykey++", DEFERing to key "++showID tokey) + fork $ do kv <- IV.get (result(frmap # tokey)) + dbgPr (" .. Delegated key "++showID tokey++", of key "++showID mykey++" produced result: "++show kv) + IV.put_ myres kv + F.foldrM fn () frmap + + let NodeRecord{result} = frmap # initKey + final <- IV.get result + ------------------------------------------------------------ + -- TEMP: Debugging + ------------------------------------------------------------ +#ifdef DEBUG_MEMO + when (dbg_lvl >= 4) $ do + dbgPr ("| START creating dot graph...") + dg <- debugVizMemoGraph True initKey frmap + unsafePerformIO (GV.runGraphviz dg GV.Pdf "MemoCyc_short.pdf") + `seq` return () + dg <- debugVizMemoGraph False initKey frmap + unsafePerformIO (GV.runGraphviz dg GV.Pdf "MemoCyc.pdf") + `seq` return () + dbgPr ("| DONE creating dot graph...") +#endif + ------------------------------------------------------------ + return final +-- return $! Memo set mp + +{- + + +-- | This version watches for, and catches, cyclic requests to the memotable that +-- would normally diverge. Once caught, the user specifies what to do with these +-- cycles by providing a handler. The handler is called on the key which formed the +-- cycle. That is, computing the invocation spawned by that key results in a demand +-- for that key. +makeMemoCyclic :: (MemoTable d s a b -> a -> Par d s b) -> (a -> Par d s b) -> Par d s (MemoTable d s a b) +makeMemoCyclic normalFn ifCycle = undefined +-- FIXME: Are there races where more than one cycle can be hit? Can we guarantee +-- that all are hit? + + + +-- | Cancel an outstanding speculative computation. This recursively attempts to +-- cancel any downstream computations in this or other memo-tables that are children +-- of the given `MemoFuture`. +cancel :: MemoFuture Det s b -> Par Det s () +-- FIXME: Det needs to be replaced here with "GetOnly". +cancel fut = undefined + +-} + +-------------------------------------------------------------------------------- +-- Misc Helpers and Utilities +-------------------------------------------------------------------------------- + +(#) :: (Ord a1, Show a1) => M.Map a1 a -> a1 -> a +m # k = case M.lookup k m of + Nothing -> error$ "Key was missing from map: "++show k + Just x -> x + +showMapContents :: (Eq t1, Show a, Show a1) => IM.IMap a1 s (IORef (Set a), IV.IVar t t1) -> IO String +showMapContents (IM.IMap lv) = do + mp <- readIORef (LV.state lv) + let lst = M.toList mp + return$ " Map Contents: (length "++ show (length lst) ++")\n" ++ + concat [ " "++fullempt++" "++showWID k++" -> "++vals++"\n" + | (k,(v,IV.IVar ivr)) <- lst +-- , let vals = "hello" + , let lst = S.toList $ unsafePerformIO (readIORef v) + , let vals = "#"++show (length lst)++"["++ (concat $ intersperse ", " $ map showID lst) ++"]" + , let fullempt = if Nothing == unsafePerformIO (readIORef (LV.state ivr)) + then "[empty]" + else "[full]" + ] + +showMapContents2 :: (Eq t3, Show t1, Show a) => IM.IMap a s (ISet t t1, IV.IVar t2 t3) -> IO String +showMapContents2 (IM.IMap lv) = do + mp <- readIORef (LV.state lv) + let lst = M.toList mp + return$ " Map Contents: (length "++ show (length lst) ++")\n" ++ + concat [ " "++fullempt++" "++showWID k++" -> "++vals++"\n" + | (k,(IS.ISet setlv, IV.IVar ivr)) <- lst +-- , let vals = "hello" + , let lst = S.toList $ unsafePerformIO (readIORef (LV.state setlv)) + , let vals = "#"++show (length lst)++"["++ (concat $ intersperse ", " $ map showID lst) ++"]" + , let fullempt = if Nothing == unsafePerformIO (readIORef (LV.state ivr)) + then "[empty]" + else "[full]" + ] + +-- | Variant of `union` that optionally ties the handlers in the resulting set to the same +-- handler pool as those in the two input sets. +copyTo :: Ord a => HandlerPool -> IS.ISet s a -> IS.ISet s a -> Par d s () +copyTo hp sfrom sto = do + IS.forEachHP (Just hp) sfrom (`insert` sto) + +{-# INLINE dbgPr #-} +dbgPr :: Monad m => String -> m () +#ifdef DEBUG_MEMO +dbgPr s | dbg_lvl >= 1 = trace s (return ()) + | otherwise = return () +#else +dbgPr _ = return () +#endif + +showWID :: Show a => a -> String +showWID x = let str = (show x) in + if length str < 10 + then str + else showID x++"__"++str + +showID :: Show a => a -> String +showID x = let str = (show x) in + if length str < 10 then str + else (show (length str))++"-"++ show (checksum str) + +showIDs ls = ("{"++(concat$ intersperse ", " $ map showID ls)++"}") + +checksum :: String -> Int +checksum str = sum (map ord str) + + +-------------------------------------------------------------------------------- +-- DEBUGGING +-------------------------------------------------------------------------------- + +-- | A show class that tries to stay under a budget. +class Show t => ShortShow t where + shortShow :: Int -> t -> String + shortShow n x = take n (show x) + +instance ShortShow Bool where + shortShow 1 True = "t" + shortShow 1 False = "f" + shortShow 2 True = "#t" + shortShow 2 False = "#f" + shortShow n b = take n (show b) + +instance ShortShow Integer where shortShow = shortShowNum +instance ShortShow Int where shortShow = shortShowNum +instance ShortShow Int8 where shortShow = shortShowNum +instance ShortShow Int16 where shortShow = shortShowNum +instance ShortShow Int32 where shortShow = shortShowNum +instance ShortShow Int64 where shortShow = shortShowNum + +shortShowNum :: Show a => Int -> a -> String +shortShowNum n num = + let str = show num + len = length str in + if len > n then + (take (n-2) str)++".." + else str + +instance ShortShow String where + shortShow n str = + let len = length str in + if len > 2 && n ==2 + then ".." + else if len > 1 && n == 1 + then "?" + else take n str + +instance (ShortShow a, ShortShow b) => ShortShow (a,b) where + shortShow 1 _ = "?" + shortShow 2 _ = ".." + shortShow n (a,b) = let (l,r) = shortTwo (n-3) a b + in "("++ l ++","++ r ++")" + +-- | Combine two things within a given size budget. +shortTwo :: (ShortShow t, ShortShow t1) => Int -> t -> t1 -> (String, String) +-- this could be better... +shortTwo n a b = (left, shortShow (half+remain) b) + where + remain = abs (half - length left) + left = shortShow half a + (q,r) = quotRem (abs(n-3)) 2 + half = q + r + +-------------------------------------------------------------------------------- + +#ifdef DEBUG_MEMO + +-- | Debugging flag shared by all accelerate-backend-kit modules. +-- This is activated by setting the environment variable DEBUG=1..5 +dbg_lvl :: Int +dbg_lvl = case lookup "DEBUG" theEnv of + Nothing -> defaultDbg + Just "" -> defaultDbg + Just "0" -> defaultDbg + Just s -> + trace (" ! Responding to env Var: DEBUG="++s)$ + case reads s of + ((n,_):_) -> n + [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s + +theEnv :: [(String, String)] +theEnv = unsafePerformIO getEnvironment + +defaultDbg :: Int +defaultDbg = 0 + +debugVizMemoGraph :: forall s t t1 t2 . (Ord t1, ShortShow t1, Show t2, F.Foldable t) => + Bool -- ^ Use shorter `showID` for keys. + -> t1 -- ^ The inital key. + -> t (NodeRecord s t1 t2) -- ^ A frozen map of graph nodes. +-- Par d s (Gr (Bool,String) ()) + -> Par QuasiDet s (GV.DotGraph G.Node) +debugVizMemoGraph idOnly initKey frmap = do + let showKey = if idOnly then showID + else shortShow 40 + let gcons :: NodeRecord s t1 t2 + -> (M.Map t1 G.Node, G.Gr (Bool,t1,t2) ()) + -> Par QuasiDet s (M.Map t1 G.Node, G.Gr (Bool,t1,t2) ()) + gcons NodeRecord{mykey, in_cycle,result} + (labmap, gracc) = do + dbgPr (" .. About to wait for node result, key "++show mykey) + res <- IV.get result + dbgPr (" .. About to wait for node in_cycle, key "++show mykey) + cyc <- IV.freezeIVar in_cycle + let num = 1 + G.noNodes gracc + gr' = G.insNode (num, (cyc == Just True,mykey,res)) $ + gracc + labmap' = M.insert mykey num labmap + return (labmap',gr') + + gedges :: NodeRecord s t1 t2 + -> (M.Map t1 G.Node, G.Gr (Bool,t1,t2) ()) + -> Par d s (M.Map t1 G.Node, G.Gr (Bool,t1,t2) ()) + gedges NodeRecord{mykey, chldrn } + (labmap, gracc) = do + let chldnodes = map (labmap #) chldrn + num = labmap # mykey + gr' = G.insEdges [ (num,cnd::Int,()) | cnd <- chldnodes ] $ + gracc + labmap' = M.insert mykey num labmap + return (labmap',gr') + + dbgPr (" !! Creating graphviz graph from MemoCyc map of size "++show (F.foldr (\ _ n -> 1+n) 0 frmap)) +-- dbgPr (" !! All keys "++show frmap) + + -- Two passes, first add nodes, then edges: + (lm,graph0) <- F.foldrM gcons (M.empty, G.empty) frmap + dbgPr (" .. Added all nodes to the graph...") + (_,graph) <- F.foldrM gedges (lm, graph0) frmap + dbgPr (" .. Added all edges to the graph...") + let -- dg = graphToDot nonClusteredParams graph + myparams :: GV.GraphvizParams G.Node (Bool,t1,t2) () () (Bool,t1,t2) + myparams = GV.defaultParams { GV.fmtNode= nodeAttrs } + + nodeAttrs :: (Int, (Bool,t1,t2)) -> [GA.Attribute] +-- nodeAttrs :: (Int, String) -> [GA.Attribute] + nodeAttrs (_num, (cyc,key,res)) = + let lbl = showKey key++"\n=> "++ show res in + [ GA.Label$ GA.StrLabel $ pack lbl ] ++ + (if key == initKey + then [GA.Color [weighted$ GA.X11Color GV.Red]] + else []) ++ + (if cyc then [] + else [GA.Shape GA.BoxShape]) + + dg = GV.graphToDot myparams graph -- (G.nmap uid graph) + return dg + +weighted c = GC.WC {GC.wColor=c, GC.weighting=Nothing} + +#endif +-- End DEBUG_MEMO diff --git a/Data/LVar/Generic/Internal.hs b/Data/LVar/Generic/Internal.hs --- a/Data/LVar/Generic/Internal.hs +++ b/Data/LVar/Generic/Internal.hs @@ -41,6 +41,9 @@ -- parameter, as well as an `s` parameter for session safety. -- -- LVars that fall into this class are typically collection types. +-- +-- The superclass constraint on this class serves to ensure that once frozen, the +-- LVar contents are foldable. class (F.Foldable (f Trvrsbl)) => LVarData1 (f :: * -> * -> *) -- TODO: if there is a Par class to generalize LVar Par monads, then -- it needs to be a superclass of this. diff --git a/Data/LVar/Internal/Pure.hs b/Data/LVar/Internal/Pure.hs --- a/Data/LVar/Internal/Pure.hs +++ b/Data/LVar/Internal/Pure.hs @@ -23,7 +23,7 @@ ( PureLVar(..), newPureLVar, putPureLVar, - waitPureLVar, freezePureLVar, + waitPureLVar, freezePureLVar, fromPureLVar, getPureLVar, unsafeGetPureLVar, -- * Verifying lattice structure @@ -37,7 +37,7 @@ import qualified Control.LVish.SchedIdempotent as LI import Algebra.Lattice import GHC.Prim (unsafeCoerce#) -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) -------------------------------------------------------------------------------- -- | An LVar which consists merely of an immutable, pure value inside a mutable box. @@ -180,6 +180,12 @@ globalThresh _ False = return Nothing deltaThresh _ = return Nothing +-- | Read the exact contents of an already frozen PureLVar. +fromPureLVar :: PureLVar Frzn t -> t +fromPureLVar (PureLVar lv) = + unsafeDupablePerformIO $ readIORef $ state lv + + ------------------------------------------------------------ -- | Physical identity, just as with `IORef`s. @@ -196,4 +202,5 @@ frz = unsafeCoerce# -- FIXME: need an efficient way to extract the logger and capture it in the callbacks: +logDbgLn_ :: Int -> String -> IO () logDbgLn_ _ _ = return () diff --git a/Data/LVar/PureMap.hs b/Data/LVar/PureMap.hs --- a/Data/LVar/PureMap.hs +++ b/Data/LVar/PureMap.hs @@ -146,7 +146,7 @@ -- -- Unfortunately, that means that this takes another computation for creating new -- \"bottom\" elements for the nested LVars stored inside the `IMap`. -modify :: forall f a b d s key . (Ord key, LVarData1 f, Show key, Ord a) => +modify :: forall f a b d s key . (Ord key, Show key, Ord a) => IMap key s (f s a) -> key -- ^ The key to lookup. -> (Par d s (f s a)) -- ^ Create a new \"bottom\" element whenever an entry is not present. @@ -175,7 +175,7 @@ {-# INLINE gmodify #-} -- | A generic version of `modify` that does not require a `newBottom` argument, -- rather, it uses the generic version of that function. -gmodify :: forall f a b d s key . (Ord key, LVarData1 f, LVarWBottom f, LVContents f a, Show key, Ord a) => +gmodify :: forall f a b d s key . (Ord key, LVarWBottom f, LVContents f a, Show key, Ord a) => IMap key s (f s a) -> key -- ^ The key to lookup. -> (f s a -> Par d s b) -- ^ The computation to apply on the right-hand side of the keyed entry. diff --git a/Data/LVar/SLMap.hs b/Data/LVar/SLMap.hs --- a/Data/LVar/SLMap.hs +++ b/Data/LVar/SLMap.hs @@ -238,7 +238,7 @@ -- existing entries (monotonically). Further, this `modify` function implicitly -- inserts a \"bottom\" element if there is no existing entry for the key. -- -modify :: forall f a b d s key . (Ord key, LVarData1 f, Show key, Ord a) => +modify :: forall f a b d s key . (Ord key, Show key, Ord a) => IMap key s (f s a) -> key -- ^ The key to lookup. -> (Par d s (f s a)) -- ^ Create a new \"bottom\" element whenever an entry is not present. diff --git a/Data/LVar/SatMap.hs b/Data/LVar/SatMap.hs new file mode 100644 --- /dev/null +++ b/Data/LVar/SatMap.hs @@ -0,0 +1,512 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} + +{-| + + Saturating maps. These store pure (joinable) values, but when a + join fails the map fails (saturates), after which it requires only a + small, constant amount of memory. + + -} + +module Data.LVar.SatMap + {-( + -- * Basic operations + SatMap(..), + newEmptyMap, newMap, newFromList, + insert, + + -- * Generic routines and convenient aliases + gmodify, getOrInit, + + -- * Iteration and callbacks + forEach, forEachHP, + withCallbacksThenFreeze, + + -- * Quasi-deterministic operations + freezeMap, fromIMap, + traverseFrzn_, + + -- * Higher-level derived operations + copy, traverseMap, traverseMap_, union, + + -- * Alternate versions of derived ops that expose @HandlerPool@s they create + traverseMapHP, traverseMapHP_, unionHP + )-} where + +-- import Algebra.Lattice +-- import Algebra.Lattice.Dropped +import Control.LVish.DeepFrz.Internal +import Control.LVish.DeepFrz (runParThenFreeze) +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.SatMap.Unsafe +import Data.UtilInternal (traverseWithKey_) + +import Control.Exception (throw) +import Data.List (intersperse) +import Data.IORef +import qualified Data.Map.Strict as M +import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) +import System.Mem.StableName (makeStableName, hashStableName) + +import Control.Applicative ((<$>)) +import qualified Data.Foldable as F +import Data.LVar.Generic.Internal (unsafeCoerceLVar) + +#ifdef GENERIC_PAR +-- From here we get a Generator and, in the future, ParFoldable instance for Map: +import Data.Par.Map () + +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 + +-- | A partial version of "Algebra.Lattice.JoinSemiLattice", this +-- could be made into a complete lattice by the addition of a top +-- element. +class PartialJoinSemiLattice a where + joinMaybe :: a -> a -> Maybe a + +-- -- | Adding a top element makes the partial join total: +-- instance PartialJoinSemiLattice a => JoinSemiLattice (Dropped a) where +-- join a b = +-- case joinMaybe a b of +-- Nothing -> Top +-- Just x -> Drop x + +------------------------------------------------------------------------------ +-- DUPLICATED from PureMap: +------------------------------------------------------------------------------ + +-- | The map datatype itself. Like all other LVars, it has an @s@ parameter (think +-- `STRef`) in addition to the @a@ parameter that describes the type of elements +-- in the set. +-- +-- Performance note: There is only /one/ mutable location in this implementation. Thus +-- it is not a scalable implementation. +newtype SatMap k s v = SatMap (LVar s (IORef (SatMapContents k v)) (k,v)) + -- SatMap { lvar :: (LVar s (IORef (Maybe (M.Map k v))) (k,v)) + -- , onSat :: L.Par () } + +type SatMapContents k v = Maybe (M.Map k v, OnSat) + +-- | Callback to execute when saturating occurs. +type OnSat = L.Par () + +-- | Equality is physical equality, as with @IORef@s. +instance Eq (SatMap k s v) where + SatMap lv1 == SatMap lv2 = state lv1 == state lv2 + +-- | An `SatMap` can be treated as a generic container LVar. However, the polymorphic +-- operations are less useful than the monomorphic ones exposed by this module. +instance LVarData1 (SatMap k) where + freeze orig@(SatMap (WrapLVar lv)) = WrapPar$ do freezeLV lv; return (unsafeCoerceLVar orig) + -- Unlike the Map-specific forEach variants, this takes only values, not keys. + addHandler mh mp fn = forEachHP mh mp (\ _k v -> fn v) + sortFrzn (SatMap lv) = + case unsafeDupablePerformIO (readIORef (state lv)) of + Nothing -> AFoldable [] -- Map saturated, contents are empty. + Just (m,_) -> AFoldable m + +-- | The `SatMap`s in this module also have the special property that they support an +-- /O(1)/ freeze operation which immediately yields a `Foldable` container +-- (`snapFreeze`). +instance OrderedLVarData1 (SatMap k) where + snapFreeze is = unsafeCoerceLVar <$> freeze is + +-- | As with all LVars, after freezing, map elements can be consumed. In +-- the case of this `SatMap` implementation, it need only be `Frzn`, not +-- `Trvrsbl`. +instance F.Foldable (SatMap k Frzn) where + foldr fn zer (SatMap lv) = + let mp = unsafeDupablePerformIO (readIORef (state lv)) in + case mp of + Nothing -> zer + Just (m,_) -> F.foldr fn zer m + +-- Of course, the stronger `Trvrsbl` state is still fine for folding. +instance F.Foldable (SatMap k Trvrsbl) where + foldr fn zer mp = F.foldr fn zer (castFrzn mp) + +-- `SatMap` values can be returned as the result of a +-- `runParThenFreeze`. Hence they need a `DeepFrz` instance. +-- @DeepFrz@ is just a type-coercion. No bits flipped at runtime. +instance DeepFrz a => DeepFrz (SatMap k s a) where +-- type FrzType (SatMap k s a) = SatMap k Frzn (FrzType a) + type FrzType (SatMap k s a) = SatMap k Frzn a -- No need to recur deeper. + frz = unsafeCoerceLVar + +instance (Show k, Show a) => Show (SatMap k Frzn a) where + show (SatMap lv) = + let mp' = unsafeDupablePerformIO (readIORef (state lv)) + contents = case mp' of + Nothing -> "saturated" + Just (m,_) -> concat $ intersperse ", " $ map show $ M.toList m + in "{IMap: " ++ contents ++ "}" + +-- | For convenience only; the user could define this. +instance (Show k, Show a) => Show (SatMap k Trvrsbl a) where + show lv = show (castFrzn lv) + + +-- | Add an (asynchronous) callback that listens for all new key/value pairs added to +-- the map, optionally enrolled in a handler pool. +forEachHP :: Maybe HandlerPool -- ^ optional pool to enroll in + -> SatMap k s v -- ^ Map to listen to + -> (k -> v -> Par d s ()) -- ^ callback + -> Par d s () +forEachHP mh (SatMap (WrapLVar lv)) callb = WrapPar $ do + L.addHandler mh lv globalCB deltaCB + return () + where + deltaCB (k,v) = return$ Just$ unWrapPar $ callb k v + globalCB ref = do + mp <- L.liftIO $ readIORef ref -- Snapshot + case mp of + Nothing -> return () -- Already saturated, nothing to do. + Just (m,_) -> unWrapPar $ + traverseWithKey_ (\ k v -> forkHP mh$ callb k v) m + +-------------------------------------------------------------------------------- + +-- | Create a fresh map with nothing in it. +newEmptyMap :: Par d s (SatMap k s v) +newEmptyMap = WrapPar$ fmap (SatMap . WrapLVar) $ newLV$ newIORef (Just (M.empty, return ())) + +-- | Create a new map populated with initial elements. +newMap :: M.Map k v -> Par d s (SatMap k s v) +newMap m = WrapPar$ fmap (SatMap . WrapLVar) $ newLV$ newIORef (Just (m,return())) + +-- | A convenience function that is equivalent to calling `Data.Map.fromList` +-- followed by `newMap`. +newFromList :: (Ord k, Eq v) => + [(k,v)] -> Par d s (SatMap k s v) +newFromList = newMap . M.fromList + +-- | Register a per-element callback, then run an action in this context, and freeze +-- when all (recursive) invocations of the callback are complete. Returns the final +-- value of the provided action. +withCallbacksThenFreeze :: forall k v b s . Eq b => + SatMap k s v -> (k -> v -> QPar s ()) -> QPar s b -> QPar s b +withCallbacksThenFreeze (SatMap (WrapLVar lv)) callback action = + do hp <- newPool + res <- IV.new + WrapPar$ freezeLVAfter lv (initCB hp res) deltaCB + -- We additionally have to quiesce here because we fork the inital set of + -- callbacks on their own threads: + quiesce hp + IV.get res + where + deltaCB (k,v) = return$ Just$ unWrapPar $ callback k v + initCB :: HandlerPool -> IV.IVar s b -> (IORef (SatMapContents k v)) -> L.Par () + initCB hp resIV ref = do + -- The implementation guarantees that all elements will be caught either here, + -- or by the delta-callback: + mp <- L.liftIO $ readIORef ref -- Snapshot + case mp of + Nothing -> return () -- Already saturated, nothing to do. + Just (m,_) -> unWrapPar $ do + traverseWithKey_ (\ k v -> forkHP (Just hp)$ callback k v) m + res <- action -- Any additional puts here trigger the callback. + IV.put_ resIV res + +-- | Add an (asynchronous) callback that listens for all new new key/value pairs added to +-- the map. +forEach :: SatMap k s v -> (k -> v -> Par d s ()) -> Par d s () +forEach = forEachHP Nothing + +-- | Put a single entry into the map. Strict (WHNF) in the key and value. +-- +-- As with other container LVars, if a key is inserted multiple times, the values had +-- better be equal @(==)@, or a multiple-put error is raised. +insert :: (Ord k, PartialJoinSemiLattice v, Eq v) => + k -> v -> SatMap k s v -> Par d s () +insert !key !elm (SatMap (WrapLVar lv)) = WrapPar$ do + -- OPTIONAL: Take the fast path if it is saturated: + snap <- L.liftIO (readIORef (L.state lv)) + case snap of + Nothing -> return () -- Fizzle. + Just _ -> putLV_ lv putter + where -- putter :: _ -> L.Par (Maybe d,b) + putter ref = do + -- TODO: try optimistic CAS version. + (x,act) <- L.liftIO$ atomicModifyIORef' ref update + case act of + Nothing -> return () + Just a -> do L.logStrLn 5 $ " [SatMap] insert saturated lvar "++lvid++", running callback." + a + L.logStrLn 5 $ " [SatMap] lvar "++lvid++", saturation callback completed." + return (x,()) + + lvid = L.lvarDbgName lv + + delt x = (x,Nothing) + update Nothing = (Nothing,delt Nothing) -- Ignored on saturated LVar. + update orig@(Just (mp,onsat)) = + case M.lookup key mp of -- A bit painful... double lookup on normal inserts. + Nothing -> (Just (M.insert key elm mp, onsat), + delt (Just (key,elm))) + Just oldVal -> + case joinMaybe elm oldVal of + Just newVal -> if newVal == oldVal + then (orig, delt Nothing) -- No change + else (Just (M.insert key newVal mp, onsat), + delt (Just (key,newVal))) + Nothing -> -- Here we SATURATE! + (Nothing, (Nothing, Just onsat)) + +-- | Register a callback that is only called if the SatMap LVar +-- becomes /saturated/. +whenSat :: SatMap k s v -> Par d s () -> Par d s () +whenSat (SatMap lv) (WrapPar newact) = WrapPar $ do + L.logStrLn 5 " [SatMap] whenSat issuing atomicModifyIORef on state" + x <- L.liftIO $ atomicModifyIORef' (state lv) fn + case x of + Nothing -> L.logStrLn 5 " [SatMap] whenSat: not yet saturated, registered only." + Just a -> do L.logStrLn 5 " [SatMap] whenSat invoking saturation callback..." + a + where + fn :: SatMapContents k v -> (SatMapContents k v, Maybe (L.Par ())) + -- In this case we register newact to execute later: + fn (Just (mp,onsat)) = let onsat' = onsat >> newact in + (Just (mp,onsat'), Nothing) + -- In this case we execute newact right away: + fn Nothing = (Nothing, Just newact) + +-- | Drive the variable to top. This is equivalent to an insert of a +-- conflicting binding. +saturate :: SatMap k s v -> Par d s () +saturate (SatMap lv) = WrapPar $ do + let lvid = L.lvarDbgName $ unWrapLVar lv + L.logStrLn 5 $ " [SatMap] saturate: explicity saturating lvar "++lvid + act <- L.liftIO $ atomicModifyIORef' (state lv) fn + case act of + Nothing -> L.logStrLn 5 $" [SatMap] saturate: done saturating lvar "++lvid++", no callbacks to invoke." + Just a -> do L.logStrLn 5 $" [SatMap] saturate: done saturating lvar "++lvid++". Now invoking callback." + a + where + fn (Just (mp,onsat)) = (Nothing, Just onsat) + fn Nothing = (Nothing,Nothing) + + +{- + +-- | `SatMap`s containing other LVars have some additional capabilities compared to +-- those containing regular Haskell data. In particular, it is possible to modify +-- existing entries (monotonically). Further, this `modify` function implicitly +-- inserts a \"bottom\" element if there is no existing entry for the key. +-- +-- Unfortunately, that means that this takes another computation for creating new +-- \"bottom\" elements for the nested LVars stored inside the `SatMap`. +modify :: forall f a b d s key . (Ord key, Show key, Ord a) => + SatMap key s (f s a) + -> key -- ^ The key to lookup. + -> (Par d s (f s a)) -- ^ Create a new \"bottom\" element whenever an entry is not present. + -> (f s a -> Par d s b) -- ^ The computation to apply on the right-hand side of the keyed entry. + -> Par d s b +modify (SatMap 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 + +{-# INLINE gmodify #-} +-- | A generic version of `modify` that does not require a `newBottom` argument, +-- rather, it uses the generic version of that function. +gmodify :: forall f a b d s key . (Ord key, LVarWBottom f, LVContents f a, Show key, Ord a) => + SatMap key s (f s a) + -> key -- ^ The key to lookup. + -> (f s a -> Par d s b) -- ^ The computation to apply on the right-hand side of the keyed entry. + -> Par d s b +gmodify map key fn = modify map key G.newBottom fn + + + +-- | Get the exact contents of the map. As with any +-- quasi-deterministic operation, using `freezeMap` may cause your +-- program to exhibit a limited form of nondeterminism: it will never +-- return the wrong answer, but it may include synchronization bugs +-- that can (nondeterministically) cause exceptions. +-- +-- This "Data.Map"-based implementation has the special property that +-- you can retrieve the full map without any `IO`, and without +-- nondeterminism leaking. (This is because the internal order is +-- fixed for the tree-based representation of maps that "Data.Map" +-- uses.) +freezeMap :: SatMap k s v -> QPar s (M.Map k v) +freezeMap (SatMap (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 + +-} + +-- | /O(1)/: Convert from an `SatMap` to a plain `Data.Map`. +-- This is only permitted when the `SatMap` has already been frozen. +-- This is useful for processing the result of `Control.LVish.DeepFrz.runParThenFreeze`. +fromIMap :: SatMap k Frzn a -> Maybe (M.Map k a) +fromIMap (SatMap lv) = unsafeDupablePerformIO $ do + x <- readIORef (state lv) + case x of + Just (m,_) -> return $! Just m + Nothing -> return $ Nothing + +{- + +-- | Traverse a frozen map for side effect. This is useful (in comparison with more +-- generic operations) because the function passed in may see the key as well as the +-- value. +traverseFrzn_ :: (Ord k) => + (k -> a -> Par d s ()) -> SatMap k Frzn a -> Par d s () +traverseFrzn_ fn mp = + traverseWithKey_ fn (fromIMap mp) + +-------------------------------------------------------------------------------- +-- Higher level routines that could (mostly) be defined using the above interface. +-------------------------------------------------------------------------------- + +-- | Establish a monotonic map between the input and output sets. +-- Produce a new result based on each element, while leaving the keys +-- the same. +traverseMap :: (Ord k, Eq b) => + (k -> a -> Par d s b) -> SatMap k s a -> Par d s (SatMap k s b) +traverseMap f s = traverseMapHP Nothing f s + +-- | An imperative-style, in-place version of 'traverseMap' that takes the output set +-- as an argument. +traverseMap_ :: (Ord k, Eq b) => + (k -> a -> Par d s b) -> SatMap k s a -> SatMap k s b -> Par d s () +traverseMap_ f s o = traverseMapHP_ Nothing f s o + +-- | Return a new map which will (ultimately) contain everything in either input +-- map. Conflicting entries will result in a multiple put exception. +union :: (Ord k, Eq a) => SatMap k s a -> SatMap k s a -> Par d s (SatMap k s a) +union = unionHP Nothing + +-- TODO: Intersection + +-------------------------------------------------------------------------------- +-- Alternate versions of functions that EXPOSE the HandlerPools +-------------------------------------------------------------------------------- + +-- | Return a fresh map which will contain strictly more elements than the input. +-- That is, things put in the former go in the latter, but not vice versa. +copy :: (Ord k, Eq v) => SatMap k s v -> Par d s (SatMap k s v) +copy = traverseMap (\ _ x -> return x) + +-- | A variant of `traverseMap` that optionally ties the handlers to a pool. +traverseMapHP :: (Ord k, Eq b) => + Maybe HandlerPool -> (k -> a -> Par d s b) -> SatMap k s a -> + Par d s (SatMap k s b) +traverseMapHP mh fn set = do + os <- newEmptyMap + traverseMapHP_ mh fn set os + return os + +-- | A variant of `traverseMap_` that optionally ties the handlers to a pool. +traverseMapHP_ :: (Ord k, Eq b) => + Maybe HandlerPool -> (k -> a -> Par d s b) -> SatMap k s a -> SatMap 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 + +-- | A variant of `union` that optionally ties the handlers in the +-- resulting set to the same handler pool as those in the two input +-- sets. +unionHP :: (Ord k, Eq a) => Maybe HandlerPool -> + SatMap k s a -> SatMap k s a -> Par d s (SatMap 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 + +{-# NOINLINE unsafeName #-} +unsafeName :: a -> Int +unsafeName x = unsafePerformIO $ do + sn <- makeStableName x + return (hashStableName sn) + +-------------------------------------------------------------------------------- +-- Interfaces for generic programming with containers: + +#ifdef GENERIC_PAR +#warning "Creating instances for generic programming with IMaps" +instance PC.Generator (SatMap k Frzn a) where + type ElemOf (SatMap k Frzn a) = (k,a) + {-# INLINE fold #-} + {-# INLINE foldM #-} + {-# INLINE foldMP #-} + fold fn zer (SatMap (WrapLVar lv)) = PC.fold fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv + foldM fn zer (SatMap (WrapLVar lv)) = PC.foldM fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv + foldMP fn zer (SatMap (WrapLVar lv)) = PC.foldMP fn zer $ unsafeDupablePerformIO $ readIORef $ L.state lv + +-- TODO: Once containers 0.5.3.2+ is broadly available we can have a real parFoldable +-- instance. +-- instance Show k => PC.ParFoldable (SatMap k Frzn a) where + +#endif + + +-} + +---------------------------------------- +-- Simple tests +---------------------------------------- + +t0 :: SatMap String Frzn Int +t0 = runParThenFreeze $ do + m <- newEmptyMap + insert "hi" (32::Int) m + insert "hi" (34::Int) m + insert "there" (1::Int) m + return m + +t1 :: SatMap String Frzn Int +t1 = runParThenFreeze $ do + m <- newEmptyMap + insert "hi" (32::Int) m + insert "hi" (33::Int) m + return m + +instance PartialJoinSemiLattice Int where + joinMaybe a b + | even a && even b = Just (max a b) + | odd a && odd b = Just (max a b) + | otherwise = Nothing diff --git a/lvish.cabal b/lvish.cabal --- a/lvish.cabal +++ b/lvish.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.1.2 +version: 1.1.4 -- Changelog: -- 0.2 -- switch SLMap over to O(1) freeze @@ -23,6 +23,8 @@ -- 1.1.1.0 -- expose logging routines -- 1.1.1.5 -- various bugfixes -- 1.1.2 -- bugfixes and small additions, work-around for -fbeta problems +-- 1.1.3 -- add fromPureLVar +-- 1.1.4 -- add SatMap synopsis: Parallel scheduler, LVar data structures, and infrastructure to build more. @@ -30,12 +32,14 @@ . A programming model based on monotonically-growing concurrent data structures. . - As a starting point, look at "Control.LVish", as well as one of these papers: + As a starting point, look at the main module, "Control.LVish", as well as one of these papers: . * FHPC 2013: /LVars: lattice-based data structures for deterministic parallelism/ (). . * POPL 2014: /Freeze after writing: quasi-deterministic parallel programming with LVars/ (). . + * PLDI 2014: /Taming the Parallel Effect Zoo: Extensible Deterministic Parallelism with LVish/ (). + . If the haddocks are not building, here is a mirror: . @@ -59,36 +63,37 @@ description: Activate additional debug assertions, and printed output. -- if DEBUGLVL env var is set to 1 or higher. default: False + manual: True flag chaselev description: Use the Chase-Lev work-stealing deque default: False - --- flag newcontainers --- description: Use a pre-release version of containers to enable splitting. --- default: False - + manual: True + flag getonce description: Ensure that continuations of get run at most once (by using extra synchronization) default: False + manual: True -- We won't really support this until LVish 2.0: flag generic description: Use (forthcoming) generic interfaces for Par monads. - default: True + default: False + manual: True -- flag beta -- description: These features are in beta and not fully supported yet. -- default: True +Source-repository head + type: git + location: https://github.com/iu-parfunc/lvars + subdir: haskell/lvish +-- tag: release-lvish-1.0.0.6 + -------------------------------------------------------------------------------- library - Source-repository head - type: git - location: https://github.com/iu-parfunc/lvars - subdir: haskell/lvish --- tag: release-lvish-1.0.0.6 -- Modules exported by the library. exposed-modules: @@ -100,6 +105,7 @@ Data.LVar.IStructure Data.LVar.PureSet Data.LVar.PureMap + Data.LVar.SatMap Data.LVar.SLSet Data.LVar.SLMap ------------------------------------------- @@ -116,6 +122,10 @@ Control.LVish.DeepFrz.Internal -- This is also not recommended for general use yet. Data.Concurrent.SkipListMap + + Data.LVar.CycGraph + + -- TEMP: using a flag to control exports doesn't really work with Hackage currently: -- if flag(beta) -- exposed-modules: -- -- Not quite ready for prime-time yet: @@ -128,12 +138,7 @@ -- ------------------------------------------- -- -- New / Experimental: -- Data.LVar.Memo - -- Data.LVar.CycGraph - -- if flag(beta) && flag(newcontainers) - -- exposed-modules: - -- Control.LVish.BulkRetry - -- Modules included in this library but not exported. other-modules: Data.UtilInternal @@ -157,29 +162,30 @@ deepseq >= 1.3, lattices >= 1.2, vector >=0.10, - atomic-primops >= 0.4, + atomic-primops >= 0.6, random, transformers, ghc-prim, async, -- Used in NatArray: bits-atomic, missing-foreign - -- if flag(newcontainers) { build-depends: containers >= 0.5.3.2 } - -- else { build-depends: containers >= 0.5 } - build-depends: containers >= 0.5 if flag(generic) cpp-options: -DGENERIC_PAR +-- build-depends: containers >= 0.5.4.0 + build-depends: containers >= 0.5 build-depends: par-classes >= 1.0 && < 2.0, par-collections >= 1.0 && < 2.0 -- par-transformers <= 2.0 + else + build-depends: containers >= 0.5 ghc-options: -O2 -rtsopts if flag(debug) -- TEMP: depending on these for visualzing MemoCyc DAGs: - build-depends: fgl, graphviz, text +-- build-depends: fgl, graphviz, text cpp-options: -DDEBUG_LVAR - cpp-options: -DDEBUG_MEMO +-- cpp-options: -DDEBUG_MEMO if flag(chaselev) build-depends: chaselev-deque cpp-options: -DCHASE_LEV @@ -212,7 +218,7 @@ containers >= 0.5, lattices >= 1.2, vector >=0.10, - atomic-primops >= 0.4, + atomic-primops >= 0.6, random, transformers, ghc-prim, @@ -235,12 +241,17 @@ build-depends: lvish if flag(debug) -- TEMP: depending on these for visualzing MemoCyc DAGs: - build-depends: fgl, graphviz, text +-- build-depends: fgl, graphviz, text cpp-options: -DDEBUG_LVAR - cpp-options: -DDEBUG_MEMO +-- cpp-options: -DDEBUG_MEMO if flag(chaselev) build-depends: chaselev-deque cpp-options: -DCHASE_LEV if flag(getonce) cpp-options: -DGET_ONCE + + -- Atomic-primops fails when used by template-haskell/ghci on linux: + if impl(ghc < 7.7) && os(linux) { + buildable: False + }