X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=e6491b77ee9a15cdbc437d30e2067c47a5695530;hp=d86e4608c33a63a3f3e654d2a7522e69b3388a89;hb=e3971de1fe67e414060047c09c4d5c64c7083981;hpb=0f7d268d00795a58a06ae3c92ebbd14571295b84 diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index d86e460..e6491b7 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- The register allocator @@ -81,7 +82,8 @@ The algorithm is roughly: -} module RegAllocLinear ( - regAlloc, + regAlloc, + RegAllocStats, pprStats ) where #include "HsVersions.h" @@ -90,7 +92,7 @@ import MachRegs import MachInstrs import RegAllocInfo import RegLiveness -import Cmm +import Cmm hiding (RegSet) import Digraph import Unique ( Uniquable(getUnique), Unique ) @@ -98,12 +100,11 @@ import UniqSet import UniqFM import UniqSupply import Outputable +import State -#ifndef DEBUG -import Data.Maybe ( fromJust ) -#endif -import Data.List ( nub, partition, mapAccumL) -import Control.Monad ( when ) +import Data.Maybe +import Data.List +import Control.Monad import Data.Word import Data.Bits @@ -154,8 +155,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 @@ -186,7 +188,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)) @@ -219,8 +221,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) @@ -232,25 +236,40 @@ getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg = -- Allocate registers regAlloc :: LiveCmmTop - -> UniqSM NatCmmTop + -> UniqSM (NatCmmTop, Maybe RegAllocStats) -regAlloc cmm@(CmmData sec d) - = returnUs $ CmmData sec d +regAlloc (CmmData sec d) + = return + ( CmmData sec d + , Nothing ) -regAlloc cmm@(CmmProc (LiveInfo info _ _) lbl params []) - = returnUs $ CmmProc info lbl params [] +regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) + = return + ( CmmProc info lbl params (ListGraph []) + , Nothing ) -regAlloc cmm@(CmmProc (LiveInfo info (Just first_id) block_live) lbl params comps) - = let ann_sccs = map (\b -> case b of - BasicBlock i [b] -> AcyclicSCC b - BasicBlock i bs -> CyclicSCC bs) - $ comps - - in linearRegAlloc block_live ann_sccs `thenUs` \final_blocks -> - - let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - in returnUs $ CmmProc info lbl params (first' : rest') +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 + $ map (\b -> case b of + BasicBlock _ [b] -> AcyclicSCC b + BasicBlock _ bs -> CyclicSCC bs) + $ comps + + -- 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')) + , Just stats) +-- bogus. to make non-exhaustive match warning go away. +regAlloc (CmmProc _ _ _ _) + = panic "RegAllocLinear.regAlloc: no match" -- ----------------------------------------------------------------------------- @@ -274,76 +293,85 @@ 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. +-- linearRegAlloc - :: BlockMap RegSet -- live regs on entry to each basic block - -> [SCC LiveBasicBlock] -- instructions annotated with "deaths" - -> UniqSM [NatBasicBlock] -linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap emptyStackMap sccs - where - linearRA_SCCs - :: BlockAssignment - -> StackMap - -> [SCC LiveBasicBlock] - -> UniqSM [NatBasicBlock] - linearRA_SCCs block_assig stack [] = returnUs [] - linearRA_SCCs block_assig stack - (AcyclicSCC (BasicBlock id instrs) : sccs) - = getUs `thenUs` \us -> - let - (block_assig',stack',(instrs',fixups)) = - case lookupUFM block_assig id of - -- no prior info about this block: assume everything is - -- free and the assignment is empty. - Nothing -> - runR block_assig initFreeRegs - emptyRegMap stack us $ - linearRA [] [] instrs - Just (freeregs,assig) -> - runR block_assig freeregs assig stack us $ - linearRA [] [] instrs - in - linearRA_SCCs block_assig' stack' sccs `thenUs` \moreBlocks -> - returnUs $ BasicBlock id instrs' : fixups ++ moreBlocks - - linearRA_SCCs block_assig stack - (CyclicSCC blocks : sccs) - = getUs `thenUs` \us -> - let - ((block_assig', stack', _), blocks') = mapAccumL processBlock - (block_assig, stack, us) - ({-reverse-} blocks) - in - linearRA_SCCs block_assig' stack' sccs `thenUs` \moreBlocks -> - returnUs $ concat blocks' ++ moreBlocks - where - processBlock (block_assig, stack, us0) (BasicBlock id instrs) - = ((block_assig', stack', us'), BasicBlock id instrs' : fixups) - where - (us, us') = splitUniqSupply us0 - (block_assig',stack',(instrs',fixups)) = - case lookupUFM block_assig id of - -- no prior info about this block: assume everything is - -- free and the assignment is empty. - Nothing -> - runR block_assig initFreeRegs - emptyRegMap stack us $ - linearRA [] [] instrs - Just (freeregs,assig) -> - runR block_assig freeregs assig stack us $ - linearRA [] [] instrs - - linearRA :: [Instr] -> [NatBasicBlock] -> [LiveInstr] + :: BlockMap RegSet -- ^ live regs on entry to each basic block + -> [SCC LiveBasicBlock] -- ^ instructions annotated with "deaths" + -> UniqSM ([NatBasicBlock], RegAllocStats) + +linearRegAlloc block_live sccs + = do us <- getUs + let (_, _, stats, blocks) = + runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us + $ linearRA_SCCs block_live [] sccs + + return (blocks, stats) + +linearRA_SCCs _ blocksAcc [] + = return $ reverse blocksAcc + +linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock block_live block + linearRA_SCCs 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 + (reverse (concat blockss') ++ blocksAcc) + sccs + + +-- | 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 + +processBlock block_live (BasicBlock id instrs) + = do initBlock id + (instrs', fixups) + <- linearRA block_live [] [] instrs + + return $ BasicBlock id instrs' : fixups + + +-- | Load the freeregs and current reg assignment into the RegM state +-- for the basic block with this BlockId. +initBlock :: BlockId -> RegM () +initBlock id + = do block_assig <- getBlockAssigR + case lookupUFM block_assig id of + -- no prior info about this block: assume everything is + -- free and the assignment is empty. + Nothing + -> do setFreeRegsR initFreeRegs + setAssigR emptyRegMap + + -- load info about register assignments leading into this block. + Just (freeregs, assig) + -> do setFreeRegsR freeregs + setAssigR assig + + +linearRA + :: BlockMap RegSet + -> [Instr] -> [NatBasicBlock] -> [LiveInstr] -> RegM ([Instr], [NatBasicBlock]) - linearRA instr_acc fixups [] = - return (reverse instr_acc, fixups) - linearRA instr_acc fixups (instr:instrs) = do - (instr_acc', new_fixups) <- raInsn block_live instr_acc instr - linearRA instr_acc' (new_fixups++fixups) instrs + +linearRA _ instr_acc fixups [] + = return (reverse instr_acc, fixups) + +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 -- ----------------------------------------------------------------------------- -- Register allocation for a single instruction @@ -358,10 +386,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, []) @@ -400,12 +428,12 @@ raInsn block_live new_instrs (Instr instr (Just live)) -} 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) @@ -474,7 +502,15 @@ genRaInsn block_live new_instrs instr r_dying w_dying = -- (j) free up stack slots for dead spilled regs -- TODO (can't be bothered right now) - return (patched_instr : w_spills ++ reverse r_spills + -- 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 + Just (src, dst) + | src == dst -> [] + _ -> [patched_instr] + + return (squashed_instr ++ w_spills ++ reverse r_spills ++ clobber_saves ++ new_instrs, fixup_blocks) }} @@ -487,7 +523,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) = @@ -534,8 +570,11 @@ saveClobberedTemps clobbered dying = do clobber assig instrs ((temp,reg):rest) = do --ToDo: copy it to another register if possible - (spill,slot) <- spillR (RealReg reg) temp - clobber (addToUFM assig temp (InBoth reg slot)) (spill: COMMENT FSLIT("spill clobber") : instrs) rest + (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 @@ -554,7 +593,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 -- ----------------------------------------------------------------------------- @@ -575,7 +614,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 @@ -590,7 +629,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 @@ -602,7 +641,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do -- case (2): we have a free register my_reg:_ -> do - spills' <- do_load reading loc my_reg spills + spills' <- loadTemp reading r loc my_reg spills let new_loc | Just (InMem slot) <- loc, reading = InBoth my_reg slot | otherwise = InReg my_reg @@ -630,7 +669,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do -- just free up its register for use. -- (temp,my_reg,slot):_ -> do - spills' <- do_load reading loc my_reg spills + spills' <- loadTemp reading r loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) assig2 = addToUFM assig1 r (InReg my_reg) @@ -640,33 +679,58 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do -- otherwise, we need to spill a temporary that currently -- resides in a register. + + [] -> do - let - (temp_to_push_out, my_reg) = myHead "regalloc" candidates2 - -- 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. - -- in - (spill_insn,slot) <- spillR (RealReg my_reg) temp_to_push_out - let - assig1 = addToUFM assig temp_to_push_out (InMem slot) - assig2 = addToUFM assig1 r (InReg my_reg) - -- in + + -- 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) = myHead "regalloc" candidates2 + + (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 - spills' <- do_load reading loc my_reg spills - allocateRegsAndSpill reading keep - (spill_insn : COMMENT FSLIT("spill alloc") : spills') + + -- 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 - where - -- load up a spilled temporary if we need to - do_load True (Just (InMem slot)) reg spills = do - insn <- loadR (RealReg reg) slot - return (insn : COMMENT FSLIT("spill load") : spills) - do_load _ _ _ spills = - return spills + + +-- | 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 + = do + insn <- loadR (RealReg hreg) slot + recordSpill (SpillLoad $ getUnique vreg) + 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 @@ -685,8 +749,9 @@ 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 block_assig <- getBlockAssigR assig <- getAssigR @@ -694,6 +759,8 @@ joinToTargets block_live new_blocks instr (dest:dests) = do -- 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. @@ -716,109 +783,144 @@ joinToTargets block_live new_blocks instr (dest:dests) = do (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 - -> -- ok, the assignments match - joinToTargets block_live new_blocks instr dests + -> joinToTargets block_live new_blocks instr dests + + -- need fixup code | otherwise - -> -- need fixup code - do + -> do delta <- getDeltaR - -- Construct a graph of register/spill movements and - -- untangle it component by component. - -- - -- 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. - let graph = [ node | (vreg, src) <- ufmToList adjusted_assig, - node <- mkNodes src vreg ] - - sccs = stronglyConnCompR graph - - mkNodes src vreg = - expandNode vreg src (lookupWithDefaultUFM_Directly - dest_assig - (panic "RegisterAlloc.joinToTargets") - 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 vreg loc@(InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true - expandNode vreg loc@(InBoth src _) (InReg dst) - | src == dst = [] - expandNode vreg loc@(InBoth src _) dst - = expandNode vreg (InReg src) dst - expandNode vreg src dst - | src == dst = [] - | otherwise = [(vreg, src, [dst])] - - -- we have eliminated any possibility of single-node cylces - -- in expandNode above. - handleComponent (AcyclicSCC (vreg,src,dsts)) - = return $ map (makeMove 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 (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest)) - = do - spill_id <- getUniqueR - (saveInstr,slot) <- spillR (RealReg sreg) spill_id - remainingFixUps <- mapM handleComponent (stronglyConnCompR rest) - restoreAndFixInstr <- getRestoreMoves dsts slot - return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr) - where - getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot - = do - restoreToReg <- loadR (RealReg reg) slot - return $ [restoreToReg, makeMove vreg r mem] - getRestoreMoves [InReg reg] slot - = loadR (RealReg reg) slot >>= return . (:[]) - getRestoreMoves [InMem _] _ = panic "getRestoreMoves can not handle memory only restores" - getRestoreMoves _ _ = panic "getRestoreMoves unknown case" - handleComponent (CyclicSCC _) - = panic "Register Allocator: handleComponent cyclic" - makeMove vreg (InReg src) (InReg dst) - = mkRegRegMoveInstr (RealReg src) (RealReg dst) - makeMove vreg (InMem src) (InReg dst) - = mkLoadInstr (RealReg dst) delta src - makeMove vreg (InReg src) (InMem dst) - = mkSpillInstr (RealReg src) delta dst - makeMove vreg src dst - = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" - ++ show dst ++ ")" - ++ " (workaround: use -fviaC)" - + let graph = makeRegMovementGraph adjusted_assig dest_assig + let sccs = stronglyConnCompR graph + fixUpInstrs <- mapM (handleComponent delta instr) sccs + block_id <- getUniqueR - fixUpInstrs <- mapM handleComponent sccs let block = BasicBlock (BlockId block_id) $ concat fixUpInstrs ++ mkBranchInstr dest + let instr' = patchJump instr dest (BlockId block_id) + joinToTargets block_live (block : new_blocks) instr' dests - where - live_set = lookItUp "joinToTargets" block_live dest + + +-- | 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 "RegisterAlloc.joinToTargets") + 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) (stronglyConnCompR 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] + + getRestoreMoves [InReg reg] slot + = loadR (RealReg reg) slot >>= return . (:[]) + + getRestoreMoves [InMem _] _ = panic "getRestoreMoves can not handle memory only restores" + getRestoreMoves _ _ = panic "getRestoreMoves unknown case" + + +handleComponent _ _ (CyclicSCC _) + = panic "Register Allocator: handleComponent cyclic" + + -- ----------------------------------------------------------------------------- -- The register allocator's monad. @@ -835,24 +937,30 @@ data RA_State ra_assig :: RegMap Loc, -- assignment of temps to locations ra_delta :: Int, -- current stack delta ra_stack :: StackMap, -- free stack slots for spilling - ra_us :: UniqSupply -- unique supply for generating names + ra_us :: UniqSupply, -- unique supply for generating names -- for fixup blocks. + + -- Record why things were spilled, for -ddrop-asm-stats. + -- Just keep a list here instead of a map of regs -> reasons. + -- We don't want to slow down the allocator if we're not going to emit the stats. + ra_spills :: [SpillReason] } newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) } + instance Monad RegM where m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } return a = RegM $ \s -> (# s, a #) runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> StackMap -> UniqSupply - -> RegM a -> (BlockAssignment, StackMap, a) + -> RegM a -> (BlockAssignment, StackMap, RegAllocStats, a) 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 }) of - (# RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #) - -> (block_assig, stack', returned_thing) + ra_us = us, ra_spills = [] }) of + (# 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) spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> @@ -901,12 +1009,108 @@ getUniqueR = RegM $ \s -> case splitUniqSupply (ra_us s) of (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #) +-- | Record that a spill instruction was inserted, for profiling. +recordSpill :: SpillReason -> RegM () +recordSpill spill + = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) + +-- ----------------------------------------------------------------------------- + +-- | Reasons why instructions might be inserted by the spiller. +-- Used when generating stats for -ddrop-asm-stats. +-- +data SpillReason + = SpillAlloc !Unique -- ^ vreg was spilled to a slot so we could use its + -- current hreg for another vreg + | SpillClobber !Unique -- ^ vreg was moved because its hreg was clobbered + | SpillLoad !Unique -- ^ vreg was loaded from a spill slot + + | SpillJoinRR !Unique -- ^ reg-reg move inserted during join to targets + | SpillJoinRM !Unique -- ^ reg-mem move inserted during join to targets + + +-- | Used to carry interesting stats out of the register allocator. +data RegAllocStats + = RegAllocStats + { ra_spillInstrs :: UniqFM [Int] } + + +-- | Make register allocator stats from its final state. +makeRAStats :: RA_State -> RegAllocStats +makeRAStats state + = RegAllocStats + { ra_spillInstrs = binSpillReasons (ra_spills state) } + + +-- | Build a map of how many times each reg was alloced, clobbered, loaded etc. +binSpillReasons + :: [SpillReason] -> UniqFM [Int] + +binSpillReasons reasons + = addListToUFM_C + (zipWith (+)) + emptyUFM + (map (\reason -> case reason of + SpillAlloc r -> (r, [1, 0, 0, 0, 0]) + SpillClobber r -> (r, [0, 1, 0, 0, 0]) + SpillLoad r -> (r, [0, 0, 1, 0, 0]) + SpillJoinRR r -> (r, [0, 0, 0, 1, 0]) + 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 :: [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 + + spillTotals = foldl' (zipWith (+)) + [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, 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)" + $$ (vcat $ map pprSpill + $ ufmToList spills) + $$ text "") + + -- ----------------------------------------------------------------------------- -- Utils #ifdef DEBUG my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p -my_fromJust s p (Just x) = x +my_fromJust _ _ (Just x) = x #else my_fromJust _ _ = fromJust #endif