Try and rewrite reloads to reg-reg moves in the spill cleaner

compiler/nativeGen/RegLiveness.hs

@@ -254,8 +254,6 @@ slurpConflicts live
 --	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
@@ -265,32 +263,80 @@ slurpReloadCoalesce live
  	slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
 		= foldl' slurpComp cs blocks
 
-	slurpComp  cs (BasicBlock _ blocks)
-		= foldl' slurpBlock cs blocks
+	slurpComp  cs comp
+	 = let	(moveBags, _)	= runState (slurpCompM comp) emptyUFM
+	   in	unionManyBags (cs : moveBags)
 
-	slurpBlock cs (BasicBlock _ instrs)
-	 = let	(_, mMoves)	= mapAccumL slurpLI emptyUFM instrs
-	   in	unionBags cs (listToBag $ catMaybes mMoves)
+	slurpCompM (BasicBlock _ blocks)
+	 = do	-- run the analysis once to record the mapping across jumps.
+	 	mapM_	(slurpBlock False) blocks
+
+		-- run it a second time while using the information from the last pass.
+		--	We /could/ run this many more times to deal with graphical control
+		--	flow and propagating info across multiple jumps, but it's probably
+		--	not worth the trouble.
+		mapM	(slurpBlock True) blocks
+
+	slurpBlock propagate (BasicBlock blockId instrs)
+	 = do	-- grab the slot map for entry to this block
+	 	slotMap		<- if propagate
+					then getSlotMap blockId
+					else return emptyUFM
+
+	 	(_, mMoves)	<- mapAccumLM slurpLI slotMap instrs
+	   	return $ listToBag $ catMaybes mMoves
+
+	slurpLI :: UniqFM Reg 				-- current slotMap
+		-> LiveInstr
+		-> State (UniqFM [UniqFM Reg]) 		-- blockId -> [slot -> reg]
+							-- 	for tracking slotMaps across jumps
+
+			 ( UniqFM Reg			-- new slotMap
+			 , Maybe (Reg, Reg))		-- maybe a new coalesce edge
 
-	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)
+		= return (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)
+			 | reg /= reg2	-> return (slotMap, Just (reg, reg2))
+			 | otherwise	-> return (slotMap, Nothing)
+
+			Nothing		-> return (slotMap, Nothing)
 
-			Nothing		-> (slotMap, Nothing)
+		-- if we hit a jump, remember the current slotMap
+		| targets	<- jumpDests instr []
+		, not $ null targets
+		= do	mapM_	(accSlotMap slotMap) targets
+			return	(slotMap, Nothing)
 
 		| otherwise
-		= (slotMap, Nothing)
+		= return (slotMap, Nothing)
+
+	-- record a slotmap for an in edge to this block
+	accSlotMap slotMap blockId
+		= modify (\s -> addToUFM_C (++) s blockId [slotMap])
+
+	-- work out the slot map on entry to this block
+	--	if we have slot maps for multiple in-edges then we need to merge them.
+	getSlotMap blockId
+	 = do	map		<- get
+	 	let slotMaps	= fromMaybe [] (lookupUFM map blockId)
+		return		$ foldr mergeSlotMaps emptyUFM slotMaps
+
+	mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
+	mergeSlotMaps map1 map2
+		= listToUFM
+		$ [ (k, r1)	| (k, r1)	<- ufmToList map1
+				, case lookupUFM map2 k of
+					Nothing	-> False
+					Just r2	-> r1 == r2 ]
 
 
 -- | Strip away liveness information, yielding NatCmmTop

compiler/nativeGen/RegSpillClean.hs

@@ -101,7 +101,7 @@ cleanBlock (BasicBlock id instrs)
 				Just assoc	-> assoc
 				Nothing		-> emptyAssoc
 
- 	instrs_reload	<- cleanReload assoc        [] instrs
+ 	instrs_reload	<- cleanFwd    assoc        [] instrs
  	instrs_spill	<- cleanSpill  emptyUniqSet [] instrs_reload
 	return	$ BasicBlock id instrs_spill
 
@@ -111,36 +111,36 @@ cleanBlock (BasicBlock id instrs)
 --	  On a reload, if we know a reg already has the same value as a slot
 --	  then we don't need to do the reload.
 --
-cleanReload
+cleanFwd
 	:: Assoc Store	 	-- ^ two store locations are associated if they have the same value
 	-> [LiveInstr]		-- ^ acc
 	-> [LiveInstr] 		-- ^ instrs to clean (in backwards order)
 	-> CleanM [LiveInstr]	-- ^ cleaned instrs  (in forward   order)
 
-cleanReload _ acc []
+cleanFwd _ acc []
 	= return acc
 
 -- write out live range joins via spill slots to just a spill and a reg-reg move
 --	hopefully the spill will be also be cleaned in the next pass
 --
-cleanReload assoc acc (Instr i1 live1 : Instr i2 _ : instrs)
+cleanFwd assoc acc (Instr i1 live1 : Instr i2 _ : instrs)
 
 	| SPILL  reg1  slot1	<- i1
 	, RELOAD slot2 reg2	<- i2
 	, slot1 == slot2
 	= do
 		modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
-		cleanReload assoc acc
+		cleanFwd assoc acc
 			(Instr i1 live1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
 
 
-cleanReload assoc acc (li@(Instr i1 _) : instrs)
+cleanFwd assoc acc (li@(Instr i1 _) : instrs)
 	| Just (r1, r2)	<- isRegRegMove i1
 	= if r1 == r2
 		-- erase any left over nop reg reg moves while we're here
 		--	this will also catch any nop moves that the "write out live range joins" case above
 		--	happens to add
-		then cleanReload assoc acc instrs
+		then cleanFwd assoc acc instrs
 
 		-- if r1 has the same value as some slots and we copy r1 to r2,
 		--	then r2 is now associated with those slots instead
@@ -148,43 +148,69 @@ cleanReload assoc acc (li@(Instr i1 _) : instrs)
 					$ delAssoc (SReg r2)
 					$ assoc
 
-			cleanReload assoc' (li : acc) instrs
+			cleanFwd assoc' (li : acc) instrs
 
 
-cleanReload assoc acc (li@(Instr instr _) : instrs)
+cleanFwd assoc acc (li@(Instr instr _) : instrs)
 
 	| SPILL reg slot	<- instr
 	= let	assoc'	= addAssoc (SReg reg)  (SSlot slot)	-- doing the spill makes reg and slot the same value
 			$ delAssoc (SSlot slot) 		-- slot value changes on spill
 			$ assoc
-	  in	cleanReload assoc' (li : acc) instrs
+	  in	cleanFwd assoc' (li : acc) instrs
 
-	| RELOAD slot reg	<- instr
-	= if elemAssoc (SSlot slot) (SReg reg) assoc
-
-           -- if the reg and slot had the same value before reload
-	   --	then we don't need the reload.
-	   then	do
-		modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
-	   	cleanReload assoc acc instrs
-
-	   -- reg and slot had different values before reload
-	   else
-	    let assoc'	= addAssoc (SReg reg)  (SSlot slot)	-- doing the reload makes reg and slot the same value
-			$ delAssoc (SReg reg)			-- reg value changes on reload
-			$ assoc
-	    in	cleanReload assoc' (li : acc) instrs
+	-- clean a reload instr
+	| RELOAD{}		<- instr
+	= do	(assoc', mli)	<- cleanReload assoc li
+		case mli of
+			Nothing		-> cleanFwd assoc' acc 		instrs
+			Just li'	-> cleanFwd assoc' (li' : acc)	instrs
 
 	-- remember the association over a jump
 	| targets	<- jumpDests instr []
 	, not $ null targets
 	= do	mapM_ (accJumpValid assoc) targets
-		cleanReload assoc (li : acc) instrs
+		cleanFwd assoc (li : acc) instrs
 
 	-- writing to a reg changes its value.
 	| RU _ written	<- regUsage instr
 	= let assoc'	= foldr delAssoc assoc (map SReg $ nub written)
-	  in  cleanReload assoc' (li : acc) instrs
+	  in  cleanFwd assoc' (li : acc) instrs
+
+
+-- | Try and rewrite a reload instruction to something more pleasing
+--
+cleanReload :: Assoc Store -> LiveInstr -> CleanM (Assoc Store, Maybe LiveInstr)
+cleanReload assoc li@(Instr (RELOAD slot reg) _)
+
+	-- if the reg we're reloading already has the same value as the slot
+	--	then we can erase the instruction outright
+	| elemAssoc (SSlot slot) (SReg reg) assoc
+	= do 	modify 	$ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+	   	return	(assoc, Nothing)
+
+	-- if we can find another reg with the same value as this slot then
+	--	do a move instead of a reload.
+	| Just reg2	<- findRegOfSlot assoc slot
+	= do	modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+
+		let assoc'	= addAssoc (SReg reg) (SReg reg2)
+				$ delAssoc (SReg reg)
+				$ assoc
+
+		return	(assoc', Just $ Instr (mkRegRegMoveInstr reg2 reg) Nothing)
+
+	-- gotta keep this instr
+	--	update the association
+	| otherwise
+	= do	let assoc'	= addAssoc (SReg reg)  (SSlot slot)	-- doing the reload makes reg and slot the same value
+				$ delAssoc (SReg reg)			-- reg value changes on reload
+				$ assoc
+
+	    	return	(assoc', Just li)
+
+cleanReload _ _
+	= panic "RegSpillClean.cleanReload: unhandled instr"
 
 
 -- | Clean out unneeded spill instructions.
@@ -240,6 +266,16 @@ intersects []		= emptyAssoc
 intersects assocs	= foldl1' intersectAssoc assocs
 
 
+-- | See if we have a reg with the same value as this slot in the association table.
+findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
+findRegOfSlot assoc slot
+	| close			<- closeAssoc (SSlot slot) assoc
+	, Just (SReg reg)	<- find isStoreReg $ uniqSetToList close
+	= Just reg
+
+	| otherwise
+	= Nothing
+
 
 ---------------
 type CleanM = State CleanS
@@ -288,6 +324,13 @@ data Store
 	= SSlot Int
 	| SReg  Reg
 
+-- | Check if this is a reg store
+isStoreReg :: Store -> Bool
+isStoreReg ss
+ = case ss of
+ 	SSlot _	-> False
+	SReg  _	-> True
+
 -- spill cleaning is only done once all virtuals have been allocated to realRegs
 --
 instance Uniquable Store where