compiler/utils/GraphPpr.hs

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