module Data.LVar.CycGraph
(
exploreGraph_seq,
Response(..),
exploreGraph, NodeValue(..), NodeAction,
ShortShow(..), shortTwo
)
where
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
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
#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
type SetAcc a = IORef (S.Set 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))
data Memo (d::Determinism) s k v =
Memo !(IS.ISet s k)
!(IM.IMap k s (NodeRecord s k v))
data NodeRecord s k v = NodeRecord
{ mykey :: k
, chldrn :: [k]
, reachme :: !(IS.ISet s k)
, in_cycle :: !(IVar s Bool)
, result :: !(IVar s v)
} deriving (Eq)
data Response par key ans =
Done !ans
| Request !key (RequestCont par key ans)
type RequestCont par key ans = (ans -> par (Response par key ans))
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))
-> (k -> Par d s v)
-> k
-> Par d s v
exploreGraph_seq initCont cycHndlr initKey = do
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
| 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
loop current hist resp'' kont
type IsCycle = Bool
type NodeAction d s k v =
IsCycle -> k -> [(k,IsCycle,IV.IVar s v)] -> Par d s (NodeValue k v)
data NodeValue k v = FinalValue !v | Defer k
deriving (Show,Eq,Ord)
#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])
-> NodeAction QuasiDet s k v
-> k
-> Par QuasiDet s v
exploreGraph keyNbrs nodeHndlr initKey = do
set <- IS.newEmptySet
mp <- IM.newEmptyMap
keywalkHP <- newPool
IS.forEachHP (Just keywalkHP) set $ \ key0 -> do
dbgPr ("![MemoFixedPoint] Start new key "++show key0)
key0_res <- IV.new
key0_cycle <- IV.new
key0_reach <- IS.newEmptySet
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 ()
_ -> do
forM_ child_keys (`IS.insert` set)
IS.forEachHP (Just keywalkHP) key0_reach $ \ key1 ->
when (key1 == key0) $ do
dbgPr (" !! Cycle detected on key "++showID key0)
IV.put_ key0_cycle True
chldrecs <- forM child_keys $ \child -> do
nrec@NodeRecord{reachme} <- IM.getKey child mp
IS.insert key0 reachme
copyTo keywalkHP key0_reach reachme
dbgPr (" Inserted ourselves ("++showID key0++") in reachme list of child: "++showID child)
return nrec
return ()
IS.insert initKey set
quiesce keywalkHP
frmap <- IM.freezeMap mp
dbgPr ("Froze map: "++show (M.keys frmap))
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
#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
(#) :: (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 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 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]"
]
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)
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)
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 (n2) 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 (n3) a b
in "("++ l ++","++ r ++")"
shortTwo :: (ShortShow t, ShortShow t1) => Int -> t -> t1 -> (String, String)
shortTwo n a b = (left, shortShow (half+remain) b)
where
remain = abs (half length left)
left = shortShow half a
(q,r) = quotRem (abs(n3)) 2
half = q + r
#ifdef DEBUG_MEMO
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
-> t1
-> t (NodeRecord s t1 t2)
-> 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))
(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
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 (_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
return dg
weighted c = GC.WC {GC.wColor=c, GC.weighting=Nothing}
#endif