Revert "Batch merge"
[ghc.git] / compiler / utils / GraphPpr.hs
1
2 -- | Pretty printing of graphs.
3
4 module GraphPpr (
5 dumpGraph,
6 dotGraph
7 )
8 where
9
10 import GhcPrelude
11
12 import GraphBase
13
14 import Outputable
15 import Unique
16 import UniqSet
17 import UniqFM
18
19 import Data.List
20 import Data.Maybe
21
22
23 -- | Pretty print a graph in a somewhat human readable format.
24 dumpGraph
25 :: (Outputable k, Outputable color)
26 => Graph k cls color -> SDoc
27
28 dumpGraph graph
29 = text "Graph"
30 $$ pprUFM (graphMap graph) (vcat . map dumpNode)
31
32 dumpNode
33 :: (Outputable k, Outputable color)
34 => Node k cls color -> SDoc
35
36 dumpNode node
37 = text "Node " <> ppr (nodeId node)
38 $$ text "conflicts "
39 <> parens (int (sizeUniqSet $ nodeConflicts node))
40 <> text " = "
41 <> ppr (nodeConflicts node)
42
43 $$ text "exclusions "
44 <> parens (int (sizeUniqSet $ nodeExclusions node))
45 <> text " = "
46 <> ppr (nodeExclusions node)
47
48 $$ text "coalesce "
49 <> parens (int (sizeUniqSet $ nodeCoalesce node))
50 <> text " = "
51 <> ppr (nodeCoalesce node)
52
53 $$ space
54
55
56
57 -- | Pretty print a graph in graphviz .dot format.
58 -- Conflicts get solid edges.
59 -- Coalescences get dashed edges.
60 dotGraph
61 :: ( Uniquable k
62 , Outputable k, Outputable cls, Outputable color)
63 => (color -> SDoc) -- ^ What graphviz color to use for each node color
64 -- It's usually safe to return X11 style colors here,
65 -- ie "red", "green" etc or a hex triplet #aaff55 etc
66 -> Triv k cls color
67 -> Graph k cls color -> SDoc
68
69 dotGraph colorMap triv graph
70 = let nodes = nonDetEltsUFM $ graphMap graph
71 -- See Note [Unique Determinism and code generation]
72 in vcat
73 ( [ text "graph G {" ]
74 ++ map (dotNode colorMap triv) nodes
75 ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
76 ++ [ text "}"
77 , space ])
78
79
80 dotNode :: ( Outputable k, Outputable cls, Outputable color)
81 => (color -> SDoc)
82 -> Triv k cls color
83 -> Node k cls color -> SDoc
84
85 dotNode colorMap triv node
86 = let name = ppr $ nodeId node
87 cls = ppr $ nodeClass node
88
89 excludes
90 = hcat $ punctuate space
91 $ map (\n -> text "-" <> ppr n)
92 $ nonDetEltsUniqSet $ nodeExclusions node
93 -- See Note [Unique Determinism and code generation]
94
95 preferences
96 = hcat $ punctuate space
97 $ map (\n -> text "+" <> ppr n)
98 $ nodePreference node
99
100 expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
101 then empty
102 else text "\\n" <> (excludes <+> preferences)
103
104 -- if the node has been colored then show that,
105 -- otherwise indicate whether it looks trivially colorable.
106 color
107 | Just c <- nodeColor node
108 = text "\\n(" <> ppr c <> text ")"
109
110 | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
111 = text "\\n(" <> text "triv" <> text ")"
112
113 | otherwise
114 = text "\\n(" <> text "spill?" <> text ")"
115
116 label = name <> text " :: " <> cls
117 <> expref
118 <> color
119
120 pcolorC = case nodeColor node of
121 Nothing -> text "style=filled fillcolor=white"
122 Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
123
124
125 pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
126 <> space <> doubleQuotes name
127 <> text ";"
128
129 in pout
130
131
132 -- | Nodes in the graph are doubly linked, but we only want one edge for each
133 -- conflict if the graphviz graph. Traverse over the graph, but make sure
134 -- to only print the edges for each node once.
135
136 dotNodeEdges
137 :: ( Uniquable k
138 , Outputable k)
139 => UniqSet k
140 -> Node k cls color
141 -> (UniqSet k, Maybe SDoc)
142
143 dotNodeEdges visited node
144 | elementOfUniqSet (nodeId node) visited
145 = ( visited
146 , Nothing)
147
148 | otherwise
149 = let dconflicts
150 = map (dotEdgeConflict (nodeId node))
151 $ nonDetEltsUniqSet
152 -- See Note [Unique Determinism and code generation]
153 $ minusUniqSet (nodeConflicts node) visited
154
155 dcoalesces
156 = map (dotEdgeCoalesce (nodeId node))
157 $ nonDetEltsUniqSet
158 -- See Note [Unique Determinism and code generation]
159 $ minusUniqSet (nodeCoalesce node) visited
160
161 out = vcat dconflicts
162 $$ vcat dcoalesces
163
164 in ( addOneToUniqSet visited (nodeId node)
165 , Just out)
166
167 where dotEdgeConflict u1 u2
168 = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
169 <> text ";"
170
171 dotEdgeCoalesce u1 u2
172 = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
173 <> space <> text "[ style = dashed ];"