Do conservative coalescing in register allocator

Avoid coalescing nodes in the register conflict graph if the
new node will not be trivially colorable. Also remove the
front end aggressive coalescing pass.
  
For typical Haskell code the graph coloring allocator now does
about as well as the linear allocator.
  
For code with a large amount of register pressure it does much
better, but takes longer.
  
For SHA1.lhs from darcs on x86
   
          spills    reloads    reg-reg-moves
          inserted   inserted  left in code   compile-time
  linear    1068      1311        229            7.69(s)
  graph      387       902        340           16.12(s)

4 files changed, 34 insertions, 32 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 44bedce52d..de49e90d80 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -105,7 +105,6 @@ data DynFlag
    | Opt_D_dump_asm
    | Opt_D_dump_asm_native
    | Opt_D_dump_asm_liveness
-   | Opt_D_dump_asm_coalesce
    | Opt_D_dump_asm_regalloc
    | Opt_D_dump_asm_regalloc_stages
    | Opt_D_dump_asm_conflicts
@@ -1030,9 +1029,8 @@ dynamic_flags = [
   ,  ( "ddump-asm",          	 setDumpFlag Opt_D_dump_asm)
   ,  ( "ddump-asm-native",       setDumpFlag Opt_D_dump_asm_native)
   ,  ( "ddump-asm-liveness",     setDumpFlag Opt_D_dump_asm_liveness)
-  ,  ( "ddump-asm-coalesce",     setDumpFlag Opt_D_dump_asm_coalesce)
-  ,  ( "ddump-asm-regalloc",     setDumpFlag Opt_D_dump_asm_regalloc)
   ,  ( "ddump-asm-conflicts",    setDumpFlag Opt_D_dump_asm_conflicts)
+  ,  ( "ddump-asm-regalloc",     setDumpFlag Opt_D_dump_asm_regalloc)
   ,  ( "ddump-asm-regalloc-stages",
                                  setDumpFlag Opt_D_dump_asm_regalloc_stages)
   ,  ( "ddump-asm-stats",        setDumpFlag Opt_D_dump_asm_stats)
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 7a2bc88d64..8fdd31a40d 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -268,15 +268,6 @@ cmmNativeGen dflags us cmm
 				emptyUFM
 			$ map RealReg allocatableRegs
 
-		-- aggressively coalesce moves between virtual regs
-		let (coalesced, usCoalesce)
-			= {-# SCC "regCoalesce" #-}
-			  initUs usLive $ regCoalesce withLiveness
-
-		dumpIfSet_dyn dflags
-			Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
-			(vcat $ map ppr coalesced)
-
 	 	-- if any of these dump flags are turned on we want to hang on to
 		--	intermediate structures in the allocator - otherwise tell the
 		--	allocator to ditch them early so we don't end up creating space leaks.
@@ -288,12 +279,12 @@ cmmNativeGen dflags us cmm
 		-- graph coloring register allocation
 		let ((alloced, regAllocStats), usAlloc)
 			= {-# SCC "regAlloc(color)" #-}
-			  initUs usCoalesce
+			  initUs usLive
 			  $ Color.regAlloc
 				generateRegAllocStats
 				alloc_regs
 				(mkUniqSet [0..maxSpillSlots])
-				coalesced
+				withLiveness
 
 		-- dump out what happened during register allocation
 		dumpIfSet_dyn dflags
diff --git a/compiler/nativeGen/GraphColor.hs b/compiler/nativeGen/GraphColor.hs
index b5838c6342..ecebf27673 100644
--- a/compiler/nativeGen/GraphColor.hs
+++ b/compiler/nativeGen/GraphColor.hs
@@ -58,7 +58,7 @@ colorGraph colors triv spill graph0
  = let
  	-- do aggressive coalesing on the graph
  	(graph_coalesced, rsCoalesce)
-		= coalesceGraph graph0
+		= coalesceGraph triv graph0
 
  	-- run the scanner to slurp out all the trivially colorable nodes
   	(ksTriv, ksProblems)
diff --git a/compiler/nativeGen/GraphOps.hs b/compiler/nativeGen/GraphOps.hs
index 78698ff962..e61b9d1f96 100644
--- a/compiler/nativeGen/GraphOps.hs
+++ b/compiler/nativeGen/GraphOps.hs
@@ -275,10 +275,11 @@ addPreference (u, c) color
 --
 coalesceGraph
 	:: (Uniquable k, Ord k, Eq cls, Outputable k)
-	=>  Graph k cls color
+	=> Triv k cls color
+	-> Graph k cls color
 	-> (Graph k cls color, [(k, k)])
 
-coalesceGraph graph
+coalesceGraph triv graph
  = let
  	-- find all the nodes that have coalescence edges
 	cNodes	= filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
@@ -297,7 +298,7 @@ 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 False triv) graph cList
 
    in	(graph', catMaybes mPairs)
 
@@ -312,32 +313,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
-	, Just nMin	<- lookupNode graph kMin
-	, Just nMax	<- lookupNode graph kMax
+	-- 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
@@ -371,9 +373,20 @@ 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
+	  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