X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLinear%2FMain.hs;h=6b39009e244345552ba3ae848a19e3502dcf5594;hb=d97ce1a545cce3218acf538200fd02547d723e20;hp=63f2814d5d3f09aab0495a20f1e39051da1d8792;hpb=20142a7dfd176c4f587adb21e1d0161018f1ec7f;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 63f2814..6b39009 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -48,7 +48,7 @@ The algorithm is roughly:
 
 	(c) Update the current assignment
 
-	(d) If the intstruction is a branch:
+	(d) If the instruction is a branch:
 	      if the destination block already has a register assignment,
 	        Generate a new block with fixup code and redirect the
 		jump to the new block.
@@ -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"
 
 
@@ -212,10 +212,12 @@ process _ _ [] []         accum _
 
 process first_id block_live [] next_round accum madeProgress
 	| not madeProgress
-	= pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." 
+	
+	  {- 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
+		$$ vcat (map ppr next_round)) -}
+	= return $ reverse accum
 	
 	| otherwise
 	= process first_id block_live 
@@ -226,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
@@ -257,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
@@ -329,7 +331,7 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
     -- register does not already have an assignment,
     -- and the source register is assigned to a register, not to a spill slot,
     -- then we can eliminate the instruction.
-    -- (we can't eliminitate it if the source register is on the stack, because
+    -- (we can't eliminate it if the source register is on the stack, because
     --  we do not want to use one spill slot for different virtual registers)
     case takeRegRegMoveInstr instr of
 	Just (src,dst)	| src `elementOfUniqSet` (liveDieRead live), 
@@ -495,7 +497,7 @@ releaseRegs regs = do
 
 
 saveClobberedTemps
-	:: Instruction instr
+	:: (Outputable instr, Instruction instr)
 	=> [RealReg]		-- real registers clobbered by this instruction
 	-> [Reg]		-- registers which are no longer live after this insn
 	-> RegM [instr]		-- return: instructions to spill any temps that will
@@ -534,7 +536,7 @@ saveClobberedTemps clobbered dying
 
 
 
--- | Mark all these regal regs as allocated,
+-- | Mark all these real regs as allocated,
 --	and kick out their vreg assignments.
 --
 clobberRegs :: [RealReg] -> RegM ()
@@ -577,7 +579,7 @@ clobberRegs clobbered
 --   the list of free registers and free stack slots.
 
 allocateRegsAndSpill
-	:: Instruction instr
+	:: (Outputable instr, Instruction instr)
 	=> Bool			-- True <=> reading (load up spilled regs)
 	-> [VirtualReg]		-- don't push these out
 	-> [instr]		-- spill insns
@@ -597,7 +599,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs)
 			allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 
 		-- case (1b): already in a register (and memory)
-		-- NB1. if we're writing this register, update its assignemnt to be
+		-- NB1. if we're writing this register, update its assignment to be
 		-- InReg, because the memory value is no longer valid.
 		-- NB2. This is why we must process written registers here, even if they
 		-- are also read by the same instruction.
@@ -707,7 +709,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
 
 -- | Load up a spilled temporary if we need to.
 loadTemp
-	:: Instruction instr
+	:: (Outputable instr, Instruction instr)
 	=> Bool
 	-> VirtualReg 	-- the temp being loaded
 	-> Maybe Loc	-- the current location of this temp