X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FnativeGen%2FRegLiveness.hs;h=b55d8c097f0303158dc76024c283a14ba31ca6dd;hb=75879a1e1a0a22d3a7218efd71017af724262704;hp=98aefb09521dc7fa578f8544a238be5a7769c4a4;hpb=fd8d04119e849f9c713d3e697228846d93c5ca69;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 98aefb0..b55d8c0 100644
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -22,6 +22,7 @@ module RegLiveness (
 	stripLive,
 	spillNatBlock,
 	slurpConflicts,
+	slurpReloadCoalesce,
 	lifetimeCount,
 	eraseDeltasLive,
 	patchEraseLive,
@@ -244,6 +245,54 @@ 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
+			 | reg /= reg2	-> (slotMap, Just (reg, reg2))
+			 | otherwise	-> (slotMap, Nothing)
+
+			Nothing		-> (slotMap, Nothing)
+
+		| otherwise
+		= (slotMap, Nothing)
+
+
 -- | Strip away liveness information, yielding NatCmmTop
 
 stripLive :: LiveCmmTop -> NatCmmTop