Whitespace

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

diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
index 414abe4..880f3c6 100644 (file)
--- a/compiler/utils/GraphOps.hs
+++ b/compiler/utils/GraphOps.hs
@@ -1,8 +1,6 @@
+{-# OPTIONS -fno-warn-missing-signatures #-}
 -- | Basic operations on graphs.
 --
---     TODO: refine coalescing crieteria
-
-{-# OPTIONS -fno-warn-missing-signatures #-}
 
 module GraphOps (
        addNode,        delNode,        getNode,        lookupNode,     modNode,
@@ -273,7 +271,9 @@ coalesceGraph
                                --      less colorable (aggressive coalescing)
        -> Triv k cls color
        -> Graph k cls color
-       -> (Graph k cls color, [(k, k)])
+       -> ( Graph k cls color
+          , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the
+                               --      coalescing was applied.
 
 coalesceGraph aggressive triv graph
        = coalesceGraph' aggressive triv graph []
@@ -301,8 +301,8 @@ coalesceGraph' aggressive triv graph kkPairsAcc
 
        -- keep running until there are no more coalesces can be found
    in  case catMaybes mPairs of
-        []     -> (graph', kkPairsAcc)
-        pairs  -> coalesceGraph' aggressive triv graph' (pairs ++ kkPairsAcc)
+        []     -> (graph', reverse kkPairsAcc)
+        pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
 
 
 -- | Coalesce this pair of nodes unconditionally / agressively.
@@ -499,30 +499,76 @@ scanGraph match graph
 
 -- | validate the internal structure of a graph
 --     all its edges should point to valid nodes
---     if they don't then throw an error
+--     If they don't then throw an error
 --
 validateGraph
-       :: (Uniquable k, Outputable k)
-       => SDoc
-       -> Graph k cls color
-       -> Graph k cls color
+       :: (Uniquable k, Outputable k, Eq color)
+       => SDoc                         -- ^ extra debugging info to display on error
+       -> Bool                         -- ^ whether this graph is supposed to be colored.
+       -> Graph k cls color            -- ^ graph to validate
+       -> Graph k cls color            -- ^ validated graph
+
+validateGraph doc isColored graph
+
+       -- Check that all edges point to valid nodes.
+       | edges         <- unionManyUniqSets
+                               (  (map nodeConflicts       $ eltsUFM $ graphMap graph)
+                               ++ (map nodeCoalesce        $ eltsUFM $ graphMap graph))
+
+       , nodes         <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
+       , badEdges      <- minusUniqSet edges nodes
+       , not $ isEmptyUniqSet badEdges
+       = pprPanic "GraphOps.validateGraph"
+               (  text "Graph has edges that point to non-existant nodes"
+               $$ text "  bad edges: " <> vcat (map ppr $ uniqSetToList badEdges)
+               $$ doc )
+
+       -- Check that no conflicting nodes have the same color
+       | badNodes      <- filter (not . (checkNode graph))
+                       $ eltsUFM $ graphMap graph
+       , not $ null badNodes
+       = pprPanic "GraphOps.validateGraph"
+               (  text "Node has same color as one of it's conflicts"
+               $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
+               $$ doc)
+
+       -- If this is supposed to be a colored graph,
+       --      check that all nodes have a color.
+       | isColored
+       , badNodes      <- filter (\n -> isNothing $ nodeColor n)
+                       $  eltsUFM $ graphMap graph
+       , not $ null badNodes
+       = pprPanic "GraphOps.validateGraph"
+               (  text "Supposably colored graph has uncolored nodes."
+               $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
+               $$ doc )
 
-validateGraph doc graph
- = let edges   = unionManyUniqSets
-                       (  (map nodeConflicts       $ eltsUFM $ graphMap graph)
-                       ++ (map nodeCoalesce        $ eltsUFM $ graphMap graph))
 
-       nodes   = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
+       -- graph looks ok
+       | otherwise
+       = graph
+
+
+-- | If this node is colored, check that all the nodes which
+--     conflict with it have different colors.
+checkNode
+       :: (Uniquable k, Eq color)
+       => Graph k cls color
+       -> Node  k cls color
+       -> Bool                 -- ^ True if this node is ok
        
-       badEdges = minusUniqSet edges nodes
+checkNode graph node
+       | Just color            <- nodeColor node
+       , Just neighbors        <- sequence $ map (lookupNode graph)
+                               $  uniqSetToList $ nodeConflicts node
+
+       , neighbourColors       <- catMaybes $ map nodeColor neighbors
+       , elem color neighbourColors
+       = False
        
-  in   if isEmptyUniqSet badEdges 
-        then   graph
-        else   pprPanic "GraphOps.validateGraph"
-               ( text  "-- bad edges"
-               $$ vcat (map ppr $ uniqSetToList badEdges)
-               $$ text "----------------------------"
-               $$ doc)
+       | otherwise
+       = True
+
 
 
 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours