X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegLiveness.hs;h=9ee98971baf49e320983970c1a357f8b4dda386f;hb=97169c5dd31537b28f5f8ad08cd6cdf82c1ecefd;hp=5b867f3eff3f0e86b26935b5b67cf73fd02cc6d3;hpb=16dc208aaad7aadaea970e47b8055d7d7f8781e5;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 5b867f3..9ee9897 100644
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -5,7 +5,7 @@
 -- (c) The University of Glasgow 2004
 --
 -----------------------------------------------------------------------------
-{-# OPTIONS -fno-warn-missing-signatures #-}
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
 
 module RegLiveness (
 	RegSet,
@@ -22,7 +22,7 @@ module RegLiveness (
 	stripLive,
 	spillNatBlock,
 	slurpConflicts,
-	lifetimeCount,
+	slurpReloadCoalesce,
 	eraseDeltasLive,
 	patchEraseLive,
 	patchRegsLiveInstr,
@@ -36,7 +36,7 @@ import MachRegs
 import MachInstrs
 import PprMach
 import RegAllocInfo
-import Cmm
+import Cmm hiding (RegSet)
 
 import Digraph
 import Outputable
@@ -154,6 +154,7 @@ mapBlockTopM f (CmmProc header label params (ListGraph comps))
  = do	comps'	<- mapM (mapBlockCompM f) comps
  	return	$ CmmProc header label params (ListGraph comps')
 
+mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a')
 mapBlockCompM f (BasicBlock i blocks)
  = do	blocks'	<- mapM f blocks
  	return	$ BasicBlock i blocks'
@@ -243,6 +244,100 @@ 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.
+--
+--
+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 comp
+	 = let	(moveBags, _)	= runState (slurpCompM comp) emptyUFM
+	   in	unionManyBags (cs : moveBags)
+
+	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 slotMap (Instr instr _)
+
+		-- remember what reg was stored into the slot
+		| SPILL reg slot	<- instr
+		, slotMap'		<- addToUFM slotMap slot reg
+		= 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	-> return (slotMap, Just (reg, reg2))
+			 | otherwise	-> return (slotMap, Nothing)
+
+			Nothing		-> return (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
+		= 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
 
 stripLive :: LiveCmmTop -> NatCmmTop
@@ -285,48 +380,6 @@ spillNatBlock (BasicBlock i is)
 	 =	spillNat (instr : acc) instrs
 
 
--- | Slurp out a map of how many times each register was live upon entry to an instruction.
-
-lifetimeCount
-	:: LiveCmmTop
-	-> UniqFM (Reg, Int)	-- ^ reg -> (reg, count)
-
-lifetimeCount cmm
-	= countCmm emptyUFM cmm
- where
-	countCmm fm  CmmData{}		= fm
-	countCmm fm (CmmProc info _ _ (ListGraph blocks))
-		= foldl' (countComp info) fm blocks
-		
-	countComp info fm (BasicBlock _ blocks)
-		= foldl' (countBlock info) fm blocks
-		
- 	countBlock info fm (BasicBlock blockId instrs)
-		| LiveInfo _ _ blockLive	<- info
-		, Just rsLiveEntry		<- lookupUFM blockLive blockId
-		= countLIs rsLiveEntry fm instrs
-
-		| otherwise
-		= error "RegLiveness.countBlock: bad block"
-		
-	countLIs _      fm []				= fm
-	countLIs rsLive fm (Instr _ Nothing : lis)	= countLIs rsLive fm lis
-	
-	countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
-	 = let
-	 	rsLiveAcross	= rsLiveEntry `minusUniqSet` (liveDieRead live)
-
-	 	rsLiveNext 	= (rsLiveAcross `unionUniqSets` (liveBorn     live))
-					         `minusUniqSet` (liveDieWrite live)
-
-		add r fm	= addToUFM_C
-					(\(r1, l1) (_, l2) -> (r1, l1 + l2))
-					fm r (r, 1)
-
-		fm'		= foldUniqSet add fm rsLiveEntry
-	   in	countLIs rsLiveNext fm' lis
-	   
-
 -- | Erase Delta instructions.
 
 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
@@ -588,6 +641,7 @@ livenessBack liveregs blockmap acc (instr : instrs)
    in	livenessBack liveregs' blockmap (instr' : acc) instrs
 
 -- don't bother tagging comments or deltas with liveness
+liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr)
 liveness1 liveregs _   (instr@COMMENT{})
 	= (liveregs, Instr instr Nothing)