X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLinear%2FMain.hs;h=473b549a149845943464aef5d5d6775634b97a34;hb=6cec61d14a324285dbb8ce73d4c7215f1f8d6766;hp=6dde72a3c180383c731614539eb41debbf08f70f;hpb=cbc96da034482b769889c109f6cc822f42b12027;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 6dde72a..473b549 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -48,7 +48,7 @@ The algorithm is roughly: (c) Update the current assignment - (d) If the intstruction is a branch: + (d) If the instruction is a branch: if the destination block already has a register assignment, Generate a new block with fixup code and redirect the jump to the new block. @@ -95,27 +95,27 @@ import RegAlloc.Linear.Base import RegAlloc.Linear.StackMap import RegAlloc.Linear.FreeRegs import RegAlloc.Linear.Stats +import RegAlloc.Linear.JoinToTargets +import TargetReg +import RegAlloc.Liveness +import Instruction +import Reg import BlockId -import MachRegs -import MachInstrs -import RegAllocInfo -import RegLiveness -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph -import Unique ( Uniquable(getUnique), Unique ) +import Unique import UniqSet import UniqFM import UniqSupply import Outputable -import FastString import Data.Maybe import Data.List import Control.Monad -#include "../includes/MachRegs.h" +#include "../includes/stg/MachRegs.h" -- ----------------------------------------------------------------------------- @@ -123,39 +123,36 @@ import Control.Monad -- Allocate registers regAlloc - :: LiveCmmTop - -> UniqSM (NatCmmTop, Maybe RegAllocStats) + :: (Outputable instr, Instruction instr) + => LiveCmmTop instr + -> UniqSM (NatCmmTop instr, Maybe RegAllocStats) regAlloc (CmmData sec d) = return ( CmmData sec d , Nothing ) -regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) - = return ( CmmProc info lbl params (ListGraph []) +regAlloc (CmmProc (LiveInfo info _ _ _) lbl []) + = return ( CmmProc info lbl (ListGraph []) , Nothing ) -regAlloc (CmmProc static lbl params (ListGraph comps)) - | LiveInfo info (Just first_id) 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) - <- linearRegAlloc first_id block_live - $ map (\b -> case b of - BasicBlock _ [b] -> AcyclicSCC b - BasicBlock _ bs -> CyclicSCC bs) - $ comps + <- linearRegAlloc first_id block_live sccs -- make sure the block that was first in the input list -- stays at the front of the output 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" @@ -168,10 +165,11 @@ regAlloc (CmmProc _ _ _ _) -- an entry in the block map or it is the first block. -- linearRegAlloc - :: BlockId -- ^ the first block + :: (Outputable instr, Instruction instr) + => BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block - -> [SCC LiveBasicBlock] -- ^ instructions annotated with "deaths" - -> UniqSM ([NatBasicBlock], RegAllocStats) + -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> UniqSM ([NatBasicBlock instr], RegAllocStats) linearRegAlloc first_id block_live sccs = do us <- getUs @@ -191,32 +189,68 @@ linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) sccs 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 []) + = do + blockss' <- process first_id block_live blocks [] (return []) False linearRA_SCCs first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs - + +{- from John Dias's patch 2008/10/16: + The linear-scan allocator sometimes allocates a block + before allocating one of its predecessors, which could lead to + inconsistent allocations. Make it so a block is only allocated + if a predecessor has set the "incoming" assignments for the block, or + if it's the procedure's entry block. + + BL 2009/02: Careful. If the assignment for a block doesn't get set for + some reason then this function will loop. We should probably do some + more sanity checking to guard against this eventuality. +-} + +process _ _ [] [] accum _ + = return $ reverse 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 madeProgress + = do + block_assig <- getBlockAssigR + + 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) True + + else process first_id block_live blocks + (b : next_round) accum madeProgress + -- | Do register allocation on this basic block -- processBlock - :: BlockMap RegSet -- ^ live regs on entry to each basic block - -> LiveBasicBlock -- ^ block to do register allocation on - -> RegM [NatBasicBlock] -- ^ block with registers allocated + :: (Outputable instr, Instruction instr) + => BlockMap RegSet -- ^ live regs on entry to each basic block + -> LiveBasicBlock instr -- ^ block to do register allocation on + -> RegM [NatBasicBlock instr] -- ^ block with registers allocated processBlock block_live (BasicBlock id instrs) = do initBlock id (instrs', fixups) - <- linearRA block_live [] [] instrs - + <- linearRA block_live [] [] id instrs return $ BasicBlock id instrs' : fixups @@ -225,11 +259,13 @@ 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 - -> do setFreeRegsR initFreeRegs + -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) + + setFreeRegsR initFreeRegs setAssigR emptyRegMap -- load info about register assignments leading into this block. @@ -238,38 +274,55 @@ initBlock id setAssigR assig +-- | Do allocation for a sequence of instructions. linearRA - :: BlockMap RegSet - -> [Instr] -> [NatBasicBlock] -> [LiveInstr] - -> RegM ([Instr], [NatBasicBlock]) - -linearRA _ instr_acc fixups [] - = return (reverse instr_acc, fixups) + :: (Outputable instr, Instruction instr) + => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. + -> BlockId -- ^ id of the current block, for debugging. + -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. -linearRA block_live instr_acc fixups (instr:instrs) - = do (instr_acc', new_fixups) <- raInsn block_live instr_acc instr - linearRA block_live instr_acc' (new_fixups++fixups) instrs + -> RegM ( [instr] -- instructions after register allocation + , [NatBasicBlock instr]) -- fresh blocks of fixup code. --- ----------------------------------------------------------------------------- --- Register allocation for a single instruction -raInsn :: BlockMap RegSet -- Live temporaries at each basic block - -> [Instr] -- new instructions (accum.) - -> LiveInstr -- the instruction (with "deaths") - -> RegM ( - [Instr], -- new instructions - [NatBasicBlock] -- extra fixup blocks - ) +linearRA _ accInstr accFixup _ [] + = return + ( reverse accInstr -- instrs need to be returned in the correct order. + , accFixup) -- it doesn't matter what order the fixup blocks are returned in. -raInsn _ new_instrs (Instr (COMMENT _) Nothing) - = return (new_instrs, []) -raInsn _ new_instrs (Instr (DELTA n) Nothing) +linearRA block_live accInstr accFixups id (instr:instrs) = do - setDeltaR n - return (new_instrs, []) + (accInstr', new_fixups) + <- raInsn block_live accInstr id instr + + linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs + -raInsn block_live new_instrs (Instr instr (Just live)) +-- | Do allocation for a single instruction. +raInsn + :: (Outputable instr, Instruction instr) + => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> BlockId -- ^ the id of the current block, for debugging + -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. + -> RegM + ( [instr] -- new instructions + , [NatBasicBlock instr]) -- extra fixup blocks + +raInsn _ new_instrs _ (LiveInstr ii Nothing) + | Just n <- takeDeltaInstr ii + = do setDeltaR n + return (new_instrs, []) + +raInsn _ new_instrs _ (LiveInstr ii Nothing) + | isMetaInstr ii + = return (new_instrs, []) + + +raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -278,15 +331,15 @@ raInsn block_live new_instrs (Instr instr (Just live)) -- register does not already have an assignment, -- and the source register is assigned to a register, not to a spill slot, -- then we can eliminate the instruction. - -- (we can't eliminitate it if the source register is on the stack, because + -- (we can't eliminate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) - case isRegRegMove instr of + case takeRegRegMoveInstr instr of Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), isVirtualReg dst, not (dst `elemUFM` assig), Just (InReg _) <- (lookupUFM assig src) -> do case src of - RealReg i -> setAssigR (addToUFM assig dst (InReg i)) + (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) -- if src is a fixed reg, then we just map dest to this -- reg in the assignment. src must be an allocatable reg, -- otherwise it wouldn't be in r_dying. @@ -299,42 +352,48 @@ raInsn block_live new_instrs (Instr instr (Just live)) {- 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 + _ -> genRaInsn block_live new_instrs id instr (uniqSetToList $ liveDieRead live) (uniqSetToList $ liveDieWrite live) -raInsn _ _ li - = pprPanic "raInsn" (text "no match for:" <> ppr li) +raInsn _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> ppr instr) + -genRaInsn block_live new_instrs instr r_dying w_dying = - case regUsage instr of { RU read written -> - case partition isRealReg written of { (real_written1,virt_written) -> + +genRaInsn block_live new_instrs block_id instr r_dying w_dying = + case regUsageOfInstr instr of { RU read written -> do - let - real_written = [ r | RealReg r <- real_written1 ] + let real_written = [ rr | (RegReal rr) <- written ] + let virt_written = [ vr | (RegVirtual vr) <- written ] - -- we don't need to do anything with real registers that are - -- only read by this instr. (the list is typically ~2 elements, - -- so using nub isn't a problem). - virt_read = nub (filter isVirtualReg read) - -- in + -- we don't need to do anything with real registers that are + -- only read by this instr. (the list is typically ~2 elements, + -- so using nub isn't a problem). + let virt_read = nub [ vr | (RegVirtual vr) <- read ] -- (a) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying - + clobber_saves <- saveClobberedTemps real_written r_dying -{- freeregs <- getFreeRegsR - assig <- getAssigR - pprTrace "raInsn" - (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written - $$ text (show freeregs) $$ ppr assig) - $ do + -- debugging +{- freeregs <- getFreeRegsR + assig <- getAssigR + pprTrace "genRaInsn" + (ppr instr + $$ text "r_dying = " <+> ppr r_dying + $$ text "w_dying = " <+> ppr w_dying + $$ text "virt_read = " <+> ppr virt_read + $$ text "virt_written = " <+> ppr virt_written + $$ text "freeregs = " <+> text (show freeregs) + $$ text "assig = " <+> ppr assig) + $ do -} -- (b), (c) allocate real regs for all regs read by this instruction. @@ -346,7 +405,7 @@ genRaInsn block_live new_instrs instr r_dying w_dying = -- these dead regs might in fact be live in the jump targets (they're -- only dead in the code that follows in the current basic block). (fixup_blocks, adjusted_instr) - <- joinToTargets block_live [] instr (jumpDests instr []) + <- joinToTargets block_live block_id instr -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. @@ -365,17 +424,20 @@ genRaInsn block_live new_instrs instr r_dying w_dying = let -- (i) Patch the instruction - patch_map = listToUFM [ (t,RealReg r) | - (t,r) <- zip virt_read r_allocd - ++ zip virt_written w_allocd ] + patch_map + = listToUFM + [ (t, RegReal r) + | (t, r) <- zip virt_read r_allocd + ++ zip virt_written w_allocd ] - patched_instr = patchRegs adjusted_instr patchLookup - patchLookup x = case lookupUFM patch_map x of - Nothing -> x - Just y -> y - -- in + patched_instr + = patchRegsOfInstr adjusted_instr patchLookup + + patchLookup x + = case lookupUFM patch_map x of + Nothing -> x + Just y -> y - -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do -- (j) free up stack slots for dead spilled regs -- TODO (can't be bothered right now) @@ -383,15 +445,20 @@ genRaInsn block_live new_instrs instr r_dying w_dying = -- erase reg->reg moves where the source and destination are the same. -- If the src temp didn't die in this instr but happened to be allocated -- to the same real reg as the destination, then we can erase the move anyway. - squashed_instr = case isRegRegMove patched_instr of + let squashed_instr = case takeRegRegMoveInstr patched_instr of Just (src, dst) | src == dst -> [] _ -> [patched_instr] - return (squashed_instr ++ w_spills ++ reverse r_spills - ++ clobber_saves ++ new_instrs, - fixup_blocks) - }} + let code = squashed_instr ++ w_spills ++ reverse r_spills + ++ clobber_saves ++ new_instrs + +-- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do +-- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do + + return (code, fixup_blocks) + + } -- ----------------------------------------------------------------------------- -- releaseRegs @@ -403,413 +470,278 @@ releaseRegs regs = do where 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 (RegReal rr : rs) = loop assig (releaseReg rr free) rs loop assig free (r:rs) = case lookupUFM assig r of Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs _other -> loop (delFromUFM assig r) free rs + -- ----------------------------------------------------------------------------- -- Clobber real registers -{- -For each temp in a register that is going to be clobbered: - - if the temp dies after this instruction, do nothing - - otherwise, put it somewhere safe (another reg if possible, - otherwise spill and record InBoth in the assignment). - -for allocateRegs on the temps *read*, - - clobbered regs are allocatable. +-- For each temp in a register that is going to be clobbered: +-- - if the temp dies after this instruction, do nothing +-- - otherwise, put it somewhere safe (another reg if possible, +-- otherwise spill and record InBoth in the assignment). +-- - for allocateRegs on the temps *read*, +-- - clobbered regs are allocatable. +-- +-- for allocateRegs on the temps *written*, +-- - clobbered regs are not allocatable. +-- +-- TODO: instead of spilling, try to copy clobbered +-- temps to another register if possible. +-- -for allocateRegs on the temps *written*, - - clobbered regs are not allocatable. --} saveClobberedTemps - :: [RegNo] -- real registers clobbered by this instruction - -> [Reg] -- registers which are no longer live after this insn - -> RegM [Instr] -- return: instructions to spill any temps that will - -- be clobbered. + :: (Outputable instr, Instruction instr) + => [RealReg] -- real registers clobbered by this instruction + -> [Reg] -- registers which are no longer live after this insn + -> RegM [instr] -- return: instructions to spill any temps that will + -- be clobbered. -saveClobberedTemps [] _ = return [] -- common case -saveClobberedTemps clobbered dying = do - assig <- getAssigR - let - to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig, - reg `elem` clobbered, - temp `notElem` map getUnique dying ] - -- in - (instrs,assig') <- clobber assig [] to_spill - setAssigR assig' - return instrs - where - clobber assig instrs [] = return (instrs,assig) - clobber assig instrs ((temp,reg):rest) - = do - --ToDo: copy it to another register if possible - (spill,slot) <- spillR (RealReg reg) temp - recordSpill (SpillClobber temp) - - let new_assign = addToUFM assig temp (InBoth reg slot) - clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest - -clobberRegs :: [RegNo] -> RegM () -clobberRegs [] = return () -- common case -clobberRegs clobbered = do - freeregs <- getFreeRegsR --- setFreeRegsR $! foldr grabReg freeregs clobbered - setFreeRegsR $! foldr allocateReg freeregs clobbered +saveClobberedTemps [] _ + = return [] - assig <- getAssigR - setAssigR $! clobber assig (ufmToList assig) - where - -- if the temp was InReg and clobbered, then we will have - -- saved it in saveClobberedTemps above. So the only case - -- we have to worry about here is InBoth. Note that this - -- also catches temps which were loaded up during allocation - -- of read registers, not just those saved in saveClobberedTemps. - clobber assig [] = assig - clobber assig ((temp, InBoth reg slot) : rest) - | reg `elem` clobbered - = clobber (addToUFM assig temp (InMem slot)) rest - clobber assig (_:rest) - = clobber assig rest - --- ----------------------------------------------------------------------------- --- allocateRegsAndSpill - --- This function does several things: --- For each temporary referred to by this instruction, --- we allocate a real register (spilling another temporary if necessary). --- We load the temporary up from memory if necessary. --- We also update the register assignment in the process, and --- the list of free registers and free stack slots. - -allocateRegsAndSpill - :: Bool -- True <=> reading (load up spilled regs) - -> [Reg] -- don't push these out - -> [Instr] -- spill insns - -> [RegNo] -- real registers allocated (accum.) - -> [Reg] -- temps to allocate - -> RegM ([Instr], [RegNo]) - -allocateRegsAndSpill _ _ spills alloc [] - = return (spills,reverse alloc) - -allocateRegsAndSpill reading keep spills alloc (r:rs) = do - assig <- getAssigR - case lookupUFM assig r of - -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be - -- 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 _) -> do - when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- Not already in a register, so we need to find a free one... - loc -> do - freeregs <- getFreeRegsR - - case getFreeRegs (regClass r) freeregs of - - -- case (2): we have a free register - my_reg:_ -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) $ -} - do - spills' <- loadTemp reading r loc my_reg spills - let new_loc - | Just (InMem slot) <- loc, reading = InBoth my_reg slot - | otherwise = InReg my_reg - setAssigR (addToUFM assig r $! new_loc) - setFreeRegsR $ allocateReg my_reg freeregs - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- case (3): we need to push something out to free up a register - [] -> do - let - keep' = map getUnique keep - candidates1 = [ (temp,reg,mem) - | (temp, InBoth reg mem) <- ufmToList assig, - temp `notElem` keep', regClass (RealReg reg) == regClass r ] - candidates2 = [ (temp,reg) - | (temp, InReg reg) <- ufmToList assig, - temp `notElem` keep', regClass (RealReg reg) == regClass r ] - -- in - ASSERT2(not (null candidates1 && null candidates2), - text (show freeregs) <+> ppr r <+> ppr assig) do - - case candidates1 of - - -- we have a temporary that is in both register and mem, - -- just free up its register for use. - -- - (temp,my_reg,slot):_ -> do - spills' <- loadTemp reading r loc my_reg spills - let - assig1 = addToUFM assig temp (InMem slot) - assig2 = addToUFM assig1 r (InReg my_reg) - -- in - setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- otherwise, we need to spill a temporary that currently - -- resides in a register. - - - [] -> do - - -- TODO: plenty of room for optimisation in choosing which temp - -- to spill. We just pick the first one that isn't used in - -- the current instruction for now. - - let (temp_to_push_out, my_reg) - = case candidates2 of - [] -> panic $ "RegAllocLinear.allocRegsAndSpill: no spill candidates" - ++ "assignment: " ++ show (ufmToList assig) ++ "\n" - (x:_) -> x - - (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out - let spill_store = (if reading then id else reverse) - [ COMMENT (fsLit "spill alloc") - , spill_insn ] - - -- record that this temp was spilled - recordSpill (SpillAlloc temp_to_push_out) - - -- update the register assignment - let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) - setAssigR assig2 - - -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp reading r loc my_reg spills - - allocateRegsAndSpill reading keep - (spill_store ++ spills') - (my_reg:alloc) rs - - --- | Load up a spilled temporary if we need to. -loadTemp - :: Bool - -> Reg -- the temp being loaded - -> Maybe Loc -- the current location of this temp - -> RegNo -- the hreg to load the temp into - -> [Instr] - -> RegM [Instr] - -loadTemp True vreg (Just (InMem slot)) hreg spills +saveClobberedTemps clobbered dying = do - insn <- loadR (RealReg hreg) slot - recordSpill (SpillLoad $ getUnique vreg) - return $ COMMENT (fsLit "spill load") : insn : spills + assig <- getAssigR + let to_spill + = [ (temp,reg) + | (temp, InReg reg) <- ufmToList assig + , any (realRegsAlias reg) clobbered + , temp `notElem` map getUnique dying ] + + (instrs,assig') <- clobber assig [] to_spill + setAssigR assig' + return instrs + + where + clobber assig instrs [] + = return (instrs, assig) + + clobber assig instrs ((temp, reg) : rest) + = do + (spill, slot) <- spillR (RegReal reg) temp -loadTemp _ _ _ _ spills = - return spills + -- record why this reg was spilled for profiling + recordSpill (SpillClobber temp) + let new_assign = addToUFM assig temp (InBoth reg slot) --- ----------------------------------------------------------------------------- --- Joining a jump instruction to its targets - --- The first time we encounter a jump to a particular basic block, we --- record the assignment of temporaries. The next time we encounter a --- jump to the same block, we compare our current assignment to the --- stored one. They might be different if spilling has occrred in one --- branch; so some fixup code will be required to match up the --- assignments. - -joinToTargets - :: BlockMap RegSet - -> [NatBasicBlock] - -> Instr - -> [BlockId] - -> RegM ([NatBasicBlock], Instr) - -joinToTargets _ new_blocks instr [] - = return (new_blocks, instr) - -joinToTargets block_live new_blocks instr (dest:dests) = do - block_assig <- getBlockAssigR - assig <- getAssigR - let - -- adjust the assignment to remove any registers which are not - -- live on entry to the destination block. - adjusted_assig = filterUFM_Directly still_live assig - - live_set = lookItUp "joinToTargets" block_live dest - still_live uniq _ = uniq `elemUniqSet_Directly` live_set - - -- and free up those registers which are now free. - to_free = - [ r | (reg, loc) <- ufmToList assig, - not (elemUniqSet_Directly reg live_set), - r <- regsOfLoc loc ] - - regsOfLoc (InReg r) = [r] - regsOfLoc (InBoth r _) = [r] - regsOfLoc (InMem _) = [] - -- in - 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 (extendBlockEnv block_assig dest - (freeregs',adjusted_assig)) - joinToTargets block_live new_blocks instr dests + clobber new_assign (spill : instrs) rest - Just (_, dest_assig) - -- the assignments match - | ufmToList dest_assig == ufmToList adjusted_assig - -> joinToTargets block_live new_blocks instr dests - -- need fixup code - | otherwise - -> do - delta <- getDeltaR - - let graph = makeRegMovementGraph adjusted_assig dest_assig - let sccs = stronglyConnCompFromEdgedVerticesR graph - fixUpInstrs <- mapM (handleComponent delta instr) sccs +-- | Mark all these real regs as allocated, +-- and kick out their vreg assignments. +-- +clobberRegs :: [RealReg] -> RegM () +clobberRegs [] + = return () - block_id <- getUniqueR - let block = BasicBlock (BlockId block_id) $ - concat fixUpInstrs ++ mkBranchInstr dest +clobberRegs clobbered + = do + freeregs <- getFreeRegsR + setFreeRegsR $! foldr allocateReg freeregs clobbered - let instr' = patchJump instr dest (BlockId block_id) + assig <- getAssigR + setAssigR $! clobber assig (ufmToList assig) - joinToTargets block_live (block : new_blocks) instr' dests + where + -- if the temp was InReg and clobbered, then we will have + -- saved it in saveClobberedTemps above. So the only case + -- we have to worry about here is InBoth. Note that this + -- also catches temps which were loaded up during allocation + -- of read registers, not just those saved in saveClobberedTemps. + clobber assig [] + = assig --- | Construct a graph of register\/spill movements. --- --- We cut some corners by --- a) not handling cyclic components --- b) not handling memory-to-memory moves. --- --- Cyclic components seem to occur only very rarely, --- and we don't need memory-to-memory moves because we --- make sure that every temporary always gets its own --- stack slot. - -makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])] -makeRegMovementGraph adjusted_assig dest_assig - = let - mkNodes src vreg - = expandNode vreg src - $ lookupWithDefaultUFM_Directly - dest_assig - (panic "RegAllocLinear.makeRegMovementGraph") - vreg - - in [ node | (vreg, src) <- ufmToList adjusted_assig - , node <- mkNodes src vreg ] - --- The InBoth handling is a little tricky here. If --- the destination is InBoth, then we must ensure that --- the value ends up in both locations. An InBoth --- destination must conflict with an InReg or InMem --- source, so we expand an InBoth destination as --- necessary. An InBoth source is slightly different: --- we only care about the register that the source value --- is in, so that we can move it to the destinations. - -expandNode vreg loc@(InReg src) (InBoth dst mem) - | src == dst = [(vreg, loc, [InMem mem])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] - -expandNode vreg loc@(InMem src) (InBoth dst mem) - | src == mem = [(vreg, loc, [InReg dst])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] - -expandNode _ (InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true - -expandNode _ (InBoth src _) (InReg dst) - | src == dst = [] - -expandNode vreg (InBoth src _) dst - = expandNode vreg (InReg src) dst - -expandNode vreg src dst - | src == dst = [] - | otherwise = [(vreg, src, [dst])] - - --- | Make a move instruction between these two locations so we --- can join together allocations for different basic blocks. --- -makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr -makeMove _ vreg (InReg src) (InReg dst) - = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr (RealReg src) (RealReg dst) - -makeMove delta vreg (InMem src) (InReg dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr (RealReg dst) delta src - -makeMove delta vreg (InReg src) (InMem dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr (RealReg src) delta dst - -makeMove _ vreg src dst - = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" - ++ show dst ++ ")" - ++ " (workaround: use -fviaC)" - - --- we have eliminated any possibility of single-node cylces --- in expandNode above. -handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr] -handleComponent delta _ (AcyclicSCC (vreg,src,dsts)) - = mapM (makeMove delta vreg src) dsts - --- we can not have cycles that involve memory --- locations as source nor as single destination --- because memory locations (stack slots) are --- allocated exclusively for a virtual register and --- therefore can not require a fixup -handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest)) - = do - spill_id <- getUniqueR - (_, slot) <- spillR (RealReg sreg) spill_id - remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest) - restoreAndFixInstr <- getRestoreMoves dsts slot - return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr) - - where - getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot - = do - restoreToReg <- loadR (RealReg reg) slot - moveInstr <- makeMove delta vreg r mem - return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr] + clobber assig ((temp, InBoth reg slot) : rest) + | any (realRegsAlias reg) clobbered + = clobber (addToUFM assig temp (InMem slot)) rest + + clobber assig (_:rest) + = clobber assig rest + +-- ----------------------------------------------------------------------------- +-- allocateRegsAndSpill - getRestoreMoves [InReg reg] slot - = loadR (RealReg reg) slot >>= return . (:[]) +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY - getRestoreMoves [InMem _] _ = panic "getRestoreMoves can not handle memory only restores" - getRestoreMoves _ _ = panic "getRestoreMoves unknown case" +-- This function does several things: +-- For each temporary referred to by this instruction, +-- we allocate a real register (spilling another temporary if necessary). +-- We load the temporary up from memory if necessary. +-- We also update the register assignment in the process, and +-- the list of free registers and free stack slots. +allocateRegsAndSpill + :: (Outputable instr, Instruction instr) + => Bool -- True <=> reading (load up spilled regs) + -> [VirtualReg] -- don't push these out + -> [instr] -- spill insns + -> [RealReg] -- real registers allocated (accum.) + -> [VirtualReg] -- temps to allocate + -> RegM ( [instr] + , [RealReg]) -handleComponent _ _ (CyclicSCC _) - = panic "Register Allocator: handleComponent cyclic" +allocateRegsAndSpill _ _ spills alloc [] + = return (spills, reverse alloc) + +allocateRegsAndSpill reading keep spills alloc (r:rs) + = do assig <- getAssigR + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig + case lookupUFM assig r of + -- case (1a): already in a register + Just (InReg my_reg) -> + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- case (1b): already in a register (and memory) + -- NB1. if we're writing this register, update its assignment to be + -- 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 _) + -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- Not already in a register, so we need to find a free one... + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- ToDo: This case should be a panic, but we + -- sometimes see an unreachable basic block which + -- triggers this because the register allocator + -- will start with an empty assignment. + doSpill WriteNew + + | otherwise -> doSpill WriteNew + +-- reading is redundant with reason, but we keep it around because it's +-- convenient and it maintains the recursive structure of the allocator. -- EZY +allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc + = do + freeRegs <- getFreeRegsR + let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs + + case freeRegs_thisClass of + + -- case (2): we have a free register + (my_reg : _) -> + do spills' <- loadTemp r spill_loc my_reg spills + + setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) + setFreeRegsR $ allocateReg my_reg freeRegs + + allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs + + + -- case (3): we need to push something out to free up a register + [] -> + do let keep' = map getUnique keep + + -- the vregs we could kick out that are already in a slot + let candidates_inBoth + = [ (temp, reg, mem) + | (temp, InBoth reg mem) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg reg == classOfVirtualReg r ] + + -- the vregs we could kick out that are only in a reg + -- this would require writing the reg to a new slot before using it. + let candidates_inReg + = [ (temp, reg) + | (temp, InReg reg) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg reg == classOfVirtualReg r ] + + let result + + -- we have a temporary that is in both register and mem, + -- just free up its register for use. + | (temp, my_reg, slot) : _ <- candidates_inBoth + = do spills' <- loadTemp r spill_loc my_reg spills + let assig1 = addToUFM assig temp (InMem slot) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg + + setAssigR assig2 + allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + + -- otherwise, we need to spill a temporary that currently + -- resides in a register. + | (temp_to_push_out, (my_reg :: RealReg)) : _ + <- candidates_inReg + = do + (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out + let spill_store = (if reading then id else reverse) + [ -- COMMENT (fsLit "spill alloc") + spill_insn ] + + -- record that this temp was spilled + recordSpill (SpillAlloc temp_to_push_out) + + -- update the register assignment + let assig1 = addToUFM assig temp_to_push_out (InMem slot) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg + setAssigR assig2 + + -- if need be, load up a spilled temp into the reg we've just freed up. + spills' <- loadTemp r spill_loc my_reg spills + + allocateRegsAndSpill reading keep + (spill_store ++ spills') + (my_reg:alloc) rs + + + -- there wasn't anything to spill, so we're screwed. + | otherwise + = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") + $ vcat + [ text "allocating vreg: " <> text (show r) + , text "assignment: " <> text (show $ ufmToList assig) + , text "freeRegs: " <> text (show freeRegs) + , text "initFreeRegs: " <> text (show initFreeRegs) ] + + result + +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealReg -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg --- ----------------------------------------------------------------------------- --- Utils +-- | Load up a spilled temporary if we need to (read from memory). +loadTemp + :: (Outputable instr, Instruction instr) + => VirtualReg -- the temp being loaded + -> SpillLoc -- the current location of this temp + -> RealReg -- the hreg to load the temp into + -> [instr] + -> RegM [instr] + +loadTemp vreg (ReadMem slot) hreg spills + = do + insn <- loadR (RegReal hreg) slot + recordSpill (SpillLoad $ getUnique vreg) + return $ {- COMMENT (fsLit "spill load") : -} insn : spills -my_fromJust :: String -> SDoc -> Maybe a -> a -my_fromJust _ _ (Just x) = x -my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p +loadTemp _ _ _ spills = + return spills -lookItUp :: String -> BlockMap a -> BlockId -> a -lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x)