X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLinear%2FMain.hs;h=5fab944e0979653c60bad8df1aace91dd7f3f15f;hb=163d12852002a67c5b661b4b3e7e3c5bb6faa5f3;hp=0014eec2d40410404f4e74acdaa63ed7859e1d66;hpb=028c032b60567b8cd501e9d7248e4aa86088a19b;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 0014eec..5fab944 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -102,7 +102,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Cmm hiding (RegSet)
+import OldCmm hiding (RegSet)
 
 import Digraph
 import Unique
@@ -132,12 +132,12 @@ regAlloc (CmmData sec d)
 		( CmmData sec d
 		, Nothing )
 	
-regAlloc (CmmProc (LiveInfo info _ _) lbl params [])
-	= return ( CmmProc info lbl params (ListGraph [])
+regAlloc (CmmProc (LiveInfo info _ _ _) lbl [])
+	= return ( CmmProc info lbl (ListGraph [])
 		 , Nothing )
 	
-regAlloc (CmmProc static lbl params sccs)
-	| LiveInfo info (Just first_id) (Just block_live)	<- static
+regAlloc (CmmProc static lbl sccs)
+	| LiveInfo info (Just first_id) (Just block_live) _	<- static
 	= do	
  		-- do register allocation on each component.
 		(final_blocks, stats)
@@ -148,11 +148,11 @@ regAlloc (CmmProc static lbl params sccs)
 		let ((first':_), rest')
 				= partition ((== first_id) . blockId) final_blocks
 
-		return	( CmmProc info lbl params (ListGraph (first' : rest'))
+		return	( CmmProc info lbl (ListGraph (first' : rest'))
 			, Just stats)
 	
 -- bogus. to make non-exhaustive match warning go away.
-regAlloc (CmmProc _ _ _ _)
+regAlloc (CmmProc _ _ _)
 	= panic "RegAllocLinear.regAlloc: no match"
 
 
@@ -206,15 +206,18 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
    some reason then this function will loop. We should probably do some 
    more sanity checking to guard against this eventuality.
 -}
-		
+
 process _ _ [] []         accum _
 	= return $ reverse accum
 
 process first_id block_live [] next_round accum madeProgress
 	| not madeProgress
-	= pprPanic "RegAlloc.Linear.Main.process: no progress made, bailing out" 
-		(  text "stalled blocks:"
-		$$ vcat (map ppr next_round))
+	
+	  {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
+	     pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." 
+		(  text "Unreachable blocks:"
+		$$ vcat (map ppr next_round)) -}
+	= return $ reverse accum
 	
 	| otherwise
 	= process first_id block_live 
@@ -225,7 +228,7 @@ process first_id block_live (b@(BasicBlock id _) : blocks)
  = do 	
 	block_assig <- getBlockAssigR
 
-    	if isJust (lookupBlockEnv block_assig id) 
+    	if isJust (mapLookup id block_assig) 
              || id == first_id
          then do 
 		b'  <- processBlock block_live b
@@ -256,7 +259,7 @@ processBlock block_live (BasicBlock id instrs)
 initBlock :: BlockId -> RegM ()
 initBlock id
  = do	block_assig	<- getBlockAssigR
-  	case lookupBlockEnv block_assig id of
+  	case mapLookup id block_assig of
 	        -- no prior info about this block: assume everything is
 	        -- free and the assignment is empty.
 	 	Nothing
@@ -292,7 +295,7 @@ linearRA _          accInstr accFixup _ []
 
 linearRA block_live accInstr accFixups id (instr:instrs)
  = do
- 	(accInstr', new_fixups) 
+	(accInstr', new_fixups) 
 		<- raInsn block_live accInstr id instr
 
 	linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
@@ -309,17 +312,17 @@ raInsn
 		( [instr]			-- new instructions
 		, [NatBasicBlock instr])	-- extra fixup blocks
 
-raInsn _     new_instrs _ (Instr ii Nothing)  
+raInsn _     new_instrs _ (LiveInstr ii Nothing)  
 	| Just n	<- takeDeltaInstr ii
  	= do	setDeltaR n
 		return (new_instrs, [])
 
-raInsn _     new_instrs _ (Instr ii Nothing)
+raInsn _     new_instrs _ (LiveInstr ii Nothing)
 	| isMetaInstr ii
 	= return (new_instrs, [])
 
 
-raInsn block_live new_instrs id (Instr instr (Just live))
+raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
  = do
     assig    <- getAssigR
 
@@ -380,7 +383,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying =
     clobber_saves 	<- saveClobberedTemps real_written r_dying
 
     -- debugging
-{-  freeregs <- getFreeRegsR
+{-    freeregs <- getFreeRegsR
     assig    <- getAssigR
     pprTrace "genRaInsn" 
     	(ppr instr