Fix #2838: we should narrow a CmmInt before converting to ImmInteger

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

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index de6e664..c67ce3e 100644 (file)
--- a/compiler/nativeGen/RegAllocLinear.hs
+++ b/compiler/nativeGen/RegAllocLinear.hs
@@ -246,16 +246,15 @@ 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
        = 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)
@@ -300,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
                
@@ -350,7 +360,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
@@ -422,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 
@@ -775,13 +785,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
 
@@ -797,7 +807,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
@@ -809,7 +819,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
@@ -901,7 +911,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)
 
@@ -1114,5 +1124,5 @@ my_fromJust :: String -> SDoc -> Maybe a -> a
 my_fromJust _ _ (Just x) = x
 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)