Big collection of patches for the new codegen branch.

[ghc-hetmet.git] / compiler / nativeGen / RegAllocLinear.hs

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index debda83..2e6e37c 100644 (file)
--- a/compiler/nativeGen/RegAllocLinear.hs
+++ b/compiler/nativeGen/RegAllocLinear.hs
@@ -88,6 +88,7 @@ module RegAllocLinear (
 
 #include "HsVersions.h"
 
+import BlockId
 import MachRegs
 import MachInstrs
 import RegAllocInfo
@@ -101,6 +102,7 @@ import UniqFM
 import UniqSupply
 import Outputable
 import State
+import FastString
 
 import Data.Maybe
 import Data.List
@@ -155,8 +157,9 @@ getFreeRegs :: RegClass -> FreeRegs -> [RegNo]      -- lazilly
 getFreeRegs cls (FreeRegs g f)
     | RcDouble <- cls = go f (0x80000000) 63
     | RcInteger <- cls = go g (0x80000000) 31
+    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad cls" (ppr cls)
     where
-        go x 0 i = []
+        go _ 0 _ = []
         go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
                  | otherwise    = go x (m `shiftR` 1) $! i-1
 
@@ -221,7 +224,8 @@ emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
 
 getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
 getStackSlotFor (StackMap [] _) _
-       = panic "RegAllocLinear.getStackSlotFor: out of stack slots"
+       = panic "RegAllocLinear.getStackSlotFor: out of stack slots, try -fregs-graph"
+        -- This happens with darcs' SHA1.hs, see #1993
 
 getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
     case lookupUFM reserved reg of
@@ -242,9 +246,8 @@ regAlloc (CmmData sec d)
                , Nothing )
        
 regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
-       = return
-               ( CmmProc info lbl params (ListGraph [])
-               , Nothing )
+       = return ( CmmProc info lbl params (ListGraph [])
+                , Nothing )
        
 regAlloc (CmmProc static lbl params (ListGraph comps))
        | LiveInfo info (Just first_id) block_live      <- static
@@ -346,7 +349,7 @@ processBlock block_live (BasicBlock id instrs)
 initBlock :: BlockId -> RegM ()
 initBlock id
  = do  block_assig     <- getBlockAssigR
-       case lookupUFM block_assig id of
+       case lookupBlockEnv block_assig id of
                -- no prior info about this block: assume everything is
                -- free and the assignment is empty.
                Nothing
@@ -572,7 +575,7 @@ saveClobberedTemps clobbered dying =  do
        recordSpill (SpillClobber temp)
 
        let new_assign  = addToUFM assig temp (InBoth reg slot)
-       clobber new_assign (spill : COMMENT FSLIT("spill clobber") : instrs) rest
+       clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest
 
 clobberRegs :: [RegNo] -> RegM ()
 clobberRegs [] = return () -- common case
@@ -689,7 +692,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 
                (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
                let spill_store  = (if reading then id else reverse)
-                                       [ COMMENT FSLIT("spill alloc") 
+                                       [ COMMENT (fsLit "spill alloc") 
                                        , spill_insn ]
 
                -- record that this temp was spilled
@@ -721,7 +724,7 @@ loadTemp True vreg (Just (InMem slot)) hreg spills
  = do
        insn <- loadR (RealReg hreg) slot
        recordSpill (SpillLoad $ getUnique vreg)
-       return  $  COMMENT FSLIT("spill load") : insn : spills
+       return  $  COMMENT (fsLit "spill load") : insn : spills
 
 loadTemp _ _ _ _ spills =
    return spills
@@ -771,13 +774,13 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
        regsOfLoc (InBoth r _) = [r]
        regsOfLoc (InMem _)    = []
   -- in
-  case lookupUFM block_assig dest of
+  case lookupBlockEnv block_assig dest of
        -- Nothing <=> this is the first time we jumped to this
        -- block.
        Nothing -> do
          freeregs <- getFreeRegsR
          let freeregs' = foldr releaseReg freeregs to_free 
-         setBlockAssigR (addToUFM block_assig dest 
+         setBlockAssigR (extendBlockEnv block_assig dest 
                                (freeregs',adjusted_assig))
          joinToTargets block_live new_blocks instr dests
 
@@ -793,7 +796,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
               delta <- getDeltaR
               
                let graph = makeRegMovementGraph adjusted_assig dest_assig
-              let sccs  = stronglyConnCompR graph
+              let sccs  = stronglyConnCompFromEdgedVerticesR graph
               fixUpInstrs <- mapM (handleComponent delta instr) sccs
 
               block_id <- getUniqueR
@@ -805,7 +808,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
               joinToTargets block_live (block : new_blocks) instr' dests
 
 
--- | Construct a graph of register/spill movements.
+-- | Construct a graph of register\/spill movements.
 --
 --     We cut some corners by
 --     a) not handling cyclic components
@@ -823,7 +826,7 @@ makeRegMovementGraph adjusted_assig dest_assig
         = expandNode vreg src
         $ lookupWithDefaultUFM_Directly
                dest_assig
-                (panic "RegisterAlloc.joinToTargets")
+                (panic "RegAllocLinear.makeRegMovementGraph")
                vreg
 
    in  [ node  | (vreg, src) <- ufmToList adjusted_assig
@@ -897,7 +900,7 @@ handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
  = do
        spill_id <- getUniqueR
        (_, slot)               <- spillR (RealReg sreg) spill_id
-       remainingFixUps         <- mapM (handleComponent delta instr) (stronglyConnCompR rest)
+       remainingFixUps         <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest)
        restoreAndFixInstr      <- getRestoreMoves dsts slot
        return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
 
@@ -906,7 +909,7 @@ handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
         = do
                restoreToReg    <- loadR (RealReg reg) slot
                moveInstr       <- makeMove delta vreg r mem
-               return $ [COMMENT FSLIT("spill join move"), restoreToReg, moveInstr]
+               return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr]
 
        getRestoreMoves [InReg reg] slot
                = loadR (RealReg reg) slot >>= return . (:[])
@@ -1106,12 +1109,9 @@ pprStats code statss
 -- -----------------------------------------------------------------------------
 -- Utils
 
-#ifdef DEBUG
-my_fromJust s p Nothing  = pprPanic ("fromJust: " ++ s) p
+my_fromJust :: String -> SDoc -> Maybe a -> a
 my_fromJust _ _ (Just x) = x
-#else
-my_fromJust _ _ = fromJust
-#endif
+my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
 
-lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
-lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)
+lookItUp :: String -> BlockMap a -> BlockId -> a
+lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x)