X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FGraphOps.hs;h=414abe4efce0489ebd138c563615252aaac166e5;hb=86f1f4e0748ba1146cf74786af38a68a88164e2f;hp=78698ff96289a1d6e82ba7820ed7736cb66da0ff;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/GraphOps.hs b/compiler/nativeGen/GraphOps.hs
index 78698ff..414abe4 100644
--- a/compiler/nativeGen/GraphOps.hs
+++ b/compiler/nativeGen/GraphOps.hs
@@ -1,13 +1,8 @@
-
 -- | Basic operations on graphs.
 --
+--	TODO: refine coalescing crieteria
 
-{-# OPTIONS -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/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
 
 module GraphOps (
 	addNode, 	delNode,	getNode,	lookupNode,	modNode,
@@ -17,8 +12,9 @@ module GraphOps (
 	addCoalesce,	delCoalesce,	
 	addExclusion,	
 	addPreference,
-	coalesceGraph,
-	coalesceNodes,
+	coalesceNodes,	coalesceGraph,
+	freezeNode,	freezeOneInGraph, freezeAllInGraph,
+	scanGraph,
 	setColor,
 	validateGraph,
 	slurpNodeConflictCount
@@ -35,7 +31,6 @@ import UniqFM
 import Data.List	hiding (union)
 import Data.Maybe
 
-
 -- | Lookup a node from the graph.
 lookupNode 
 	:: Uniquable k
@@ -83,28 +78,28 @@ addNode k node graph
   	{ graphMap	= addToUFM map_coalesce k node}
 		
 
-
 -- | Delete a node and all its edges from the graph.
---	Throws an error if it's not there.
-delNode :: Uniquable k
-	=> k -> Graph k cls color -> Graph k cls color
+delNode :: (Uniquable k, Outputable k)
+	=> k -> Graph k cls color -> Maybe (Graph k cls color)
 
 delNode k graph
- = let	Just node	= lookupNode graph k
-
-	-- delete conflict edges from other nodes to this one.
-	graph1		= foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
+	| Just node	<- lookupNode graph k
+	= let	-- delete conflict edges from other nodes to this one.
+		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 -> let Just g' = delCoalesce k1 k g in g') graph1
+		-- delete coalesce edge from other nodes to this one.
+		graph2	= foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
 			$ uniqSetToList (nodeCoalesce node)
 	
-	-- delete the node
-	graph3		= graphMapModify (\fm -> delFromUFM fm k) graph2
+		-- delete the node
+		graph3	= graphMapModify (\fm -> delFromUFM fm k) graph2
 	
-  in	graph3
+	  in	Just graph3
 		
+	| otherwise
+	= Nothing
+
 
 -- | Modify a node in the graph.
 --	returns Nothing if the node isn't present.
@@ -125,6 +120,7 @@ modNode f k graph
 
 	Nothing	-> Nothing
 
+
 -- | Get the size of the graph, O(n)
 size	:: Uniquable k 
 	=> Graph k cls color -> Int
@@ -140,8 +136,6 @@ union	:: Uniquable k
 union	graph1 graph2
 	= Graph 
 	{ graphMap		= plusUFM (graphMap graph1) (graphMap graph2) }
-	 
-	
 
 
 -- | Add a conflict between nodes to the graph, creating the nodes required.
@@ -195,13 +189,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
@@ -275,10 +269,16 @@ addPreference (u, c) color
 --
 coalesceGraph
 	:: (Uniquable k, Ord k, Eq cls, Outputable k)
-	=>  Graph k cls color
+	=> Bool			-- ^ If True, coalesce nodes even if this might make the graph
+				--	less colorable (aggressive coalescing)
+	-> Triv k cls color
+	-> Graph k cls color
 	-> (Graph k cls color, [(k, k)])
 
-coalesceGraph graph
+coalesceGraph aggressive triv graph
+	= coalesceGraph' aggressive triv graph []
+
+coalesceGraph' aggressive triv graph kkPairsAcc
  = let
  	-- find all the nodes that have coalescence edges
 	cNodes	= filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
@@ -297,9 +297,12 @@ coalesceGraph graph
 	-- do the coalescing, returning the new graph and a list of pairs of keys
 	--	that got coalesced together.
 	(graph', mPairs)
-		= mapAccumL coalesceNodes graph cList
+		= mapAccumL (coalesceNodes aggressive triv) graph cList
 
-   in	(graph', catMaybes mPairs)
+	-- 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)
 
 
 -- | Coalesce this pair of nodes unconditionally / agressively.
@@ -312,32 +315,33 @@ coalesceGraph graph
 
 coalesceNodes
 	:: (Uniquable k, Ord k, Eq cls, Outputable k)
-	=> Graph k cls color
+	=> 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 graph (k1, k2)
+coalesceNodes aggressive triv graph (k1, k2)
 	| (kMin, kMax)	<- if k1 < k2
 				then (k1, k2)
 				else (k2, k1)
 
-	-- nodes must be in the graph
+	-- the nodes being coalesced must be in the graph
 	, Just nMin	<- lookupNode graph kMin
 	, Just nMax	<- lookupNode graph kMax
 
-	-- can't coalesce conflicting nodes
+	-- can't coalesce conflicting modes
 	, not $ elementOfUniqSet kMin (nodeConflicts nMax)
 	, not $ elementOfUniqSet kMax (nodeConflicts nMin)
 
-	= coalesceNodes' graph kMin kMax nMin nMax
+	= coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 
-
-
-	-- one of the nodes wasn't in the graph anymore
+	-- don't do the coalescing after all
 	| otherwise
 	= (graph, Nothing)
 
-coalesceNodes' graph kMin kMax nMin nMax
+coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 
 	-- sanity checks
 	| nodeClass nMin /= nodeClass nMax
@@ -346,6 +350,9 @@ coalesceNodes' 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
@@ -371,15 +378,125 @@ coalesceNodes' graph kMin kMax nMin nMax
 					`delOneFromUniqSet` kMax
 			}
 
-		-- delete the old nodes from the graph and add the new one
-	 	graph'	= addNode kMin node
-	  		$ delNode kMin
-			$ delNode kMax
-			$ graph
+	  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
+		Just graph1	= delNode kMax graph
+		Just graph2	= delNode kMin graph1
+		graph3		= addNode kMin node graph2
+
+	  in	(graph3, Just (kMax, kMin))
+
+
+-- | Freeze a node
+--	This is for the iterative coalescer.
+--	By freezing a node we give up on ever coalescing it.
+--	Move all its coalesce edges into the frozen set - and update
+--	back edges from other nodes.
+--
+freezeNode
+	:: Uniquable k
+	=> k			-- ^ key of the node to freeze
+	-> Graph k cls color	-- ^ the graph
+	-> Graph k cls color	-- ^ graph with that node frozen
+
+freezeNode k
+  = graphMapModify
+  $ \fm ->
+    let
+    	-- freeze all the edges in the node to be frozen
+    	Just node = lookupUFM fm k
+	node'	= node
+		{ nodeCoalesce		= emptyUniqSet }
+
+	fm1	= addToUFM fm k node'
+
+	-- 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"
+
+	fm2	= foldUniqSet (adjustUFM (freezeEdge k)) fm1
+	   		$ nodeCoalesce node
+
+    in	fm2
+
+
+-- | Freeze one node in the graph
+--	This if for the iterative coalescer.
+--	Look for a move related node of low degree and freeze it.
+--
+--	We probably don't need to scan the whole graph looking for the node of absolute
+--	lowest degree. Just sample the first few and choose the one with the lowest 
+--	degree out of those. Also, we don't make any distinction between conflicts of different
+--	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.
+--
+freezeOneInGraph
+	:: (Uniquable k, Outputable k)
+	=> Graph k cls color
+	-> ( Graph k cls color		-- the new graph
+	   , Bool )			-- whether we found a node to freeze
+
+freezeOneInGraph graph
+ = let	compareNodeDegree n1 n2
+		= compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
+
+	candidates
+		= sortBy compareNodeDegree
+		$ take 5	-- 5 isn't special, it's just a small number.
+		$ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
+
+   in	case candidates of
+
+	 -- there wasn't anything available to freeze
+   	 []	-> (graph, False)
+
+	 -- we found something to freeze
+	 (n : _)
+	  -> ( freezeNode (nodeId n) graph
+	     , True)
+
+
+-- | Freeze all the nodes in the graph
+--	for debugging the iterative allocator.
+--
+freezeAllInGraph
+	:: (Uniquable k, Outputable k)
+	=> Graph k cls color
+	-> Graph k cls color
+
+freezeAllInGraph graph
+	= foldr freezeNode graph
+   		$ map nodeId
+		$ eltsUFM $ graphMap graph
+
+
+-- | Find all the nodes in the graph that meet some criteria
+--
+scanGraph
+	:: Uniquable k
+	=> (Node k cls color -> Bool)
+	-> Graph k cls color
+	-> [Node k cls color]
+
+scanGraph match graph
+	= filter match $ eltsUFM $ graphMap graph
 
-	  in	(graph', Just (kMax, kMin))
 
-		
 -- | validate the internal structure of a graph
 --	all its edges should point to valid nodes
 --	if they don't then throw an error
@@ -391,12 +508,10 @@ validateGraph
 	-> Graph k cls color
 
 validateGraph doc graph
- = let	edges	= unionUniqSets
- 			(unionManyUniqSets
- 				(map nodeConflicts $ eltsUFM $ graphMap graph))
-			(unionManyUniqSets
-				(map nodeCoalesce  $ eltsUFM $ graphMap graph))
-				
+ = let	edges	= unionManyUniqSets
+ 			(  (map nodeConflicts       $ eltsUFM $ graphMap graph)
+			++ (map nodeCoalesce        $ eltsUFM $ graphMap graph))
+
 	nodes	= mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
 	
 	badEdges = minusUniqSet edges nodes
@@ -419,7 +534,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
@@ -441,6 +556,7 @@ setColor u color
 		u 
 	
 
+{-# INLINE 	adjustWithDefaultUFM #-}
 adjustWithDefaultUFM 
 	:: Uniquable k 
 	=> (a -> a) -> a -> k 
@@ -448,11 +564,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)
@@ -462,5 +578,4 @@ adjustUFM f k map
  = case lookupUFM map k of
  	Nothing	-> map
 	Just a	-> addToUFM map k (f a)
-