Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 86a4d11

Browse files
add TraverseState debug utility module to generate reachability graphs
1 parent 81c142a commit 86a4d11

File tree

2 files changed

+124
-0
lines changed

2 files changed

+124
-0
lines changed

‎external-stg-interpreter/external-stg-interpreter.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ library
3030
Stg.Interpreter.Debugger.Internal
3131
Stg.Interpreter.Debugger.Region
3232
Stg.Interpreter.Debugger.UI
33+
Stg.Interpreter.Debugger.TraverseState
3334
Stg.Interpreter.GC
3435
Stg.Interpreter.GC.GCRef
3536
Stg.Interpreter.GC.LiveDataAnalysis
Lines changed: 123 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,123 @@
1+
{-# LANGUAGE RecordWildCards, LambdaCase, OverloadedStrings #-}
2+
module Stg.Interpreter.Debugger.TraverseState
3+
( exportReachableGraph
4+
) where
5+
6+
import Control.Monad.State
7+
import Data.Set (Set)
8+
import qualified Data.Set as Set
9+
import qualified Data.IntMap as IntMap
10+
import qualified Data.ByteString.Char8 as BS8
11+
import System.IO
12+
import Stg.Interpreter.Base
13+
import Stg.Interpreter.GC.GCRef
14+
15+
{-
16+
export GCSymbol's reachability graph as gephi compatible .tsv file
17+
-}
18+
19+
type ExportM = StateT (Set GCSymbol) IO
20+
21+
exportReachableGraph :: FilePath -> FilePath -> StgState -> GCSymbol -> IO ()
22+
exportReachableGraph nodesFname edgesFname stgState root = do
23+
withFile edgesFname WriteMode $ \hEdge -> do
24+
withFile nodesFname WriteMode $ \hNode -> do
25+
BS8.hPutStrLn hNode $ BS8.intercalate "\t"
26+
[ "Id"
27+
, "Label"
28+
, "partition2"
29+
]
30+
BS8.hPutStrLn hEdge $ BS8.intercalate "\t"
31+
[ "Source"
32+
, "Target"
33+
, "partition2"
34+
]
35+
evalStateT (addEdgesFrom hNode hEdge stgState root True) Set.empty
36+
{-
37+
special case: if gcsymbol has no children then emit one node only
38+
otherwise: leaves will always be included
39+
40+
OR:
41+
the graph should be empty if the object has no internal structure
42+
-}
43+
44+
mark :: GCSymbol -> ExportM Bool
45+
mark symbol = state $ \visitedSet ->
46+
let wasVisited = Set.member symbol visitedSet
47+
in (not wasVisited, if wasVisited then visitedSet else Set.insert symbol visitedSet)
48+
49+
addEdgesFrom :: Handle -> Handle -> StgState -> GCSymbol -> Bool -> ExportM ()
50+
addEdgesFrom hNode hEdge stgState@StgState{..} source isRoot = do
51+
firstTimeVisit <- mark source
52+
when firstTimeVisit $ do
53+
liftIO $ print source
54+
55+
let (ns, idx) = decodeRef source
56+
(nodeLabel, nodeCategory) = case ns of
57+
NS_HeapPtr
58+
| Just ho <- IntMap.lookup idx ssHeap
59+
-> (getHeapObjectSummary ho, getHeapObjectCategory ho)
60+
_ -> (drop 3 $ show ns, drop 3 $ show ns)
61+
62+
-- HINT: write line to node .tsv
63+
liftIO $ do
64+
BS8.hPut hNode $ unGCSymbol source
65+
BS8.hPut hNode "\t"
66+
hPutStr hNode $ if isRoot then "Root " ++ nodeLabel else nodeLabel
67+
BS8.hPut hNode "\t"
68+
hPutStr hNode nodeCategory
69+
BS8.hPut hNode "\n"
70+
71+
-- TODO: generate Source node attributes ; or get
72+
let emitEdge :: VisitGCRef a => Maybe a -> ExportM ()
73+
emitEdge Nothing = error $ "missing StgState item: " ++ show (ns, idx)
74+
emitEdge obj = flip visitGCRef obj $ \target -> do
75+
-- HINT: write line to edge .tsv
76+
liftIO $ do
77+
BS8.hPut hEdge $ unGCSymbol source
78+
BS8.hPut hEdge "\t"
79+
BS8.hPut hEdge $ unGCSymbol target
80+
BS8.hPut hEdge "\t"
81+
BS8.hPut hEdge "green"
82+
BS8.hPut hEdge "\n"
83+
addEdgesFrom hNode hEdge stgState target False
84+
85+
case ns of
86+
NS_Array -> emitEdge $ IntMap.lookup idx ssArrays
87+
NS_ArrayArray -> emitEdge $ IntMap.lookup idx ssArrayArrays
88+
NS_HeapPtr -> emitEdge $ IntMap.lookup idx ssHeap
89+
NS_MutableArray -> emitEdge $ IntMap.lookup idx ssMutableArrays
90+
NS_MutableArrayArray -> emitEdge $ IntMap.lookup idx ssMutableArrayArrays
91+
NS_MutableByteArray -> pure () -- IntMap.lookup idx ssMutableByteArrays
92+
NS_MutVar -> emitEdge $ IntMap.lookup idx ssMutVars
93+
NS_TVar -> emitEdge $ IntMap.lookup idx ssTVars
94+
NS_MVar -> emitEdge $ IntMap.lookup idx ssMVars
95+
NS_SmallArray -> emitEdge $ IntMap.lookup idx ssSmallArrays
96+
NS_SmallMutableArray -> emitEdge $ IntMap.lookup idx ssSmallMutableArrays
97+
{-
98+
NS_StableName
99+
| Just obj <- IntMap.lookup idx -- TODO
100+
-}
101+
NS_StablePointer -> emitEdge $ IntMap.lookup idx ssStablePointers
102+
NS_WeakPointer -> emitEdge $ IntMap.lookup idx ssWeakPointers
103+
NS_Thread -> emitEdge $ IntMap.lookup idx ssThreads
104+
105+
_ -> error $ "unknown StgState item: " ++ show (ns, idx)
106+
107+
getHeapObjectSummary :: HeapObject -> String
108+
getHeapObjectSummary = \case
109+
Con{..} -> "Con: " ++ show hoCon
110+
Closure{..} -> if hoCloMissing == 0
111+
then "Thunk: " ++ show hoName
112+
else "Closure: " ++ show hoName
113+
BlackHole{} -> "BlackHole"
114+
ApStack{} -> "ApStack"
115+
RaiseException{} -> "RaiseException"
116+
117+
getHeapObjectCategory :: HeapObject -> String
118+
getHeapObjectCategory = \case
119+
Con{} -> "Constructor"
120+
Closure{..} -> if hoCloMissing == 0 then "Thunk" else "Closure"
121+
BlackHole{} -> "BlackHole"
122+
ApStack{} -> "ApStack"
123+
RaiseException{} -> "Exception"

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /