X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=c67ce3ee6a3dba432380f9ef92450f79898af517;hb=6bc92166180824bf046d31e378359e3c386150f9;hp=d761bae3c0ae88fd889780683339f9856033c9b1;hpb=9e5cd691a00f5e53bdd735df4d5a33b72eeafedf;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index d761bae..c67ce3e 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- The register allocator @@ -87,11 +88,12 @@ module RegAllocLinear ( #include "HsVersions.h" +import BlockId import MachRegs import MachInstrs import RegAllocInfo import RegLiveness -import Cmm +import Cmm hiding (RegSet) import Digraph import Unique ( Uniquable(getUnique), Unique ) @@ -99,12 +101,12 @@ import UniqSet import UniqFM import UniqSupply import Outputable +import State +import FastString -#ifndef DEBUG -import Data.Maybe ( fromJust ) -#endif -import Data.List ( nub, partition, mapAccumL, foldl') -import Control.Monad ( when ) +import Data.Maybe +import Data.List +import Control.Monad import Data.Word import Data.Bits @@ -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 @@ -187,7 +190,7 @@ initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly getFreeRegs cls f = go f 0 - where go 0 m = [] + where go 0 _ = [] go n m | n .&. 1 /= 0 && regClass (RealReg m) == cls = m : (go (n `shiftR` 1) $! (m+1)) @@ -220,8 +223,10 @@ emptyStackMap :: StackMap emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM getStackSlotFor :: StackMap -> Unique -> (StackMap,Int) -getStackSlotFor fs@(StackMap [] reserved) reg - = panic "RegAllocLinear.getStackSlotFor: out of stack slots" +getStackSlotFor (StackMap [] _) _ + = 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 Just slot -> (fs,slot) @@ -235,25 +240,24 @@ regAlloc :: LiveCmmTop -> UniqSM (NatCmmTop, Maybe RegAllocStats) -regAlloc cmm@(CmmData sec d) +regAlloc (CmmData sec d) = return ( CmmData sec d , Nothing ) -regAlloc cmm@(CmmProc (LiveInfo info _ _) lbl params []) - = return - ( CmmProc info lbl params [] - , Nothing ) +regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) + = return ( CmmProc info lbl params (ListGraph []) + , Nothing ) -regAlloc cmm@(CmmProc static lbl params comps) +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 i [b] -> AcyclicSCC b - BasicBlock i bs -> CyclicSCC bs) + BasicBlock _ [b] -> AcyclicSCC b + BasicBlock _ bs -> CyclicSCC bs) $ comps -- make sure the block that was first in the input list @@ -261,9 +265,12 @@ regAlloc cmm@(CmmProc static lbl params comps) let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - return ( CmmProc info lbl params (first' : rest') + return ( CmmProc info lbl params (ListGraph (first' : rest')) , Just stats) +-- bogus. to make non-exhaustive match warning go away. +regAlloc (CmmProc _ _ _ _) + = panic "RegAllocLinear.regAlloc: no match" -- ----------------------------------------------------------------------------- @@ -287,39 +294,48 @@ save it in a spill location, but mark it as InBoth because the current instruction might still want to read it. -} -#ifdef DEBUG instance Outputable Loc where ppr l = text (show l) -#endif -- | 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 (block_assig', stackMap', stats, blocks) = + 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 block_live 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 @@ -344,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 @@ -362,7 +378,7 @@ linearRA -> [Instr] -> [NatBasicBlock] -> [LiveInstr] -> RegM ([Instr], [NatBasicBlock]) -linearRA block_live instr_acc fixups [] +linearRA _ instr_acc fixups [] = return (reverse instr_acc, fixups) linearRA block_live instr_acc fixups (instr:instrs) @@ -382,10 +398,10 @@ raInsn :: BlockMap RegSet -- Live temporaries at each basic block [NatBasicBlock] -- extra fixup blocks ) -raInsn block_live new_instrs (Instr instr@(COMMENT _) Nothing) +raInsn _ new_instrs (Instr (COMMENT _) Nothing) = return (new_instrs, []) -raInsn block_live new_instrs (Instr instr@(DELTA n) Nothing) +raInsn _ new_instrs (Instr (DELTA n) Nothing) = do setDeltaR n return (new_instrs, []) @@ -416,20 +432,20 @@ 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, []) - other -> genRaInsn block_live new_instrs instr + _ -> genRaInsn block_live new_instrs instr (uniqSetToList $ liveDieRead live) (uniqSetToList $ liveDieWrite live) -raInsn block_live new_instrs li +raInsn _ _ li = pprPanic "raInsn" (text "no match for:" <> ppr li) @@ -519,7 +535,7 @@ releaseRegs regs = do free <- getFreeRegsR loop assig free regs where - loop assig free _ | free `seq` False = undefined + loop _ free _ | free `seq` False = undefined loop assig free [] = do setAssigR assig; setFreeRegsR free; return () loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs loop assig free (r:rs) = @@ -570,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 @@ -589,7 +605,7 @@ clobberRegs clobbered = do clobber assig ((temp, InBoth reg slot) : rest) | reg `elem` clobbered = clobber (addToUFM assig temp (InMem slot)) rest - clobber assig (entry:rest) + clobber assig (_:rest) = clobber assig rest -- ----------------------------------------------------------------------------- @@ -610,7 +626,7 @@ allocateRegsAndSpill -> [Reg] -- temps to allocate -> RegM ([Instr], [RegNo]) -allocateRegsAndSpill reading keep spills alloc [] +allocateRegsAndSpill _ _ spills alloc [] = return (spills,reverse alloc) allocateRegsAndSpill reading keep spills alloc (r:rs) = do @@ -625,7 +641,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do -- 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. - Just (InBoth my_reg mem) -> do + Just (InBoth my_reg _) -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) allocateRegsAndSpill reading keep spills (my_reg:alloc) rs @@ -687,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 @@ -719,14 +735,14 @@ 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 myHead s [] = panic s -myHead s (x:xs) = x +myHead _ (x:_) = x -- ----------------------------------------------------------------------------- -- Joining a jump instruction to its targets @@ -745,7 +761,7 @@ joinToTargets -> [BlockId] -> RegM ([NatBasicBlock], Instr) -joinToTargets block_live new_blocks instr [] +joinToTargets _ new_blocks instr [] = return (new_blocks, instr) joinToTargets block_live new_blocks instr (dest:dests) = do @@ -769,17 +785,17 @@ 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 - Just (freeregs,dest_assig) + Just (_, dest_assig) -- the assignments match | ufmToList dest_assig == ufmToList adjusted_assig @@ -791,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 @@ -803,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 @@ -821,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 @@ -844,13 +860,13 @@ expandNode vreg loc@(InMem src) (InBoth dst mem) | src == mem = [(vreg, loc, [InReg dst])] | otherwise = [(vreg, loc, [InReg dst, InMem mem])] -expandNode vreg loc@(InBoth _ src) (InMem dst) +expandNode _ (InBoth _ src) (InMem dst) | src == dst = [] -- guaranteed to be true -expandNode vreg loc@(InBoth src _) (InReg dst) +expandNode _ (InBoth src _) (InReg dst) | src == dst = [] -expandNode vreg loc@(InBoth src _) dst +expandNode vreg (InBoth src _) dst = expandNode vreg (InReg src) dst expandNode vreg src dst @@ -862,7 +878,7 @@ expandNode vreg src dst -- can join together allocations for different basic blocks. -- makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr -makeMove delta vreg (InReg src) (InReg dst) +makeMove _ vreg (InReg src) (InReg dst) = do recordSpill (SpillJoinRR vreg) return $ mkRegRegMoveInstr (RealReg src) (RealReg dst) @@ -874,7 +890,7 @@ makeMove delta vreg (InReg src) (InMem dst) = do recordSpill (SpillJoinRM vreg) return $ mkSpillInstr (RealReg src) delta dst -makeMove delta vreg src dst +makeMove _ vreg src dst = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" ++ show dst ++ ")" ++ " (workaround: use -fviaC)" @@ -883,7 +899,7 @@ makeMove delta vreg src dst -- we have eliminated any possibility of single-node cylces -- in expandNode above. handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr] -handleComponent delta instr (AcyclicSCC (vreg,src,dsts)) +handleComponent delta _ (AcyclicSCC (vreg,src,dsts)) = mapM (makeMove delta vreg src) dsts -- we can not have cycles that involve memory @@ -891,11 +907,11 @@ handleComponent delta instr (AcyclicSCC (vreg,src,dsts)) -- because memory locations (stack slots) are -- allocated exclusively for a virtual register and -- therefore can not require a fixup -handleComponent delta instr (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest)) +handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest)) = do spill_id <- getUniqueR - (saveInstr,slot) <- spillR (RealReg sreg) spill_id - remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompR rest) + (_, slot) <- spillR (RealReg sreg) spill_id + remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest) restoreAndFixInstr <- getRestoreMoves dsts slot return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr) @@ -904,7 +920,7 @@ handleComponent delta instr (CyclicSCC ((vreg,src@(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 . (:[]) @@ -913,7 +929,7 @@ handleComponent delta instr (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest)) getRestoreMoves _ _ = panic "getRestoreMoves unknown case" -handleComponent delta instr (CyclicSCC _) +handleComponent _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" @@ -955,7 +971,7 @@ runR block_assig freeregs assig stack us thing = case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs, ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack, ra_us = us, ra_spills = [] }) of - (# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack', ra_spills=spills' }, returned_thing #) + (# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #) -> (block_assig, stack', makeRAStats state', returned_thing) spillR :: Reg -> Unique -> RegM (Instr, Int) @@ -1054,10 +1070,29 @@ binSpillReasons reasons SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons) +-- | Count reg-reg moves remaining in this code. +countRegRegMovesNat :: NatCmmTop -> Int +countRegRegMovesNat cmm + = execState (mapGenBlockTopM countBlock cmm) 0 + where + countBlock b@(BasicBlock _ instrs) + = do mapM_ countInstr instrs + return b + + countInstr instr + | Just _ <- isRegRegMove instr + = do modify (+ 1) + return instr + + | otherwise + = return instr + + -- | Pretty print some RegAllocStats -pprStats :: [RegAllocStats] -> SDoc -pprStats statss - = let spills = foldl' (plusUFM_C (zipWith (+))) +pprStats :: [NatCmmTop] -> [RegAllocStats] -> SDoc +pprStats code statss + = let -- sum up all the instrs inserted by the spiller + spills = foldl' (plusUFM_C (zipWith (+))) emptyUFM $ map ra_spillInstrs statss @@ -1065,12 +1100,15 @@ pprStats statss [0, 0, 0, 0, 0] $ eltsUFM spills + -- count how many reg-reg-moves remain in the code + moves = sum $ map countRegRegMovesNat code + pprSpill (reg, spills) = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills)) in ( text "-- spills-added-total" - $$ text "-- (allocs, clobbers, loads, joinRR, joinRM)" - $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals))) + $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)" + $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves]))) $$ text "" $$ text "-- spills-added" $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)" @@ -1082,12 +1120,9 @@ pprStats statss -- ----------------------------------------------------------------------------- -- Utils -#ifdef DEBUG -my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p -my_fromJust s p (Just x) = x -#else -my_fromJust _ _ = fromJust -#endif +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)