X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLiveness.hs;h=d7659b5c86a9f110f657f893ab24230dff6f4d22;hb=cf1c939d4693519e4f23c0f4fcbe60f1e04adf3e;hp=e4481b59cd5d79f72de6c2c0e630b66aa99f6f86;hpb=85981a6fc4bb94af433b0b3655c26c5ec4dda1bd;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index e4481b5..d7659b5 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -12,6 +12,7 @@ module RegAlloc.Liveness (
 	RegMap, emptyRegMap,
 	BlockMap, emptyBlockMap,
 	LiveCmmTop,
+	InstrSR	  (..),
 	LiveInstr (..),
 	Liveness (..),
 	LiveInfo (..),
@@ -26,8 +27,9 @@ module RegAlloc.Liveness (
 	eraseDeltasLive,
 	patchEraseLive,
 	patchRegsLiveInstr,
-	regLiveness
-
+	reverseBlocksInTops,
+	regLiveness,
+	natCmmTopToLive
   ) where
 
 
@@ -73,16 +75,73 @@ type LiveCmmTop instr
 		[SCC (LiveBasicBlock instr)]
 
 
--- | An instruction with liveness information.
-data LiveInstr instr
-	= Instr instr (Maybe Liveness)
+-- | The register allocator also wants to use SPILL/RELOAD meta instructions,
+--	so we'll keep those here.
+data InstrSR instr
+	-- | A real machine instruction
+	= Instr  instr
 
 	-- | spill this reg to a stack slot
-	| SPILL Reg Int
+	| SPILL  Reg Int
 
 	-- | reload this reg from a stack slot
 	| RELOAD Int Reg
-	
+
+instance Instruction instr => Instruction (InstrSR instr) where
+	regUsageOfInstr i
+	 = case i of
+		Instr  instr	-> regUsageOfInstr instr
+		SPILL  reg _	-> RU [reg] []
+		RELOAD _ reg	-> RU [] [reg]
+
+	patchRegsOfInstr i f
+	 = case i of
+		Instr instr	-> Instr (patchRegsOfInstr instr f)
+		SPILL  reg slot	-> SPILL (f reg) slot
+		RELOAD slot reg	-> RELOAD slot (f reg)
+
+	isJumpishInstr i
+	 = case i of
+		Instr instr	-> isJumpishInstr instr
+		_		-> False
+
+	jumpDestsOfInstr i
+	 = case i of
+		Instr instr	-> jumpDestsOfInstr instr 
+		_		-> []
+
+	patchJumpInstr i f
+	 = case i of
+		Instr instr	-> Instr (patchJumpInstr instr f)
+		_		-> i
+
+	mkSpillInstr		= error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
+	mkLoadInstr		= error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
+
+	takeDeltaInstr i
+	 = case i of
+		Instr instr	-> takeDeltaInstr instr
+		_		-> Nothing
+
+	isMetaInstr i
+	 = case i of
+		Instr instr	-> isMetaInstr instr
+		_		-> False
+
+	mkRegRegMoveInstr r1 r2	= Instr (mkRegRegMoveInstr r1 r2)
+
+	takeRegRegMoveInstr i
+	 = case i of
+		Instr instr	-> takeRegRegMoveInstr instr
+		_		-> Nothing
+
+	mkJumpInstr target	= map Instr (mkJumpInstr target)
+		
+
+
+-- | An instruction with liveness information.
+data LiveInstr instr
+	= LiveInstr (InstrSR instr) (Maybe Liveness)
 
 -- | Liveness information.
 -- 	The regs which die are ones which are no longer live in the *next* instruction
@@ -110,8 +169,12 @@ type LiveBasicBlock instr
 	= GenBasicBlock (LiveInstr instr)
 
 
-instance Outputable instr 
-      => Outputable (LiveInstr instr) where
+instance Outputable instr
+      => Outputable (InstrSR instr) where
+
+	ppr (Instr realInstr)
+	   = ppr realInstr
+
 	ppr (SPILL reg slot)
 	   = hcat [
 	   	ptext (sLit "\tSPILL"),
@@ -128,10 +191,13 @@ instance Outputable instr
 		comma,
 		ppr reg]
 
-	ppr (Instr instr Nothing)
+instance Outputable instr 
+      => Outputable (LiveInstr instr) where
+
+	ppr (LiveInstr instr Nothing)
 	 = ppr instr
 
-	ppr (Instr instr (Just live))
+	ppr (LiveInstr instr (Just live))
 	 =  ppr instr
 		$$ (nest 8
 			$ vcat
@@ -186,12 +252,6 @@ mapSCCM f (CyclicSCC xs)
  = do	xs'	<- mapM f xs
 	return	$ CyclicSCC xs'
 
-{-
-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'
--}
 
 -- map a function across all the basic blocks in this code
 mapGenBlockTop
@@ -250,17 +310,10 @@ slurpConflicts live
 	slurpLIs rsLive (conflicts, moves) []
 		= (consBag rsLive conflicts, moves)
 
-	slurpLIs rsLive rs (Instr _ Nothing     : lis)	
+	slurpLIs rsLive rs (LiveInstr _ Nothing     : lis)	
 		= slurpLIs rsLive rs lis
-
-	-- we're not expecting to be slurping conflicts from spilled code
-	slurpLIs _ _ (SPILL _ _ : _)
-		= panic "Liveness.slurpConflicts: unexpected SPILL"
-
-	slurpLIs _ _ (RELOAD _ _ : _)
-		= panic "Liveness.slurpConflicts: unexpected RELOAD"
 		
-	slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
+	slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis)
 	 = let
 		-- regs that die because they are read for the last time at the start of an instruction
 		--	are not live across it.
@@ -349,12 +402,12 @@ slurpReloadCoalesce live
 	slurpLI slotMap li
 
 		-- remember what reg was stored into the slot
-		| SPILL reg slot	<- li
-		, slotMap'		<- addToUFM slotMap slot reg
+		| LiveInstr (SPILL reg slot) _	<- li
+		, 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	<- li
+		| LiveInstr (RELOAD slot reg) _	<- li
 		= case lookupUFM slotMap slot of
 			Just reg2
 			 | reg /= reg2	-> return (slotMap, Just (reg, reg2))
@@ -363,8 +416,8 @@ slurpReloadCoalesce live
 			Nothing		-> return (slotMap, Nothing)
 
 		-- if we hit a jump, remember the current slotMap
-		| Instr instr _		<- li
-		, targets		<- jumpDestsOfInstr instr
+		| LiveInstr (Instr instr) _	<- li
+		, targets			<- jumpDestsOfInstr instr
 		, not $ null targets
 		= do	mapM_	(accSlotMap slotMap) targets
 			return	(slotMap, Nothing)
@@ -393,9 +446,8 @@ slurpReloadCoalesce live
 
 
 -- | Strip away liveness information, yielding NatCmmTop
-
 stripLive 
-	:: Instruction instr
+	:: (Outputable instr, Instruction instr)
 	=> LiveCmmTop instr 
 	-> NatCmmTop instr
 
@@ -403,10 +455,27 @@ stripLive live
 	= stripCmm live
 
  where	stripCmm (CmmData sec ds)	= CmmData sec ds
- 	stripCmm (CmmProc (LiveInfo info _ _) label params sccs)
-		= CmmProc info label params
-                          (ListGraph $ map stripLiveBlock $ flattenSCCs sccs)
-	
+
+ 	stripCmm (CmmProc (LiveInfo info (Just first_id) _) label params sccs)
+	 = let	final_blocks	= flattenSCCs sccs
+		
+		-- make sure the block that was first in the input list
+		--	stays at the front of the output. This is the entry point
+		--	of the proc, and it needs to come first.
+		((first':_), rest')
+				= partition ((== first_id) . blockId) final_blocks
+
+	   in	CmmProc info label params
+                          (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 [])
+
+	-- 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.
@@ -425,20 +494,20 @@ stripLiveBlock (BasicBlock i lis)
 	spillNat acc []
 	 = 	return (reverse acc)
 
-	spillNat acc (SPILL reg slot : instrs)
+	spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
 	 = do	delta	<- get
 	 	spillNat (mkSpillInstr reg delta slot : acc) instrs
 
-	spillNat acc (RELOAD slot reg : instrs)
+	spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
 	 = do	delta	<- get
 	 	spillNat (mkLoadInstr reg delta slot : acc) instrs
 
-	spillNat acc (Instr instr _ : instrs)
+	spillNat acc (LiveInstr (Instr instr) _ : instrs)
 	 | Just i <- takeDeltaInstr instr
 	 = do	put i
 	 	spillNat acc instrs
 
-	spillNat acc (Instr instr _ : instrs)
+	spillNat acc (LiveInstr (Instr instr) _ : instrs)
 	 =	spillNat (instr : acc) instrs
 
 
@@ -454,7 +523,7 @@ eraseDeltasLive cmm
  where
  	eraseBlock (BasicBlock id lis)
 		= BasicBlock id
-		$ filter (\(Instr i _) -> not $ isJust $ takeDeltaInstr i)
+		$ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
 		$ lis
 
 
@@ -493,7 +562,7 @@ patchEraseLive patchF cmm
 	patchInstrs []		= []
 	patchInstrs (li : lis)
 
-		| Instr i (Just live)	<- li'
+		| LiveInstr i (Just live)	<- li'
 		, Just (r1, r2)	<- takeRegRegMoveInstr i
 		, eatMe r1 r2 live
 		= patchInstrs lis
@@ -524,11 +593,11 @@ patchRegsLiveInstr
 
 patchRegsLiveInstr patchF li
  = case li of
-	Instr instr Nothing
-	 -> Instr (patchRegsOfInstr instr patchF) Nothing
+	LiveInstr instr Nothing
+	 -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
 
-	Instr instr (Just live)
-	 -> Instr
+	LiveInstr instr (Just live)
+	 -> LiveInstr
 	 	(patchRegsOfInstr instr patchF)
 		(Just live
 			{ -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
@@ -536,109 +605,155 @@ patchRegsLiveInstr patchF li
 			, liveDieRead	= mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
 			, liveDieWrite	= mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
 
-	SPILL reg slot
-	 -> SPILL (patchF reg) slot
-		
-	RELOAD slot reg
-	 -> RELOAD slot (patchF reg)
-
 
 --------------------------------------------------------------------------------
 -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information
-{-
+
 natCmmTopToLive 
-	:: NatCmmTop instr
+	:: Instruction instr
+	=> NatCmmTop instr
 	-> LiveCmmTop instr
 
-natCmmTopToLive cmm@(CmmData _ _)
-	= cmm
+natCmmTopToLive (CmmData i d)
+	= CmmData i d
 
 natCmmTopToLive (CmmProc info lbl params (ListGraph []))
-	= CmmProc (LiveInfo info Nothing emptyBlockEnv)
-		lbl params (ListGraph []))
+	= CmmProc (LiveInfo info Nothing Nothing)
+		  lbl params []
 
-natCmmTopToLive (CmmProc info lbl params (ListGraph blocks))
- = let	first_id		= blockId first
-	sccs			= sccBlocks blocks
+natCmmTopToLive (CmmProc info lbl params (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
 
-	liveBlocks
-	 = map (\scc -> case scc of
-			AcyclicSCC  b@(BasicBlock l _)		-> BasicBlock l [cmmBlockToLive b]	
-			CyclicSCC  bs@(BasicBlock l _ : _)	-> BasicBlock l (map cmmBlockToLive bs)
-			CyclicSCC  []	
-			 -> panic "RegLiveNess.natCmmTopToLive: no blocks in scc list")
-		sccs
 
-   in	CmmProc (LiveInfo info (Just first_id) ???
--}
+sccBlocks 
+	:: Instruction instr
+	=> [NatBasicBlock instr] 
+	-> [SCC (NatBasicBlock instr)]
+
+sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
+  where
+	getOutEdges :: Instruction instr => [instr] -> [BlockId]
+	getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
+
+	graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
+		| block@(BasicBlock id instrs) <- blocks ]
+
 
 ---------------------------------------------------------------------------------
 -- Annotate code with register liveness information
 --
 regLiveness
-	:: Instruction instr
-	=> NatCmmTop instr
+	:: (Outputable instr, Instruction instr)
+	=> LiveCmmTop instr
 	-> UniqSM (LiveCmmTop instr)
 
 regLiveness (CmmData i d)
 	= returnUs $ CmmData i d
 
-regLiveness (CmmProc info lbl params (ListGraph []))
+regLiveness (CmmProc info lbl params [])
+	| LiveInfo static mFirst _	<- info
 	= returnUs $ CmmProc
-			(LiveInfo info Nothing (Just emptyBlockEnv))
+			(LiveInfo static mFirst (Just emptyBlockEnv))
 			lbl params []
 
-regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
- = let 	first_id		= blockId first
-	sccs			= sccBlocks blocks
-	(ann_sccs, block_live)	= computeLiveness sccs
+regLiveness (CmmProc info lbl params sccs)
+	| LiveInfo static mFirst _	<- info
+	= let	(ann_sccs, block_live)	= computeLiveness sccs
 
-   in	returnUs $ CmmProc (LiveInfo info (Just first_id) (Just block_live))
+   	  in	returnUs $ CmmProc (LiveInfo static mFirst (Just block_live))
 			   lbl params ann_sccs
 
 
-sccBlocks 
+-- -----------------------------------------------------------------------------
+-- | Check ordering of Blocks
+--	The computeLiveness function requires SCCs to be in reverse dependent order.
+--	If they're not the liveness information will be wrong, and we'll get a bad allocation.
+--	Better to check for this precondition explicitly or some other poor sucker will
+--	waste a day staring at bad assembly code..
+--	
+checkIsReverseDependent
 	:: Instruction instr
-	=> [NatBasicBlock instr] 
-	-> [SCC (NatBasicBlock instr)]
-
-sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
-  where
-	getOutEdges :: Instruction instr => [instr] -> [BlockId]
-	getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
+	=> [SCC (LiveBasicBlock instr)]		-- ^ SCCs of blocks that we're about to run the liveness determinator on.
+	-> Maybe BlockId			-- ^ BlockIds that fail the test (if any)
+	
+checkIsReverseDependent sccs'
+ = go emptyUniqSet sccs'
 
-	graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
-		| block@(BasicBlock id instrs) <- blocks ]
+ where 	go _ []
+	 = Nothing
+	
+	go blocksSeen (AcyclicSCC block : sccs)
+	 = let	dests		= slurpJumpDestsOfBlock block
+		blocksSeen'	= unionUniqSets blocksSeen $ mkUniqSet [blockId block]
+		badDests	= dests `minusUniqSet` blocksSeen'
+	   in	case uniqSetToList badDests of
+		 []		-> go blocksSeen' sccs
+		 bad : _	-> Just bad
+		
+	go blocksSeen (CyclicSCC blocks : sccs)
+	 = let	dests		= unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
+		blocksSeen'	= unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
+		badDests	= dests `minusUniqSet` blocksSeen'
+	   in	case uniqSetToList badDests of
+		 []		-> go blocksSeen' sccs
+		 bad : _	-> Just bad
+		
+	slurpJumpDestsOfBlock (BasicBlock _ instrs)
+	 	= unionManyUniqSets
+		$ map (mkUniqSet . jumpDestsOfInstr) 
+		 	[ i | LiveInstr i _ <- instrs]
 
 
--- -----------------------------------------------------------------------------
--- Computing liveness
+-- | 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 params sccs	-> CmmProc info lbl params (reverse sccs)
 
+	
+-- | Computing liveness
+-- 	
+--  On entry, the SCCs must be in "reverse" order: later blocks may transfer
+--  control to earlier ones only, else `panic`.
+-- 
+--  The SCCs returned are in the *opposite* order, which is exactly what we
+--  want for the next pass.
+--
 computeLiveness
-	:: Instruction instr
-	=> [SCC (NatBasicBlock instr)]
+	:: (Outputable instr, Instruction instr)
+	=> [SCC (LiveBasicBlock instr)]
 	-> ([SCC (LiveBasicBlock instr)],	-- instructions annotated with list of registers
 						-- which are "dead after this instruction".
 	       BlockMap RegSet)			-- blocks annontated with set of live registers
 						-- on entry to the block.
-	
-  -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
-  -- control to earlier ones only.  The SCCs returned are in the *opposite* 
-  -- order, which is exactly what we want for the next pass.
 
 computeLiveness sccs
-  	= livenessSCCs emptyBlockMap [] sccs
-
+ = case checkIsReverseDependent sccs of
+	Nothing		-> livenessSCCs emptyBlockMap [] sccs
+	Just bad	-> pprPanic "RegAlloc.Liveness.computeLivenss"
+	 			(vcat 	[ text "SCCs aren't in reverse dependent order"
+					, text "bad blockId" <+> ppr bad 
+					, ppr sccs])
 
 livenessSCCs
        :: Instruction instr
        => BlockMap RegSet
        -> [SCC (LiveBasicBlock instr)]		-- accum
-       -> [SCC (NatBasicBlock instr)]
+       -> [SCC (LiveBasicBlock instr)]
        -> ( [SCC (LiveBasicBlock instr)]
        	  , BlockMap RegSet)
 
-livenessSCCs blockmap done [] = (done, blockmap)
+livenessSCCs blockmap done [] 
+	= (done, blockmap)
 
 livenessSCCs blockmap done (AcyclicSCC block : sccs)
  = let	(blockmap', block')	= livenessBlock blockmap block
@@ -666,7 +781,7 @@ livenessSCCs blockmap done
 
             linearLiveness 
 	    	:: Instruction instr
-		=> BlockMap RegSet -> [NatBasicBlock instr]
+		=> BlockMap RegSet -> [LiveBasicBlock instr]
             	-> (BlockMap RegSet, [LiveBasicBlock instr])
 
             linearLiveness = mapAccumL livenessBlock
@@ -686,7 +801,7 @@ livenessSCCs blockmap done
 livenessBlock
 	:: Instruction instr
 	=> BlockMap RegSet
-	-> NatBasicBlock instr
+	-> LiveBasicBlock instr
 	-> (BlockMap RegSet, LiveBasicBlock instr)
 
 livenessBlock blockmap (BasicBlock block_id instrs)
@@ -710,7 +825,7 @@ livenessForward
 	-> [LiveInstr instr] -> [LiveInstr instr]
 
 livenessForward _           []	= []
-livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
+livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis)
 	| Nothing		<- mLive
 	= li : livenessForward rsLiveEntry lis
 
@@ -726,7 +841,7 @@ livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
 					`minusUniqSet` (liveDieRead live)
 					`minusUniqSet` (liveDieWrite live)
 
-	in Instr instr (Just live { liveBorn = rsBorn })
+	in LiveInstr instr (Just live { liveBorn = rsBorn })
 		: livenessForward rsLiveNext lis
 
 livenessForward _ _ 		= panic "RegLiveness.livenessForward: no match"
@@ -740,7 +855,7 @@ livenessBack
 	=> RegSet			-- regs live on this instr
 	-> BlockMap RegSet   		-- regs live on entry to other BBs
 	-> [LiveInstr instr]   		-- instructions (accum)
-	-> [instr]			-- instructions
+	-> [LiveInstr instr]		-- instructions
 	-> (RegSet, [LiveInstr instr])
 
 livenessBack liveregs _        done []  = (liveregs, done)
@@ -755,24 +870,24 @@ liveness1
 	:: Instruction instr
 	=> RegSet 
 	-> BlockMap RegSet 
-	-> instr
+	-> LiveInstr instr
 	-> (RegSet, LiveInstr instr)
 
-liveness1 liveregs _ instr
+liveness1 liveregs _ (LiveInstr instr _)
 	| isMetaInstr instr
-	= (liveregs, Instr instr Nothing)
+	= (liveregs, LiveInstr instr Nothing)
 
-liveness1 liveregs blockmap instr
+liveness1 liveregs blockmap (LiveInstr instr _)
 
 	| not_a_branch
-	= (liveregs1, Instr instr
+	= (liveregs1, LiveInstr instr
 			(Just $ Liveness
 			{ liveBorn	= emptyUniqSet
 			, liveDieRead	= mkUniqSet r_dying
 			, liveDieWrite	= mkUniqSet w_dying }))
 
 	| otherwise
-	= (liveregs_br, Instr instr
+	= (liveregs_br, LiveInstr instr
 			(Just $ Liveness
 			{ liveBorn	= emptyUniqSet
 			, liveDieRead	= mkUniqSet r_dying_br