compiler/nativeGen/GraphPpr.hs

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