summaryrefslogtreecommitdiff
path: root/compiler/utils/GraphPpr.hs
blob: 4327ec881cb40e285c2d0435d3077d5356b4e0be (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

-- | Pretty printing of graphs.

module GraphPpr (
        dumpGraph,
        dotGraph
)
where

import GhcPrelude

import GraphBase

import Outputable
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM

import Data.List (mapAccumL)
import Data.Maybe


-- | Pretty print a graph in a somewhat human readable format.
dumpGraph
        :: (Outputable k, Outputable color)
        => Graph k cls color -> SDoc

dumpGraph graph
        =  text "Graph"
        $$ pprUFM (graphMap graph) (vcat . map dumpNode)

dumpNode
        :: (Outputable k, Outputable color)
        => Node k cls color -> SDoc

dumpNode node
        =  text "Node " <> ppr (nodeId node)
        $$ text "conflicts "
                <> parens (int (sizeUniqSet $ nodeConflicts node))
                <> text " = "
                <> ppr (nodeConflicts node)

        $$ text "exclusions "
                <> parens (int (sizeUniqSet $ nodeExclusions node))
                <> text " = "
                <> ppr (nodeExclusions node)

        $$ text "coalesce "
                <> parens (int (sizeUniqSet $ nodeCoalesce node))
                <> text " = "
                <> ppr (nodeCoalesce node)

        $$ space



-- | Pretty print a graph in graphviz .dot format.
--      Conflicts get solid edges.
--      Coalescences get dashed edges.
dotGraph
        :: ( Uniquable k
           , Outputable k, Outputable cls, Outputable color)
        => (color -> SDoc)  -- ^ What graphviz color to use for each node color
                            --  It's usually safe to return X11 style colors here,
                            --  ie "red", "green" etc or a hex triplet #aaff55 etc
        -> Triv k cls color
        -> Graph k cls color -> SDoc

dotGraph colorMap triv graph
 = let  nodes   = nonDetEltsUFM $ graphMap graph
                  -- See Note [Unique Determinism and code generation]
   in   vcat
                (  [ text "graph G {" ]
                ++ map (dotNode colorMap triv) nodes
                ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
                ++ [ text "}"
                   , space ])


dotNode :: ( Outputable k, Outputable cls, Outputable color)
        => (color -> SDoc)
        -> Triv k cls color
        -> Node k cls color -> SDoc

dotNode colorMap triv node
 = let  name    = ppr $ nodeId node
        cls     = ppr $ nodeClass node

        excludes
                = hcat $ punctuate space
                $ map (\n -> text "-" <> ppr n)
                $ nonDetEltsUniqSet $ nodeExclusions node
                -- See Note [Unique Determinism and code generation]

        preferences
                = hcat $ punctuate space
                $ map (\n -> text "+" <> ppr n)
                $ nodePreference node

        expref  = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
                        then empty
                        else text "\\n" <> (excludes <+> preferences)

        -- if the node has been colored then show that,
        --      otherwise indicate whether it looks trivially colorable.
        color
                | Just c        <- nodeColor node
                = text "\\n(" <> ppr c <> text ")"

                | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
                = text "\\n(" <> text "triv" <> text ")"

                | otherwise
                = text "\\n(" <> text "spill?" <> text ")"

        label   =  name <> text " :: " <> cls
                <> expref
                <> color

        pcolorC = case nodeColor node of
                        Nothing -> text "style=filled fillcolor=white"
                        Just c  -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)


        pout    = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
                <> space <> doubleQuotes name
                <> text ";"

 in     pout


-- | Nodes in the graph are doubly linked, but we only want one edge for each
--      conflict if the graphviz graph. Traverse over the graph, but make sure
--      to only print the edges for each node once.

dotNodeEdges
        :: ( Uniquable k
           , Outputable k)
        => UniqSet k
        -> Node k cls color
        -> (UniqSet k, Maybe SDoc)

dotNodeEdges visited node
        | elementOfUniqSet (nodeId node) visited
        = ( visited
          , Nothing)

        | otherwise
        = let   dconflicts
                        = map (dotEdgeConflict (nodeId node))
                        $ nonDetEltsUniqSet
                        -- See Note [Unique Determinism and code generation]
                        $ minusUniqSet (nodeConflicts node) visited

                dcoalesces
                        = map (dotEdgeCoalesce (nodeId node))
                        $ nonDetEltsUniqSet
                        -- See Note [Unique Determinism and code generation]
                        $ minusUniqSet (nodeCoalesce node) visited

                out     =  vcat dconflicts
                        $$ vcat dcoalesces

          in    ( addOneToUniqSet visited (nodeId node)
                , Just out)

        where   dotEdgeConflict u1 u2
                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
                        <> text ";"

                dotEdgeCoalesce u1 u2
                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
                        <> space <> text "[ style = dashed ];"