update for changes in hetmet Makefile

[ghc-hetmet.git] / compiler / nativeGen / RegAlloc / Linear / Main.hs

diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 229fd32..5fab944 100644 (file)
--- 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"
 
 
@@ -190,7 +190,7 @@ linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
 
 linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) 
  = do
-        blockss' <- process first_id block_live blocks [] (return [])
+        blockss' <- process first_id block_live blocks [] (return []) False
        linearRA_SCCs first_id block_live
                (reverse (concat blockss') ++ blocksAcc)
                sccs
@@ -206,24 +206,37 @@ 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 
+
+process _ _ [] []         accum _
        = return $ reverse accum
 
-process first_id block_live [] next_round accum 
-       = process first_id block_live next_round [] accum
+process first_id block_live [] next_round accum madeProgress
+       | not madeProgress
+       
+         {- 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 
+                 next_round [] accum False
 
-process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum 
+process first_id block_live (b@(BasicBlock id _) : blocks) 
+       next_round accum madeProgress
  = 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
-                process first_id block_live blocks next_round (b' : accum)
+                process first_id block_live blocks 
+                       next_round (b' : accum) True
 
-         else  process first_id block_live blocks (b : next_round) accum
+         else  process first_id block_live blocks 
+                       (b : next_round) accum madeProgress
 
 
 -- | Do register allocation on this basic block
@@ -246,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
@@ -282,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
@@ -299,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
 
@@ -370,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