X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FGraphOps.hs;h=308cae0467afe43d0c144f2eb997da61dc6b797c;hb=8672676c20d5c9a268a8f07dc7aa706df4ca315f;hp=419cd383f6ff4b45dd04487b960bdd128d3f0bef;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/GraphOps.hs b/compiler/nativeGen/GraphOps.hs
index 419cd38..308cae0 100644
--- a/compiler/nativeGen/GraphOps.hs
+++ b/compiler/nativeGen/GraphOps.hs
@@ -1,13 +1,6 @@
-
 -- | Basic operations on graphs.
 --
-
-{-# OPTIONS_GHC -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
 
 module GraphOps (
 	addNode, 	delNode,	getNode,	lookupNode,	modNode,
@@ -17,8 +10,10 @@ module GraphOps (
 	addCoalesce,	delCoalesce,	
 	addExclusion,	
 	addPreference,
+	coalesceGraph,
+	coalesceNodes,
 	setColor,
-	verify,
+	validateGraph,
 	slurpNodeConflictCount
 )
 where
@@ -33,7 +28,6 @@ import UniqFM
 import Data.List	hiding (union)
 import Data.Maybe
 
-
 -- | Lookup a node from the graph.
 lookupNode 
 	:: Uniquable k
@@ -91,11 +85,11 @@ delNode k graph
  = let	Just node	= lookupNode graph k
 
 	-- delete conflict edges from other nodes to this one.
-	graph1		= foldl' (\g k1 -> delConflict k1 k g) graph 
+	graph1		= foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
 			$ uniqSetToList (nodeConflicts node)
 	
 	-- delete coalesce edge from other nodes to this one.
-	graph2		= foldl' (\g k1 -> delCoalesce k1 k g) graph1 
+	graph2		= foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
 			$ uniqSetToList (nodeCoalesce node)
 	
 	-- delete the node
@@ -104,19 +98,24 @@ delNode k graph
   in	graph3
 		
 
--- | Modify a node in the graph
+-- | Modify a node in the graph.
+--	returns Nothing if the node isn't present.
+--
 modNode :: Uniquable k
 	=> (Node k cls color -> Node k cls color) 
-	-> k -> Graph k cls color -> Graph k cls color
+	-> k -> Graph k cls color -> Maybe (Graph k cls color)
 
 modNode f k graph
- = case getNode graph k of
- 	Node{} -> graphMapModify
+ = case lookupNode graph k of
+ 	Just Node{}
+	 -> Just
+	 $  graphMapModify
 		 (\fm	-> let	Just node	= lookupUFM fm k
 			   	node'		= f node
 			   in	addToUFM fm k node') 
 		graph
 
+	Nothing	-> Nothing
 
 -- | Get the size of the graph, O(n)
 size	:: Uniquable k 
@@ -157,10 +156,11 @@ addConflict (u1, c1) (u2, c2)
 
  
 -- | Delete a conflict edge. k1 -> k2
+--	returns Nothing if the node isn't in the graph
 delConflict 
 	:: Uniquable k
 	=> k -> k
-	-> Graph k cls color -> Graph k cls color
+	-> Graph k cls color -> Maybe (Graph k cls color)
 	
 delConflict k1 k2
 	= modNode
@@ -187,13 +187,13 @@ addConflicts conflicts getClass
 
 	| otherwise
 	= graphMapModify
-	$ (\fm -> foldr	(\u -> addConflictSet1 u getClass conflicts) fm
+	$ (\fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm
 		$ uniqSetToList conflicts)
 
 
 addConflictSet1 u getClass set 
- = let	set'	= delOneFromUniqSet set u
-   in	adjustWithDefaultUFM 
+ = case delOneFromUniqSet set u of
+    set' -> adjustWithDefaultUFM
 		(\node -> node 			{ nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
 		(newNode u (getClass u))	{ nodeConflicts = set' }
 		u
@@ -237,7 +237,7 @@ addCoalesce (u1, c1) (u2, c2)
 delCoalesce
 	:: Uniquable k
 	=> k -> k 
-	-> Graph k cls color	-> Graph k cls color
+	-> Graph k cls color	-> Maybe (Graph k cls color)
 
 delCoalesce k1 k2
 	= modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
@@ -260,15 +260,142 @@ addPreference (u, c) color
 		(newNode u c)  { nodePreference = [color] }
 		u
 
+
+-- | Do agressive coalescing on this graph.
+--	returns	the new graph and the list of pairs of nodes that got coaleced together.
+--	for each pair, the resulting node will have the least key and be second in the pair.
+--
+coalesceGraph
+	:: (Uniquable k, Ord k, Eq cls, Outputable k)
+	=> Triv k cls color
+	-> Graph k cls color
+	-> (Graph k cls color, [(k, k)])
+
+coalesceGraph triv graph
+ = let
+ 	-- find all the nodes that have coalescence edges
+	cNodes	= filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
+		$ eltsUFM $ graphMap graph
+
+	-- build a list of pairs of keys for node's we'll try and coalesce
+	--	every pair of nodes will appear twice in this list
+	--	ie [(k1, k2), (k2, k1) ... ]
+	--	This is ok, GrapOps.coalesceNodes handles this and it's convenient for
+	--	build a list of what nodes get coalesced together for later on.
+	--
+	cList	= [ (nodeId node1, k2)
+			| node1	<- cNodes
+			, k2	<- uniqSetToList $ nodeCoalesce node1 ]
+
+	-- do the coalescing, returning the new graph and a list of pairs of keys
+	--	that got coalesced together.
+	(graph', mPairs)
+		= mapAccumL (coalesceNodes False triv) graph cList
+
+   in	(graph', catMaybes mPairs)
+
+
+-- | Coalesce this pair of nodes unconditionally / agressively.
+--	The resulting node is the one with the least key.
+--
+--	returns: Just 	 the pair of keys if the nodes were coalesced
+--			 the second element of the pair being the least one
+--
+--		 Nothing if either of the nodes weren't in the graph
+
+coalesceNodes
+	:: (Uniquable k, Ord k, Eq cls, Outputable k)
+	=> Bool			-- ^ If True, coalesce nodes even if this might make the graph
+				--	less colorable (aggressive coalescing)
+	-> Triv  k cls color
+	-> Graph k cls color
+	-> (k, k)		-- ^ keys of the nodes to be coalesced
+	-> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes aggressive triv graph (k1, k2)
+	| (kMin, kMax)	<- if k1 < k2
+				then (k1, k2)
+				else (k2, k1)
+
+	-- the nodes being coalesced must be in the graph
+	, Just nMin		<- lookupNode graph kMin
+	, Just nMax		<- lookupNode graph kMax
+
+	-- can't coalesce conflicting modes
+	, not $ elementOfUniqSet kMin (nodeConflicts nMax)
+	, not $ elementOfUniqSet kMax (nodeConflicts nMin)
+
+	= coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
+
+	-- don't do the coalescing after all
+	| otherwise
+	= (graph, Nothing)
+
+coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
+
+	-- sanity checks
+	| nodeClass nMin /= nodeClass nMax
+	= error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
+
+	| not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
+	= error "GraphOps.coalesceNodes: can't coalesce colored nodes."
+
+	---
+	| otherwise
+	= let
+		-- the new node gets all the edges from its two components
+		node	=
+		 Node	{ nodeId		= kMin
+			, nodeClass		= nodeClass nMin
+			, nodeColor		= Nothing
+
+			-- nodes don't conflict with themselves..
+			, nodeConflicts
+				= (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
+					`delOneFromUniqSet` kMin
+					`delOneFromUniqSet` kMax
+
+			, nodeExclusions	= unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
+			, nodePreference	= nodePreference nMin ++ nodePreference nMax
+
+			-- nodes don't coalesce with themselves..
+			, nodeCoalesce
+				= (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
+					`delOneFromUniqSet` kMin
+					`delOneFromUniqSet` kMax
+			}
+
+	  in	coalesceNodes_check aggressive triv graph kMin kMax node
+
+coalesceNodes_check aggressive triv graph kMin kMax node
+
+	-- Unless we're coalescing aggressively, if the result node is not trivially
+	--	colorable then don't do the coalescing.
+	| not aggressive
+	, not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+	= (graph, Nothing)
+
+	| otherwise
+	= let -- delete the old nodes from the graph and add the new one
+		graph'	= addNode kMin node
+			$ delNode kMin
+			$ delNode kMax
+			$ graph
+
+	  in	(graph', Just (kMax, kMin))
+
 		
--- | Verify the internal structure of a graph
+-- | validate the internal structure of a graph
 --	all its edges should point to valid nodes
+--	if they don't then throw an error
 --
-verify 	:: Uniquable k 
-	=> Graph k cls color
-	-> Bool
+validateGraph
+	:: (Uniquable k, Outputable k)
+	=> SDoc
+	-> Graph k cls color
+	-> Graph k cls color
 
-verify graph
+validateGraph doc graph
  = let	edges	= unionUniqSets
  			(unionManyUniqSets
  				(map nodeConflicts $ eltsUFM $ graphMap graph))
@@ -280,8 +407,12 @@ verify graph
 	badEdges = minusUniqSet edges nodes
 	
   in	if isEmptyUniqSet badEdges 
-  	 then 	True
-	 else	False
+  	 then 	graph
+	 else	pprPanic "GraphOps.validateGraph"
+	 	( text  "-- bad edges"
+		$$ vcat (map ppr $ uniqSetToList badEdges)
+		$$ text "----------------------------"
+		$$ doc)
 
 
 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
@@ -293,7 +424,7 @@ slurpNodeConflictCount
 
 slurpNodeConflictCount graph
 	= addListToUFM_C
-		(\(c1, n1) (c2, n2) -> (c1, n1 + n2))
+		(\(c1, n1) (_, n2) -> (c1, n1 + n2))
 		emptyUFM
 	$ map 	(\node
 	 	  -> let count	= sizeUniqSet $ nodeConflicts node
@@ -315,6 +446,7 @@ setColor u color
 		u 
 	
 
+{-# INLINE 	adjustWithDefaultUFM #-}
 adjustWithDefaultUFM 
 	:: Uniquable k 
 	=> (a -> a) -> a -> k 
@@ -322,11 +454,11 @@ adjustWithDefaultUFM
 
 adjustWithDefaultUFM f def k map
 	= addToUFM_C 
-		(\old new -> f old)
+		(\old _ -> f old)
 		map
 		k def
 		
-
+{-# INLINE adjustUFM #-}
 adjustUFM 
 	:: Uniquable k
 	=> (a -> a)
@@ -336,5 +468,4 @@ adjustUFM f k map
  = case lookupUFM map k of
  	Nothing	-> map
 	Just a	-> addToUFM map k (f a)
-