X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FGraphOps.hs;h=880f3c65cd85983b1261e683309528ff32cdc9f0;hb=b56fa72c006e7dfd850729cb8dd28552bc4e041e;hp=414abe4efce0489ebd138c563615252aaac166e5;hpb=b01110d1352de5d972d8fb63f28c244d2c1ff99b;p=ghc-hetmet.git

diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
index 414abe4..880f3c6 100644
--- 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