X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FGraphOps.hs;h=1fa4199aa22c9b2ac99ca9cda8c1b68adb2761f5;hp=880f3c65cd85983b1261e683309528ff32cdc9f0;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=1370a4a360ec154b390c1da21d40e446739b24c8

diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
index 880f3c6..1fa4199 100644
--- a/compiler/utils/GraphOps.hs
+++ b/compiler/utils/GraphOps.hs
@@ -8,7 +8,7 @@ module GraphOps (
 	union,
 	addConflict,	delConflict,	addConflicts,
 	addCoalesce,	delCoalesce,	
-	addExclusion,	
+	addExclusion,	addExclusions,
 	addPreference,
 	coalesceNodes,	coalesceGraph,
 	freezeNode,	freezeOneInGraph, freezeAllInGraph,
@@ -61,14 +61,14 @@ addNode k node graph
  	-- add back conflict edges from other nodes to this one
  	map_conflict	
 		= foldUniqSet 
-			(adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
+			(adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
 			(graphMap graph)
 			(nodeConflicts node)
 			
 	-- add back coalesce edges from other nodes to this one
 	map_coalesce
 		= foldUniqSet
-			(adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
+			(adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
 			map_conflict
 			(nodeCoalesce node)
 	
@@ -213,6 +213,14 @@ addExclusion u getClass color
 		(newNode u (getClass u))  	{ nodeExclusions = unitUniqSet color }
 		u
 
+addExclusions
+	:: (Uniquable k, Uniquable color)
+	=> k -> (k -> cls) -> [color]
+	-> Graph k cls color -> Graph k cls color
+
+addExclusions u getClass colors graph
+	= foldr (addExclusion u getClass) graph colors
+
 
 -- | Add a coalescence edge to the graph, creating nodes if requried.
 --	It is considered adventageous to assign the same color to nodes in a coalesence.
@@ -305,7 +313,7 @@ coalesceGraph' aggressive triv graph kkPairsAcc
 	 pairs	-> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
 
 
--- | Coalesce this pair of nodes unconditionally / agressively.
+-- | 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
@@ -335,6 +343,9 @@ coalesceNodes aggressive triv graph (k1, k2)
 	, not $ elementOfUniqSet kMin (nodeConflicts nMax)
 	, not $ elementOfUniqSet kMax (nodeConflicts nMin)
 
+	-- can't coalesce the same node
+	, nodeId nMin /= nodeId nMax
+
 	= coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 
 	-- don't do the coalescing after all
@@ -350,9 +361,6 @@ coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 	| not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
 	= error "GraphOps.coalesceNodes: can't coalesce colored nodes."
 
-	| nodeId nMin == nodeId nMax
-	= error "GraphOps.coalesceNodes: can't coalesce the same node."
-
 	---
 	| otherwise
 	= let
@@ -412,8 +420,7 @@ freezeNode
 freezeNode k
   = graphMapModify
   $ \fm ->
-    let
-    	-- freeze all the edges in the node to be frozen
+    let	-- freeze all the edges in the node to be frozen
     	Just node = lookupUFM fm k
 	node'	= node
 		{ nodeCoalesce		= emptyUniqSet }
@@ -423,11 +430,11 @@ freezeNode k
 	-- update back edges pointing to this node
 	freezeEdge k node
 	 = if elementOfUniqSet k (nodeCoalesce node)
-	 	then node
-			{ nodeCoalesce		= delOneFromUniqSet (nodeCoalesce node) k }
-		else	panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
+	 	then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }
+		else node 	-- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
+				-- If the edge isn't actually in the coelesce set then just ignore it.
 
-	fm2	= foldUniqSet (adjustUFM (freezeEdge k)) fm1
+	fm2	= foldUniqSet (adjustUFM_C (freezeEdge k)) fm1
 	   		$ nodeCoalesce node
 
     in	fm2
@@ -443,7 +450,7 @@ freezeNode k
 --	classes.. this is just a heuristic, after all.
 --
 --	IDEA:	freezing a node might free it up for Simplify.. would be good to check for triv
---		right here, and add it to a worklist if known triv/non-move nodes.
+--		right here, and add it to a worklist if known triv\/non-move nodes.
 --
 freezeOneInGraph
 	:: (Uniquable k, Outputable k)
@@ -597,7 +604,7 @@ setColor
 	
 setColor u color
  	= graphMapModify
- 	$ adjustUFM
+ 	$ adjustUFM_C
 		(\n -> n { nodeColor = Just color })
 		u 
 	
@@ -614,13 +621,14 @@ adjustWithDefaultUFM f def k map
 		map
 		k def
 		
-{-# INLINE adjustUFM #-}
-adjustUFM 
+-- Argument order different from UniqFM's adjustUFM
+{-# INLINE adjustUFM_C #-}
+adjustUFM_C 
 	:: Uniquable k
 	=> (a -> a)
 	-> k -> UniqFM a -> UniqFM a
 
-adjustUFM f k map
+adjustUFM_C f k map
  = case lookupUFM map k of
  	Nothing	-> map
 	Just a	-> addToUFM map k (f a)