Try and allocate vregs spilled/reloaded from some slot to the same hreg

compiler/nativeGen/RegAllocColor.hs

@@ -119,7 +119,7 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 
 	-- rewrite regs in the code that have been coalesced
 	let patchF reg	= case lookupUFM rmCoalesce reg of
-				Just reg'	-> reg'
+				Just reg'	-> patchF reg'
 				Nothing		-> reg
 	let code_coalesced
 			= map (patchEraseLive patchF) code
@@ -246,16 +246,18 @@ buildGraph code
 	let (conflictList, moveList) =
 		unzip $ map slurpConflicts code
 
-	let conflictBag		= unionManyBags conflictList
-	let moveBag		= unionManyBags moveList
+	-- Slurp out the spill/reload coalesces
+	let moveList2		= map slurpReloadCoalesce code
 
  	-- Add the reg-reg conflicts to the graph
+	let conflictBag		= unionManyBags conflictList
 	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictBag
 
 	-- Add the coalescences edges to the graph.
+	let moveBag		= unionBags (unionManyBags moveList2) (unionManyBags moveList)
 	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict moveBag
 			
-	return	graph_coalesce
+	return	$ Color.validateGraph (text "urk") graph_coalesce
 
 
 -- | Add some conflict edges to the graph.
@@ -326,7 +328,7 @@ patchRegsFromGraph graph code
 			(  text "There is no node in the graph for register " <> ppr reg
 			$$ ppr code
 			$$ Color.dotGraph (\_ -> text "white") trivColorable graph)
-	
+
    in	patchEraseLive patchF code
    
 

compiler/nativeGen/RegLiveness.hs

@@ -22,6 +22,7 @@ module RegLiveness (
 	stripLive,
 	spillNatBlock,
 	slurpConflicts,
+	slurpReloadCoalesce,
 	lifetimeCount,
 	eraseDeltasLive,
 	patchEraseLive,
@@ -244,6 +245,51 @@ slurpConflicts live
 					, moves) lis
 
 
+-- | For spill/reloads
+--
+--	SPILL  v1, slot1
+--	...
+--	RELOAD slot1, v2
+--
+--	If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
+--	the spill/reload instrs can be cleaned and replaced by a nop reg-reg move.
+--
+-- 	TODO: This only works intra-block at the momement. It's be nice to join up the mappings
+--	      across blocks also.
+--
+slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg)
+slurpReloadCoalesce live
+	= slurpCmm emptyBag live
+
+ where	slurpCmm cs CmmData{}	= cs
+ 	slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
+		= foldl' slurpComp cs blocks
+
+	slurpComp  cs (BasicBlock _ blocks)
+		= foldl' slurpBlock cs blocks
+
+	slurpBlock cs (BasicBlock _ instrs)
+	 = let	(_, mMoves)	= mapAccumL slurpLI emptyUFM instrs
+	   in	unionBags cs (listToBag $ catMaybes mMoves)
+
+	slurpLI :: UniqFM Reg -> LiveInstr -> (UniqFM Reg, Maybe (Reg, Reg))
+	slurpLI slotMap (Instr instr _)
+
+		-- remember what reg was stored into the slot
+		| SPILL reg slot	<- instr
+		, slotMap'		<- addToUFM slotMap slot reg
+		= (slotMap', Nothing)
+
+		-- add an edge betwen the this reg and the last one stored into the slot
+		| RELOAD slot reg	<- instr
+		= case lookupUFM slotMap slot of
+			Just reg2	-> (slotMap, Just (reg, reg2))
+			Nothing		-> (slotMap, Nothing)
+
+		| otherwise
+		= (slotMap, Nothing)
+
+
 -- | Strip away liveness information, yielding NatCmmTop
 
 stripLive :: LiveCmmTop -> NatCmmTop