compiler/nativeGen/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 node
  31         =  text "Node " <> ppr (nodeId node)
  32         $$ text "conflicts "
  33                 <> parens (int (sizeUniqSet $ nodeConflicts node))
  34                 <> text " = "
  35                 <> ppr (nodeConflicts node)
  36
  37         $$ text "exclusions "
  38                 <> parens (int (sizeUniqSet $ nodeExclusions node))
  39                 <> text " = "
  40                 <> ppr (nodeExclusions node)
  41
  42         $$ text "coalesce "
  43                 <> parens (int (sizeUniqSet $ nodeCoalesce node))
  44                 <> text " = "
  45                 <> ppr (nodeCoalesce node)
  46
  47         $$ space
  48
  49
  50
  51 -- | Pretty print a graph in graphviz .dot format.
  52 --      Conflicts get solid edges.
  53 --      Coalescences get dashed edges.
  54 dotGraph
  55         :: ( Uniquable k
  56            , Outputable k, Outputable cls, Outputable color)
  57         => (color -> SDoc)              -- | What graphviz color to use for each node color
  58                                         --      It's usually safe to return X11 style colors here,
  59                                         --      ie "red", "green" etc or a hex triplet #aaff55 etc
  60         -> Triv k cls color
  61         -> Graph k cls color -> SDoc
  62
  63 dotGraph colorMap triv graph
  64  = let  nodes   = eltsUFM $ graphMap graph
  65    in   vcat
  66                 (  [ text "graph G {" ]
  67                 ++ map (dotNode colorMap triv) nodes
  68                 ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
  69                 ++ [ text "}"
  70                    , space ])
  71
  72 dotNode colorMap triv node
  73  = let  name    = ppr $ nodeId node
  74         cls     = ppr $ nodeClass node
  75
  76         excludes
  77                 = hcat $ punctuate space
  78                 $ map (\n -> text "-" <> ppr n)
  79                 $ uniqSetToList $ nodeExclusions node
  80
  81         preferences
  82                 = hcat $ punctuate space
  83                 $ map (\n -> text "+" <> ppr n)
  84                 $ nodePreference node
  85
  86         expref  = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
  87                         then empty
  88                         else text "\\n" <> (excludes <+> preferences)
  89
  90         -- if the node has been colored then show that,
  91         --      otherwise indicate whether it looks trivially colorable.
  92         color
  93                 | Just c        <- nodeColor node
  94                 = text "\\n(" <> ppr c <> text ")"
  95
  96                 | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
  97                 = text "\\n(" <> text "triv" <> text ")"
  98
  99                 | otherwise
 100                 = text "\\n(" <> text "spill?" <> text ")"
 101
 102         label   =  name <> text " :: " <> cls
 103                 <> expref
 104                 <> color
 105
 106         pcolorC = case nodeColor node of
 107                         Nothing -> text "style=filled fillcolor=white"
 108                         Just c  -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
 109
 110
 111         pout    = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
 112                 <> space <> doubleQuotes name
 113                 <> text ";"
 114
 115  in     pout
 116
 117
 118 -- | Nodes in the graph are doubly linked, but we only want one edge for each
 119 --      conflict if the graphviz graph. Traverse over the graph, but make sure
 120 --      to only print the edges for each node once.
 121
 122 dotNodeEdges visited node
 123         | elementOfUniqSet (nodeId node) visited
 124         = ( visited
 125           , Nothing)
 126
 127         | otherwise
 128         = let   dconflicts
 129                         = map (dotEdgeConflict (nodeId node))
 130                         $ uniqSetToList
 131                         $ minusUniqSet (nodeConflicts node) visited
 132
 133                 dcoalesces
 134                         = map (dotEdgeCoalesce (nodeId node))
 135                         $ uniqSetToList
 136                         $ minusUniqSet (nodeCoalesce node) visited
 137
 138                 out     =  vcat dconflicts
 139                         $$ vcat dcoalesces
 140
 141           in    ( addOneToUniqSet visited (nodeId node)
 142                 , Just out)
 143
 144 dotEdgeConflict u1 u2
 145         = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> text ";"
 146
 147 dotEdgeCoalesce u1 u2
 148         = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> space <> text "[ style = dashed ];"
 149