move generic graph-colouring code into util

[ghc-hetmet.git] / compiler / utils / GraphPpr.hs

diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs
new file mode 100644 (file)
index 0000000..1df5158
--- /dev/null
+++ b/compiler/utils/GraphPpr.hs
@@ -0,0 +1,169 @@
+
+-- | Pretty printing of graphs.
+
+module GraphPpr (
+       dumpGraph,
+       dotGraph
+)
+where
+
+import GraphBase
+
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+
+import Data.List
+import Data.Maybe
+
+
+-- | Pretty print a graph in a somewhat human readable format.
+dumpGraph 
+       :: (Outputable k, Outputable cls, Outputable color)
+       => Graph k cls color -> SDoc
+
+dumpGraph graph
+       =  text "Graph"
+       $$ (vcat $ map dumpNode $ eltsUFM $ graphMap graph)
+       
+dumpNode 
+       :: (Outputable k, Outputable cls, 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   = eltsUFM $ graphMap graph
+   in  vcat 
+               (  [ text "graph G {" ]
+               ++ map (dotNode colorMap triv) nodes
+               ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
+               ++ [ text "}"
+                  , space ])
+       
+
+dotNode :: ( Uniquable k
+          , 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)
+               $ uniqSetToList $ nodeExclusions node
+               
+       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, Outputable cls, Outputable color)
+       => 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)) 
+                       $ uniqSetToList
+                       $ minusUniqSet (nodeConflicts node) visited
+                               
+               dcoalesces
+                       = map (dotEdgeCoalesce (nodeId node))
+                       $ uniqSetToList
+                       $ 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 ];"
+