X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLiveness.hs;h=a2030fafa99369e9112341d070cfd3f3530900aa;hb=1f7ab811c4421458568b0ed900b496192fee885b;hp=61e800f46186c19fc6e45e7822dfb157fe526e19;hpb=1d5beef40a2611746f7345919e9b52f7904556bb;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 61e800f..a2030fa 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -18,7 +18,7 @@ module RegAlloc.Liveness (
 	LiveInfo (..),
 	LiveBasicBlock,
 
-	mapBlockTop, 	mapBlockTopM,
+	mapBlockTop, 	mapBlockTopM, 	mapSCCM,
 	mapGenBlockTop,	mapGenBlockTopM,
 	stripLive,
 	stripLiveBlock,
@@ -27,17 +27,16 @@ module RegAlloc.Liveness (
 	eraseDeltasLive,
 	patchEraseLive,
 	patchRegsLiveInstr,
+	reverseBlocksInTops,
 	regLiveness,
 	natCmmTopToLive
   ) where
-
-
 import Reg
 import Instruction
 
 import BlockId
-import Cmm hiding (RegSet)
-import PprCmm()
+import OldCmm hiding (RegSet)
+import OldPprCmm()
 
 import Digraph
 import Outputable
@@ -51,6 +50,9 @@ import FastString
 
 import Data.List
 import Data.Maybe
+import Data.Map			(Map)
+import Data.Set			(Set)
+import qualified Data.Map	as Map
 
 -----------------------------------------------------------------------------
 type RegSet = UniqSet Reg
@@ -62,9 +64,6 @@ emptyRegMap = emptyUFM
 
 type BlockMap a = BlockEnv a
 
-emptyBlockMap :: BlockEnv a
-emptyBlockMap = emptyBlockEnv
-
 
 -- | A top level thing which carries liveness information.
 type LiveCmmTop instr
@@ -159,9 +158,11 @@ data Liveness
 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
 data LiveInfo
 	= LiveInfo
-		[CmmStatic]			-- cmm static stuff
-		(Maybe BlockId)			-- id of the first block
-		(Maybe (BlockMap RegSet))	-- argument locals live on entry to this block
+		[CmmStatic]				-- cmm static stuff
+		(Maybe BlockId)				-- id of the first block
+		(Maybe (BlockMap RegSet))		-- argument locals live on entry to this block
+		(Map BlockId (Set Int))			-- stack slots live on entry to this block
+
 
 -- | A basic block with liveness information.
 type LiveBasicBlock instr
@@ -211,10 +212,11 @@ instance Outputable instr
 		 | otherwise		= name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
 
 instance Outputable LiveInfo where
-	ppr (LiveInfo static firstId liveOnEntry)
+	ppr (LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry)
 		=  (vcat $ map ppr static)
-		$$ text "# firstId     = " <> ppr firstId
-		$$ text "# liveOnEntry = " <> ppr liveOnEntry
+		$$ text "# firstId          = " <> ppr firstId
+		$$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
+		$$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
 
 
 
@@ -238,9 +240,9 @@ mapBlockTopM
 mapBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
-mapBlockTopM f (CmmProc header label params sccs)
+mapBlockTopM f (CmmProc header label sccs)
  = do	sccs'	<- mapM (mapSCCM f) sccs
- 	return	$ CmmProc header label params sccs'
+ 	return	$ CmmProc header label sccs'
 
 mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
 mapSCCM	f (AcyclicSCC x)	
@@ -270,9 +272,9 @@ mapGenBlockTopM
 mapGenBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
-mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
+mapGenBlockTopM f (CmmProc header label (ListGraph blocks))
  = do	blocks'	<- mapM f blocks
- 	return	$ CmmProc header label params (ListGraph blocks')
+ 	return	$ CmmProc header label (ListGraph blocks')
 
 
 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
@@ -288,7 +290,7 @@ slurpConflicts live
 	= slurpCmm (emptyBag, emptyBag) live
 
  where	slurpCmm   rs  CmmData{}		= rs
- 	slurpCmm   rs (CmmProc info _ _ sccs)
+ 	slurpCmm   rs (CmmProc info _ sccs)
 		= foldl' (slurpSCC info) rs sccs
 
 	slurpSCC  info rs (AcyclicSCC b)	
@@ -298,9 +300,9 @@ slurpConflicts live
 		= foldl'  (slurpBlock info) rs bs
 
 	slurpBlock info rs (BasicBlock blockId instrs)	
-		| LiveInfo _ _ (Just blockLive)	<- info
-		, Just rsLiveEntry		<- lookupBlockEnv blockLive blockId
-		, (conflicts, moves)		<- slurpLIs rsLiveEntry rs instrs
+		| LiveInfo _ _ (Just blockLive)	_ <- info
+		, Just rsLiveEntry		  <- mapLookup blockId blockLive
+		, (conflicts, moves)		  <- slurpLIs rsLiveEntry rs instrs
 		= (consBag rsLiveEntry conflicts, moves)
 
 		| otherwise
@@ -355,21 +357,30 @@ slurpConflicts live
 --
 --
 slurpReloadCoalesce 
-	:: Instruction instr
+	:: forall instr. Instruction instr
 	=> LiveCmmTop instr
 	-> Bag (Reg, Reg)
 
 slurpReloadCoalesce live
 	= slurpCmm emptyBag live
 
- where	slurpCmm cs CmmData{}	= cs
- 	slurpCmm cs (CmmProc _ _ _ sccs)
+ where	
+        slurpCmm :: Bag (Reg, Reg)
+                 -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
+                 -> Bag (Reg, Reg)
+        slurpCmm cs CmmData{}	= cs
+ 	slurpCmm cs (CmmProc _ _ sccs)
 		= slurpComp cs (flattenSCCs sccs)
 
+        slurpComp :: Bag (Reg, Reg)
+                     -> [LiveBasicBlock instr]
+                     -> Bag (Reg, Reg)
 	slurpComp  cs blocks
 	 = let	(moveBags, _)	= runState (slurpCompM blocks) emptyUFM
 	   in	unionManyBags (cs : moveBags)
 
+        slurpCompM :: [LiveBasicBlock instr]
+                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
 	slurpCompM blocks
 	 = do	-- run the analysis once to record the mapping across jumps.
 	 	mapM_	(slurpBlock False) blocks
@@ -380,6 +391,8 @@ slurpReloadCoalesce live
 		--	not worth the trouble.
 		mapM	(slurpBlock True) blocks
 
+        slurpBlock :: Bool -> LiveBasicBlock instr
+                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
 	slurpBlock propagate (BasicBlock blockId instrs)
 	 = do	-- grab the slot map for entry to this block
 	 	slotMap		<- if propagate
@@ -389,8 +402,7 @@ slurpReloadCoalesce live
 	 	(_, mMoves)	<- mapAccumLM slurpLI slotMap instrs
 	   	return $ listToBag $ catMaybes mMoves
 
-	slurpLI :: Instruction instr
-		=> UniqFM Reg 				-- current slotMap
+	slurpLI :: UniqFM Reg 				-- current slotMap
 		-> LiveInstr instr
 		-> State (UniqFM [UniqFM Reg]) 		-- blockId -> [slot -> reg]
 							-- 	for tracking slotMaps across jumps
@@ -454,8 +466,7 @@ stripLive live
 	= stripCmm live
 
  where	stripCmm (CmmData sec ds)	= CmmData sec ds
-
- 	stripCmm (CmmProc (LiveInfo info (Just first_id) _) label params sccs)
+ 	stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs)
 	 = let	final_blocks	= flattenSCCs sccs
 		
 		-- make sure the block that was first in the input list
@@ -464,17 +475,17 @@ stripLive live
 		((first':_), rest')
 				= partition ((== first_id) . blockId) final_blocks
 
-	   in	CmmProc info label params
+	   in	CmmProc info label 
                           (ListGraph $ map stripLiveBlock $ first' : rest')
 
 	-- procs used for stg_split_markers don't contain any blocks, and have no first_id.
-	stripCmm (CmmProc (LiveInfo info Nothing _) label params [])
-	 =	CmmProc info label params (ListGraph [])
+	stripCmm (CmmProc (LiveInfo info Nothing _ _) label [])
+	 =	CmmProc info label (ListGraph [])
 
 	-- If the proc has blocks but we don't know what the first one was, then we're dead.
 	stripCmm proc
 		 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
-			
+
 
 -- | Strip away liveness information from a basic block,
 --	and make real spill instructions out of SPILL, RELOAD pseudos along the way.
@@ -529,7 +540,6 @@ eraseDeltasLive cmm
 -- | Patch the registers in this code according to this register mapping.
 --	also erase reg -> reg moves when the reg is the same.
 --	also erase reg -> reg moves when the destination dies in this instr.
-
 patchEraseLive
 	:: Instruction instr
 	=> (Reg -> Reg)
@@ -540,14 +550,14 @@ patchEraseLive patchF cmm
  where
 	patchCmm cmm@CmmData{}	= cmm
 
-	patchCmm (CmmProc info label params sccs)
-	 | LiveInfo static id (Just blockMap)	<- info
+	patchCmm (CmmProc info label sccs)
+	 | LiveInfo static id (Just blockMap) mLiveSlots <- info
 	 = let 	
 	 	patchRegSet set	= mkUniqSet $ map patchF $ uniqSetToList set
-		blockMap'	= mapBlockEnv patchRegSet blockMap
+		blockMap'	= mapMap patchRegSet blockMap
 
-		info'		= LiveInfo static id (Just blockMap')
-	   in	CmmProc info' label params $ map patchSCC sccs
+		info'		= LiveInfo static id (Just blockMap') mLiveSlots
+	   in	CmmProc info' label $ map patchSCC sccs
 
 	 | otherwise
 	 = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
@@ -616,19 +626,17 @@ natCmmTopToLive
 natCmmTopToLive (CmmData i d)
 	= CmmData i d
 
-natCmmTopToLive (CmmProc info lbl params (ListGraph []))
-	= CmmProc (LiveInfo info Nothing Nothing)
-		  lbl params []
+natCmmTopToLive (CmmProc info lbl (ListGraph []))
+	= CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl []
 
-natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _)))
+natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _)))
  = let	first_id	= blockId first
 	sccs		= sccBlocks blocks
 	sccsLive	= map (fmap (\(BasicBlock l instrs) -> 
 					BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
 			$ sccs
 				
-   in	CmmProc (LiveInfo info (Just first_id) Nothing)
-		lbl params sccsLive
+   in	CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive
 
 
 sccBlocks 
@@ -656,21 +664,18 @@ regLiveness
 regLiveness (CmmData i d)
 	= returnUs $ CmmData i d
 
-regLiveness (CmmProc info lbl params [])
-	| LiveInfo static mFirst _	<- info
+regLiveness (CmmProc info lbl [])
+	| LiveInfo static mFirst _ _	<- info
 	= returnUs $ CmmProc
-			(LiveInfo static mFirst (Just emptyBlockEnv))
-			lbl params []
+			(LiveInfo static mFirst (Just mapEmpty) Map.empty)
+			lbl []
 
-regLiveness (CmmProc info lbl params sccs)
-	| LiveInfo static mFirst _	<- info
+regLiveness (CmmProc info lbl sccs)
+	| LiveInfo static mFirst _ liveSlotsOnEntry	<- info
 	= let	(ann_sccs, block_live)	= computeLiveness sccs
 
-   	  in	returnUs $ CmmProc (LiveInfo static mFirst (Just block_live))
-			   lbl params ann_sccs
-
-
-
+   	  in	returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
+			   lbl ann_sccs
 
 
 -- -----------------------------------------------------------------------------
@@ -688,7 +693,7 @@ checkIsReverseDependent
 checkIsReverseDependent sccs'
  = go emptyUniqSet sccs'
 
- where 	go blockssSeen []
+ where 	go _ []
 	 = Nothing
 	
 	go blocksSeen (AcyclicSCC block : sccs)
@@ -707,12 +712,21 @@ checkIsReverseDependent sccs'
 		 []		-> go blocksSeen' sccs
 		 bad : _	-> Just bad
 		
-	slurpJumpDestsOfBlock (BasicBlock blockId instrs)
+	slurpJumpDestsOfBlock (BasicBlock _ instrs)
 	 	= unionManyUniqSets
 		$ map (mkUniqSet . jumpDestsOfInstr) 
 		 	[ i | LiveInstr i _ <- instrs]
-	
 
+
+-- | If we've compute liveness info for this code already we have to reverse
+--   the SCCs in each top to get them back to the right order so we can do it again.
+reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr
+reverseBlocksInTops top
+ = case top of
+	CmmData{}			-> top
+	CmmProc info lbl sccs	-> CmmProc info lbl (reverse sccs)
+
+	
 -- | Computing liveness
 -- 	
 --  On entry, the SCCs must be in "reverse" order: later blocks may transfer
@@ -783,8 +797,8 @@ livenessSCCs blockmap done
                 -- BlockMaps for equality.
 	    equalBlockMaps a b
 	        = a' == b'
-	      where a' = map f $ blockEnvToList a
-	            b' = map f $ blockEnvToList b
+	      where a' = map f $ mapToList a
+	            b' = map f $ mapToList b
 	            f (key,elt) = (key, uniqSetToList elt)
 
 
@@ -801,7 +815,7 @@ livenessBlock blockmap (BasicBlock block_id instrs)
  = let
  	(regsLiveOnEntry, instrs1)
  		= livenessBack emptyUniqSet blockmap [] (reverse instrs)
- 	blockmap'	= extendBlockEnv blockmap block_id regsLiveOnEntry
+ 	blockmap'	= mapInsert block_id regsLiveOnEntry blockmap
 
 	instrs2		= livenessForward regsLiveOnEntry instrs1
 
@@ -908,7 +922,7 @@ liveness1 liveregs blockmap (LiveInstr instr _)
 	    not_a_branch = null targets
 
 	    targetLiveRegs target
-                  = case lookupBlockEnv blockmap target of
+                  = case mapLookup target blockmap of
                                 Just ra -> ra
                                 Nothing -> emptyRegMap