X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FGraph%2FSpill.hs;h=7e744e6337e898183946e8e64df8f1e59be4a4ad;hp=b5a645188ffc62eb0b2cd1f267d2c4294b14cee0;hb=14a496fd0b3aa821b69eb02736d5f41086576761;hpb=ee6bba6f3d80c56b47bc623bc6e4f076be1f046f diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index b5a6451..7e744e6 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -1,19 +1,19 @@ - {-# OPTIONS -fno-warn-missing-signatures #-} +-- | When there aren't enough registers to hold all the vregs we have to spill some of those +-- vregs to slots on the stack. This module is used modify the code to use those slots. +-- module RegAlloc.Graph.Spill ( regSpill, SpillStats(..), accSpillSL ) - where - import RegAlloc.Liveness -import RegAllocInfo -import Regs -import Instrs -import Cmm +import Instruction +import Reg +import Cmm hiding (RegSet) +import BlockId import State import Unique @@ -24,22 +24,28 @@ import Outputable import Data.List import Data.Maybe +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Set as Set --- | Spill all these virtual regs to memory --- TODO: see if we can split some of the live ranges instead of just globally --- spilling the virtual reg. +-- | Spill all these virtual regs to stack slots. +-- +-- TODO: See if we can split some of the live ranges instead of just globally +-- spilling the virtual reg. This might make the spill cleaner's job easier. -- --- TODO: On ciscy x86 and x86_64 we don't nessesarally have to add a mov instruction --- when making spills. If an instr is using a spilled virtual we may be able to --- address the spill slot directly. +-- TODO: On CISCy x86 and x86_64 we don't nessesarally have to add a mov instruction +-- when making spills. If an instr is using a spilled virtual we may be able to +-- address the spill slot directly. -- regSpill - :: [LiveCmmTop] -- ^ the code + :: Instruction instr + => [LiveCmmTop instr] -- ^ the code -> UniqSet Int -- ^ available stack slots - -> UniqSet Reg -- ^ the regs to spill + -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM - ([LiveCmmTop] -- code will spill instructions + ([LiveCmmTop instr] -- code with SPILL and RELOAD meta instructions added. , UniqSet Int -- left over slots , SpillStats ) -- stats about what happened during spilling @@ -63,7 +69,7 @@ regSpill code slotsFree regs -- run the spiller on all the blocks let (code', state') = - runState (mapM (mapBlockTopM (regSpill_block regSlotMap)) code) + runState (mapM (regSpill_top regSlotMap) code) (initSpillS us) return ( code' @@ -71,18 +77,93 @@ regSpill code slotsFree regs , makeSpillStats state') +-- | Spill some registers to stack slots in a top-level thing. +regSpill_top + :: Instruction instr + => RegMap Int -- ^ map of vregs to slots they're being spilled to. + -> LiveCmmTop instr -- ^ the top level thing. + -> SpillM (LiveCmmTop instr) + +regSpill_top regSlotMap cmm + = case cmm of + CmmData{} + -> return cmm + + CmmProc info label params sccs + | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info + -> do + -- We should only passed Cmms with the liveness maps filled in, but we'll + -- create empty ones if they're not there just in case. + let liveVRegsOnEntry = fromMaybe emptyBlockEnv mLiveVRegsOnEntry + + -- The liveVRegsOnEntry contains the set of vregs that are live on entry to + -- each basic block. If we spill one of those vregs we remove it from that + -- set and add the corresponding slot number to the liveSlotsOnEntry set. + -- The spill cleaner needs this information to erase unneeded spill and + -- reload instructions after we've done a successful allocation. + let liveSlotsOnEntry' :: Map BlockId (Set Int) + liveSlotsOnEntry' + = foldBlockEnv patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry + + let info' + = LiveInfo static firstId + (Just liveVRegsOnEntry) + liveSlotsOnEntry' + + -- Apply the spiller to all the basic blocks in the CmmProc. + sccs' <- mapM (mapSCCM (regSpill_block regSlotMap)) sccs + + return $ CmmProc info' label params sccs' + + where -- | Given a BlockId and the set of registers live in it, + -- if registers in this block are being spilled to stack slots, + -- then record the fact that these slots are now live in those blocks + -- in the given slotmap. + patchLiveSlot :: BlockId -> RegSet -> Map BlockId (Set Int) -> Map BlockId (Set Int) + patchLiveSlot blockId regsLive slotMap + = let curSlotsLive = fromMaybe Set.empty + $ Map.lookup blockId slotMap + + moreSlotsLive = Set.fromList + $ catMaybes + $ map (lookupUFM regSlotMap) + $ uniqSetToList regsLive + + slotMap' = Map.insert blockId (Set.union curSlotsLive moreSlotsLive) slotMap + + in slotMap' + + + +-- | Spill some registers to stack slots in a basic block. +regSpill_block + :: Instruction instr + => UniqFM Int -- ^ map of vregs to slots they're being spilled to. + -> LiveBasicBlock instr + -> SpillM (LiveBasicBlock instr) + regSpill_block regSlotMap (BasicBlock i instrs) = do instrss' <- mapM (regSpill_instr regSlotMap) instrs return $ BasicBlock i (concat instrss') -regSpill_instr _ li@(Instr _ Nothing) + +-- | Spill some registers to stack slots in a single instruction. If the instruction +-- uses registers that need to be spilled, then it is prefixed (or postfixed) with +-- the appropriate RELOAD or SPILL meta instructions. +regSpill_instr + :: Instruction instr + => UniqFM Int -- ^ map of vregs to slots they're being spilled to. + -> LiveInstr instr + -> SpillM [LiveInstr instr] + +regSpill_instr _ li@(LiveInstr _ Nothing) = do return [li] regSpill_instr regSlotMap - (Instr instr (Just _)) + (LiveInstr instr (Just _)) = do -- work out which regs are read and written in this instr - let RU rlRead rlWritten = regUsage instr + let RU rlRead rlWritten = regUsageOfInstr instr -- sometimes a register is listed as being read more than once, -- nub this so we don't end up inserting two lots of spill code. @@ -109,9 +190,9 @@ regSpill_instr regSlotMap let postfixes = concat mPostfixes -- final code - let instrs' = map (\i -> Instr i Nothing) prefixes - ++ [ Instr instr3 Nothing ] - ++ map (\i -> Instr i Nothing) postfixes + let instrs' = prefixes + ++ [LiveInstr instr3 Nothing] + ++ postfixes return {- $ pprTrace "* regSpill_instr spill" @@ -134,11 +215,12 @@ spillRead regSlotMap instr reg { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } return ( instr' - , ( [RELOAD slot nReg] + , ( [LiveInstr (RELOAD slot nReg) Nothing] , []) ) | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" + spillWrite regSlotMap instr reg | Just slot <- lookupUFM regSlotMap reg = do (instr', nReg) <- patchInstr reg instr @@ -148,10 +230,11 @@ spillWrite regSlotMap instr reg return ( instr' , ( [] - , [SPILL nReg slot])) + , [LiveInstr (SPILL nReg slot) Nothing])) | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" + spillModify regSlotMap instr reg | Just slot <- lookupUFM regSlotMap reg = do (instr', nReg) <- patchInstr reg instr @@ -160,36 +243,45 @@ spillModify regSlotMap instr reg { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } return ( instr' - , ( [RELOAD slot nReg] - , [SPILL nReg slot])) + , ( [LiveInstr (RELOAD slot nReg) Nothing] + , [LiveInstr (SPILL nReg slot) Nothing])) | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" --- | rewrite uses of this virtual reg in an instr to use a different virtual reg -patchInstr :: Reg -> Instr -> SpillM (Instr, Reg) +-- | Rewrite uses of this virtual reg in an instr to use a different virtual reg +patchInstr + :: Instruction instr + => Reg -> instr -> SpillM (instr, Reg) + patchInstr reg instr = do nUnique <- newUnique - let nReg = renameVirtualReg nUnique reg + let nReg = case reg of + RegVirtual vr -> RegVirtual (renameVirtualReg nUnique vr) + RegReal{} -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" let instr' = patchReg1 reg nReg instr return (instr', nReg) -patchReg1 :: Reg -> Reg -> Instr -> Instr +patchReg1 + :: Instruction instr + => Reg -> Reg -> instr -> instr + patchReg1 old new instr = let patchF r | r == old = new | otherwise = r - in patchRegs instr patchF - + in patchRegsOfInstr instr patchF ------------------------------------------------------- --- Spiller monad +-- Spiller monad -------------------------------------------------------------- data SpillS = SpillS - { stateUS :: UniqSupply - , stateSpillSL :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored + { -- | unique supply for generating fresh vregs. + stateUS :: UniqSupply + + -- | spilled vreg vs the number of times it was loaded, stored + , stateSpillSL :: UniqFM (Reg, Int, Int) } initSpillS uniqueSupply = SpillS @@ -200,20 +292,17 @@ type SpillM a = State SpillS a newUnique :: SpillM Unique newUnique - = do us <- gets stateUS - case splitUniqSupply us of - (us1, us2) - -> do let uniq = uniqFromSupply us1 - modify $ \s -> s { stateUS = us2 } - return uniq + = do us <- gets stateUS + case takeUniqFromSupply us of + (uniq, us') + -> do modify $ \s -> s { stateUS = us' } + return uniq accSpillSL (r1, s1, l1) (_, s2, l2) = (r1, s1 + s2, l1 + l2) ----------------------------------------------------- --- Spiller stats - +-- Spiller stats -------------------------------------------------------------- data SpillStats = SpillStats { spillStoreLoad :: UniqFM (Reg, Int, Int) }