1+ {-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-}
2+ module Stg.Interpreter.Debugger.Retainer
3+ ( exportRetainerGraph
4+ -- , exportRetainerDominatorTree
5+ ) where
6+ 7+ import Control.Monad.Writer
8+ import Control.Monad.State
9+ import Data.Maybe
10+ import Data.Bimap ( Bimap )
11+ import qualified Data.Bimap as Bimap
12+ import Data.Map (Map )
13+ import Data.Set (Set )
14+ import Data.IntMap.Strict (IntMap )
15+ import Data.IntSet (IntSet )
16+ import qualified Data.Set as Set
17+ import qualified Data.IntSet as IntSet
18+ import qualified Data.IntMap.Strict as IntMap
19+ import qualified Data.Map as Map
20+ import qualified Data.ByteString.Char8 as BS8
21+ import qualified Data.Graph.Dom as Graph
22+ import System.IO
23+ import Stg.Interpreter.Base
24+ import Stg.Interpreter.GC.GCRef
25+ import Stg.Interpreter.GC.LiveDataAnalysis
26+ import Stg.Interpreter.Debugger.TraverseState
27+ 28+ 29+ data RetainerState
30+ = RetainerState
31+ { rsGraph :: IntMap IntSet
32+ , rsNodeMap :: Bimap GCSymbol Int
33+ }
34+ 35+ type RetainerM = StateT RetainerState IO
36+ 37+ addNode :: GCSymbol -> RetainerM Int
38+ addNode n = do
39+ nodeMap <- gets rsNodeMap
40+ case Bimap. lookup n nodeMap of
41+ Just i -> pure i
42+ Nothing -> do
43+ let i = Bimap. size nodeMap
44+ modify' $ \ s@ RetainerState {.. } -> s {rsNodeMap = Bimap. insert n i rsNodeMap}
45+ pure i
46+ 47+ addEdge :: GCSymbol -> GCSymbol -> RetainerM ()
48+ addEdge from to = do
49+ fromId <- addNode from
50+ toId <- addNode to
51+ modify' $ \ s@ RetainerState {.. } -> s {rsGraph = IntMap. insertWith IntSet. union fromId (IntSet. singleton toId) rsGraph}
52+ 53+ exportRetainerGraph :: FilePath -> FilePath -> StgState -> GCSymbol -> IO ()
54+ exportRetainerGraph nodesFname edgesFname stgState root = do
55+ {-
56+ done - calculate retainer graph
57+ done - traverse graph
58+ -}
59+ -- HINT: retainer = inverse reference
60+ RetainerState {.. } <- flip execStateT (RetainerState mempty Bimap. empty) . withReferenceFacts stgState $ \ from to -> addEdge to from
61+ let gcRootSet :: Map GCSymbol String
62+ gcRootSet = execWriter $ withGCRootFacts stgState (ssLocalEnv stgState) $ \ msg s -> tell $ Map. singleton s msg
63+ 64+ withFile edgesFname WriteMode $ \ hEdge -> do
65+ withFile nodesFname WriteMode $ \ hNode -> do
66+ BS8. hPutStrLn hNode $ BS8. intercalate " \t "
67+ [ " Id"
68+ , " Label"
69+ , " partition2"
70+ ]
71+ BS8. hPutStrLn hEdge $ BS8. intercalate " \t "
72+ [ " Source"
73+ , " Target"
74+ , " partition2"
75+ ]
76+ flip evalStateT Set. empty . addEdgesFrom hNode hEdge stgState gcRootSet root True $ \ case
77+ source
78+ | Just i <- Bimap. lookup source rsNodeMap
79+ , Just edges <- IntMap. lookup i rsGraph
80+ -> catMaybes $ map (flip Bimap. lookupR rsNodeMap) $ IntSet. toList edges
81+ | otherwise
82+ -> []
83+ 84+ pure ()
85+ 86+ type ExportM = StateT (Set GCSymbol ) IO
87+ 88+ mark :: GCSymbol -> ExportM Bool
89+ mark symbol = state $ \ visitedSet ->
90+ let wasVisited = Set. member symbol visitedSet
91+ in (not wasVisited, if wasVisited then visitedSet else Set. insert symbol visitedSet)
92+ 93+ addEdgesFrom :: Handle -> Handle -> StgState -> Map GCSymbol String -> GCSymbol -> Bool -> (GCSymbol -> [GCSymbol ]) -> ExportM ()
94+ addEdgesFrom hNode hEdge stgState@ StgState {.. } gcRootSet source isRoot getEdges = do
95+ firstTimeVisit <- mark source
96+ when firstTimeVisit $ do
97+ liftIO $ print source
98+ 99+ let (ns, idx) = decodeRef source
100+ (nodeLabel, nodeCategory) = case ns of
101+ NS_HeapPtr
102+ | Just ho <- IntMap. lookup idx ssHeap
103+ -> (getHeapObjectSummary ho, getHeapObjectCategory ho)
104+ _ -> (drop 3 $ show ns, drop 3 $ show ns)
105+ 106+ -- HINT: write line to node .tsv
107+ liftIO $ do
108+ BS8. hPut hNode $ unGCSymbol source
109+ BS8. hPut hNode " \t "
110+ hPutStr hNode $
111+ (if isRoot then (" Root " ++ ) else id ) $
112+ (maybe id (\ msg str -> " GCRoot " ++ msg ++ " " ++ str) $ Map. lookup source gcRootSet) $
113+ nodeLabel
114+ BS8. hPut hNode " \t "
115+ hPutStr hNode nodeCategory
116+ BS8. hPut hNode " \n "
117+ 118+ -- TODO: generate Source node attributes ; or get
119+ forM_ (getEdges source) $ \ target -> do
120+ -- HINT: write line to edge .tsv
121+ liftIO $ do
122+ BS8. hPut hEdge $ unGCSymbol source
123+ BS8. hPut hEdge " \t "
124+ BS8. hPut hEdge $ unGCSymbol target
125+ BS8. hPut hEdge " \t "
126+ BS8. hPut hEdge " green"
127+ BS8. hPut hEdge " \n "
128+ addEdgesFrom hNode hEdge stgState gcRootSet target False
129+ 130+ {-
131+ exportRetainerDominatorTree :: FilePath -> FilePath -> StgState -> GCSymbol -> IO ()
132+ exportRetainerDominatorTree nodesFname edgesFname stgState root = do
133+ -- HINT: retainer = inverse reference
134+ RetainerState{..} <- flip execStateT (RetainerState mempty Bimap.empty) . withReferenceFacts stgState $ \from to -> addEdge to from
135+ let gcRootSet :: Set GCSymbol
136+ gcRootSet = execWriter $ withGCRootFacts stgState (ssLocalEnv stgState) (tell . Set.singleton)
137+
138+ withFile edgesFname WriteMode $ \hEdge -> do
139+ withFile nodesFname WriteMode $ \hNode -> do
140+ BS8.hPutStrLn hNode $ BS8.intercalate "\t"
141+ [ "Id"
142+ , "Label"
143+ , "partition2"
144+ ]
145+ BS8.hPutStrLn hEdge $ BS8.intercalate "\t"
146+ [ "Source"
147+ , "Target"
148+ , "partition2"
149+ ]
150+ -}
0 commit comments