lvish 1.1.2 → 1.1.4

raw patch · 10 files changed

+1156/−42 lines, 10 filesdep −fgldep −graphvizdep ~atomic-primopsdep ~basenew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: fgl, graphviz

Dependency ranges changed: atomic-primops, base

API changes (from Hackage documentation)

Files

• Control/LVish/SchedIdempotent.hs +13/−8
• Control/LVish/SchedIdempotentInternal.hs +1/−1
• Data/Concurrent/SkipListMap.hs +1/−1
• Data/LVar/CycGraph.hs +576/−0
• Data/LVar/Generic/Internal.hs +3/−0
• Data/LVar/Internal/Pure.hs +9/−2
• Data/LVar/PureMap.hs +2/−2
• Data/LVar/SLMap.hs +1/−1
• Data/LVar/SatMap.hs +512/−0
• lvish.cabal +38/−27

@@ -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:

@@ -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

@@ -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: {-        

@@ -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

@@ -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.

@@ -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 ()

@@ -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.

@@ -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.

@@ -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

@@ -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/ (<http://dl.acm.org/citation.cfm?id=2502326>).   .     * POPL 2014: /Freeze after writing: quasi-deterministic parallel programming with LVars/ (<http://www.cs.indiana.edu/~lkuper/papers/2013-lvish-draft.pdf>).   . +    * PLDI 2014: /Taming the Parallel Effect Zoo: Extensible Deterministic Parallelism with LVish/ (<http://www.cs.indiana.edu/~rrnewton/papers/effectzoo-draft.pdf>).+  .    If the haddocks are not building, here is a mirror:   <http://www.cs.indiana.edu/~rrnewton/haddock/lvish/>   .@@ -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+    }