From 589238c4c2712d29092086926cc48eeb5e9b8fa7 Mon Sep 17 00:00:00 2001
From: "Ben.Lippmeier@anu.edu.au" <unknown>
Date: Tue, 28 Aug 2007 14:44:24 +0000
Subject: [PATCH] Add coalescence edges back to the register graph

---
 compiler/nativeGen/GraphColor.hs    |    2 +-
 compiler/nativeGen/RegAllocColor.hs |   17 +++++++++-------
 compiler/nativeGen/RegLiveness.hs   |   38 ++++++++++++++++++++++++++---------
 3 files changed, 39 insertions(+), 18 deletions(-)

diff --git a/compiler/nativeGen/GraphColor.hs b/compiler/nativeGen/GraphColor.hs
index bdd708a..71f7f6d 100644
--- a/compiler/nativeGen/GraphColor.hs
+++ b/compiler/nativeGen/GraphColor.hs
@@ -152,7 +152,7 @@ selectColor colors graph u
 	Just colors_avail
 			= lookupUFM colors (nodeClass node)
 
-	-- colors we can't use because they're already being used
+	-- find colors we can't use because they're already being used
 	--	by a node that conflicts with this one.
 	Just nsConflicts 	
 			= sequence
diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 27b603c..c49a94d 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -34,7 +34,6 @@ import RegSpillClean
 import RegAllocStats
 import MachRegs
 import MachInstrs
-import RegCoalesce
 import PprMach
 
 import UniqSupply
@@ -214,16 +213,20 @@ buildGraph
 	
 buildGraph code
  = do
- 	-- Add the reg-reg conflicts to the graph
-	let conflictSets	= unionManyBags (map slurpConflicts code)
-	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictSets
+	-- Slurp out the conflicts and reg->reg moves from this code
+	let (conflictList, moveList) =
+		unzip $ map slurpConflicts code
+
+	let conflictBag		= unionManyBags conflictList
+	let moveBag		= unionManyBags moveList
 
+ 	-- Add the reg-reg conflicts to the graph
+	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictBag
 
 	-- Add the coalescences edges to the graph.
-	let coalesce		= unionManyBags (map slurpJoinMovs code)
-	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict coalesce
+	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict moveBag
 			
-	return	$ graph_coalesce
+	return	graph_coalesce
 
 
 -- | Add some conflict edges to the graph.
diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 737ce5a..81d993b 100644
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -184,11 +184,13 @@ mapGenBlockTopM f (CmmProc header label params blocks)
  	return	$ CmmProc header label params blocks'
 
 
--- | Slurp out the list of register conflicts from this top level thing.
-
-slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
+-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
+--	Slurping of conflicts and moves is wrapped up together so we don't have
+--	to make two passes over the same code when we want to build the graph.
+--
+slurpConflicts :: LiveCmmTop -> (Bag (UniqSet Reg), Bag (Reg, Reg))
 slurpConflicts live
-	= slurpCmm emptyBag live
+	= slurpCmm (emptyBag, emptyBag) live
 
  where	slurpCmm   rs  CmmData{}		= rs
  	slurpCmm   rs (CmmProc info _ _ blocks)	
@@ -200,12 +202,18 @@ slurpConflicts live
 	slurpBlock info rs (BasicBlock blockId instrs)	
 		| LiveInfo _ _ blockLive	<- info
 		, Just rsLiveEntry		<- lookupUFM blockLive blockId
-		= consBag rsLiveEntry $ slurpLIs rsLiveEntry rs instrs
+		, (conflicts, moves)		<- slurpLIs rsLiveEntry rs instrs
+		= (consBag rsLiveEntry conflicts, moves)
+
+		| otherwise
+		= error "RegLiveness.slurpBlock: bad block"
+
+	slurpLIs rsLive (conflicts, moves) []
+		= (consBag rsLive conflicts, moves)
 
-	slurpLIs rsLive rs []				= consBag rsLive rs
 	slurpLIs rsLive rs (Instr _ Nothing     : lis)	= slurpLIs rsLive rs lis
 		
-	slurpLIs rsLiveEntry rs (li@(Instr _ (Just live)) : lis)
+	slurpLIs rsLiveEntry (conflicts, moves) (li@(Instr instr (Just live)) : lis)
 	 = let
 		-- regs that die because they are read for the last time at the start of an instruction
 		--	are not live across it.
@@ -227,7 +235,14 @@ slurpConflicts live
 		--
 		rsConflicts	= unionUniqSets rsLiveNext rsOrphans
 
-	  in	slurpLIs rsLiveNext (consBag rsConflicts rs) lis
+	  in	case isRegRegMove instr of
+	  	 Just rr	-> slurpLIs rsLiveNext
+		 			( consBag rsConflicts conflicts
+					, consBag rr moves) lis
+
+	  	 Nothing	-> slurpLIs rsLiveNext
+		 			( consBag rsConflicts conflicts
+					, moves) lis
 
 
 -- | Strip away liveness information, yielding NatCmmTop
@@ -248,10 +263,10 @@ stripLive live
 -- | Make real spill instructions out of SPILL, RELOAD pseudos
 
 spillNatBlock :: NatBasicBlock -> NatBasicBlock
-spillNatBlock (BasicBlock i instrs)
+spillNatBlock (BasicBlock i is)
  = 	BasicBlock i instrs'
  where 	(instrs', _)
- 		= runState (spillNat [] instrs) 0
+ 		= runState (spillNat [] is) 0
 
 	spillNat acc []
 	 = 	return (reverse acc)
@@ -292,6 +307,9 @@ lifetimeCount cmm
 		| LiveInfo _ _ blockLive	<- info
 		, Just rsLiveEntry		<- lookupUFM blockLive blockId
 		= countLIs rsLiveEntry fm instrs
+
+		| otherwise
+		= error "RegLiveness.countBlock: bad block"
 		
 	countLIs rsLive fm []				= fm
 	countLIs rsLive fm (Instr _ Nothing : lis)	= countLIs rsLive fm lis
-- 
1.7.10.4