X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLiveness.hs;h=d7659b5c86a9f110f657f893ab24230dff6f4d22;hb=8fdb09e2610927c2bd65fca31965893216e4da34;hp=69ec7ae41871394bfcd497415ffe491711899734;hpb=e17cf7ff32778f4e6b3622855f25426251e843d6;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 69ec7ae..d7659b5 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -27,6 +27,7 @@ module RegAlloc.Liveness (
 	eraseDeltasLive,
 	patchEraseLive,
 	patchRegsLiveInstr,
+	reverseBlocksInTops,
 	regLiveness,
 	natCmmTopToLive
   ) where
@@ -141,8 +142,6 @@ instance Instruction instr => Instruction (InstrSR instr) where
 -- | 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
@@ -447,9 +446,8 @@ slurpReloadCoalesce live
 
 
 -- | Strip away liveness information, yielding NatCmmTop
-
 stripLive 
-	:: Instruction instr
+	:: (Outputable instr, Instruction instr)
 	=> LiveCmmTop instr 
 	-> NatCmmTop instr
 
@@ -457,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.
@@ -635,7 +650,7 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
 -- Annotate code with register liveness information
 --
 regLiveness
-	:: Instruction instr
+	:: (Outputable instr, Instruction instr)
 	=> LiveCmmTop instr
 	-> UniqSM (LiveCmmTop instr)
 
@@ -656,25 +671,78 @@ regLiveness (CmmProc info lbl params sccs)
 			   lbl params ann_sccs
 
 
-
 -- -----------------------------------------------------------------------------
--- Computing liveness
+-- | 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
+	=> [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'
+
+ 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]
+
 
+-- | 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
+	:: (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