X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=c67ce3ee6a3dba432380f9ef92450f79898af517;hb=598d761c769316dc4550028285f6508538b8a99c;hp=2e6e37c18930fd09beefc0dc13b75db929e173d4;hpb=e6243a818496aad82b6f47511d3bd9bc800f747d;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index 2e6e37c..c67ce3e 100644
--- a/compiler/nativeGen/RegAllocLinear.hs
+++ b/compiler/nativeGen/RegAllocLinear.hs
@@ -254,7 +254,7 @@ regAlloc (CmmProc static lbl params (ListGraph comps))
 	= do	
  		-- do register allocation on each component.
 		(final_blocks, stats)
-			<- linearRegAlloc block_live 
+			<- linearRegAlloc first_id block_live 
 			$ map (\b -> case b of 
 					BasicBlock _ [b]	-> AcyclicSCC b
 					BasicBlock _ bs		-> CyclicSCC  bs)
@@ -299,32 +299,43 @@ instance Outputable Loc where
 
 
 -- | Do register allocation on some basic blocks.
+--   But be careful to allocate a block in an SCC only if it has
+--   an entry in the block map or it is the first block.
 --
 linearRegAlloc
-	:: BlockMap RegSet		-- ^ live regs on entry to each basic block
+	:: BlockId                      -- ^ the first block
+        -> BlockMap RegSet		-- ^ live regs on entry to each basic block
 	-> [SCC LiveBasicBlock]		-- ^ instructions annotated with "deaths"
 	-> UniqSM ([NatBasicBlock], RegAllocStats)
 
-linearRegAlloc block_live sccs
+linearRegAlloc first_id block_live sccs
  = do	us	<- getUs
  	let (_, _, stats, blocks) =
 		runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
-			$ linearRA_SCCs block_live [] sccs
+			$ linearRA_SCCs first_id block_live [] sccs
 
 	return	(blocks, stats)
 
-linearRA_SCCs _ blocksAcc []
+linearRA_SCCs _ _ blocksAcc []
 	= return $ reverse blocksAcc
 
-linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs) 
+linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) 
  = do	blocks'	<- processBlock block_live block
-	linearRA_SCCs block_live 
+	linearRA_SCCs first_id block_live 
 		((reverse blocks') ++ blocksAcc)
 		sccs
 
-linearRA_SCCs block_live blocksAcc (CyclicSCC blocks : sccs) 
- = do	blockss' <- mapM (processBlock block_live) blocks
-	linearRA_SCCs block_live
+linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) 
+ = do	let process [] []         accum = return $ reverse accum
+            process [] next_round accum = process next_round [] accum
+            process (b@(BasicBlock id _) : blocks) next_round accum =
+              do block_assig <- getBlockAssigR
+                 if isJust (lookupBlockEnv block_assig id) || id == first_id
+                  then do b'  <- processBlock block_live b
+                          process blocks next_round (b' : accum)
+                  else process blocks (b : next_round) accum
+        blockss' <- process blocks [] (return [])
+	linearRA_SCCs first_id block_live
 		(reverse (concat blockss') ++ blocksAcc)
 		sccs
 		
@@ -421,12 +432,12 @@ raInsn block_live new_instrs (Instr instr (Just live))
 			 Just loc ->
 			   setAssigR (addToUFM (delFromUFM assig src) dst loc)
 
-	   -- we have elimianted this instruction
-	   {-
-	   freeregs <- getFreeRegsR
-    	   assig <- getAssigR
-	   pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
-	   -}
+	   -- we have eliminated this instruction
+          {-
+	  freeregs <- getFreeRegsR
+    	  assig <- getAssigR
+          pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
+          -}
 	   return (new_instrs, [])
 
 	_ -> genRaInsn block_live new_instrs instr