X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=323e1ff1df531ee9206721f0028ce46feb9283eb;hp=7c7690c798261d7e3ca0fc2920d6c73d108aba35;hb=c62b824e9e8808eb3845ddb1614494b0575eaafd;hpb=f8c52d7fde2d7408b4f734251c373f8d3e2c558e diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index 7c7690c..323e1ff 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- The register allocator @@ -5,7 +6,6 @@ -- (c) The University of Glasgow 2004 -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-missing-signatures #-} {- The algorithm is roughly: @@ -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,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) @@ -296,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 @@ -346,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 @@ -419,11 +433,11 @@ raInsn block_live new_instrs (Instr instr (Just live)) 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 - -} + {- + 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 @@ -572,7 +586,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 +703,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 +735,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 +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 @@ -793,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 @@ -805,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 @@ -823,7 +837,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 +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) @@ -906,7 +920,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 +1120,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)