+++ /dev/null
-
-{-# OPTIONS -fno-warn-missing-signatures #-}
-
-module RegSpill (
- regSpill,
- SpillStats(..),
- accSpillSL
-)
-
-where
-
-import RegLiveness
-import RegAllocInfo
-import MachRegs
-import MachInstrs
-import Cmm
-
-import State
-import Unique
-import UniqFM
-import UniqSet
-import UniqSupply
-import Outputable
-
-import Data.List
-import Data.Maybe
-
-
--- | 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.
---
--- 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
- -> UniqSet Int -- ^ available stack slots
- -> UniqSet Reg -- ^ the regs to spill
- -> UniqSM
- ([LiveCmmTop] -- code will spill instructions
- , UniqSet Int -- left over slots
- , SpillStats ) -- stats about what happened during spilling
-
-regSpill code slotsFree regs
-
- -- not enough slots to spill these regs
- | sizeUniqSet slotsFree < sizeUniqSet regs
- = pprPanic "regSpill: out of spill slots!"
- ( text " regs to spill = " <> ppr (sizeUniqSet regs)
- $$ text " slots left = " <> ppr (sizeUniqSet slotsFree))
-
- | otherwise
- = do
- -- allocate a slot for each of the spilled regs
- let slots = take (sizeUniqSet regs) $ uniqSetToList slotsFree
- let regSlotMap = listToUFM
- $ zip (uniqSetToList regs) slots
-
- -- grab the unique supply from the monad
- us <- getUs
-
- -- run the spiller on all the blocks
- let (code', state') =
- runState (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
- (initSpillS us)
-
- return ( code'
- , minusUniqSet slotsFree (mkUniqSet slots)
- , makeSpillStats state')
-
-
-regSpill_block regSlotMap (BasicBlock i instrs)
- = do instrss' <- mapM (regSpill_instr regSlotMap) instrs
- return $ BasicBlock i (concat instrss')
-
-regSpill_instr _ li@(Instr _ Nothing)
- = do return [li]
-
-regSpill_instr regSlotMap
- (Instr instr (Just _))
- = do
- -- work out which regs are read and written in this instr
- let RU rlRead rlWritten = regUsage 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.
- let rsRead_ = nub rlRead
- let rsWritten_ = nub rlWritten
-
- -- if a reg is modified, it appears in both lists, want to undo this..
- let rsRead = rsRead_ \\ rsWritten_
- let rsWritten = rsWritten_ \\ rsRead_
- let rsModify = intersect rsRead_ rsWritten_
-
- -- work out if any of the regs being used are currently being spilled.
- let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead
- let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten
- let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify
-
- -- rewrite the instr and work out spill code.
- (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead
- (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten
- (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
-
- let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)
- let prefixes = concat mPrefixes
- let postfixes = concat mPostfixes
-
- -- final code
- let instrs' = map (\i -> Instr i Nothing) prefixes
- ++ [ Instr instr3 Nothing ]
- ++ map (\i -> Instr i Nothing) postfixes
-
- return
-{- $ pprTrace "* regSpill_instr spill"
- ( text "instr = " <> ppr instr
- $$ text "read = " <> ppr rsSpillRead
- $$ text "write = " <> ppr rsSpillWritten
- $$ text "mod = " <> ppr rsSpillModify
- $$ text "-- out"
- $$ (vcat $ map ppr instrs')
- $$ text " ")
--}
- $ instrs'
-
-
-spillRead regSlotMap instr reg
- | Just slot <- lookupUFM regSlotMap reg
- = do (instr', nReg) <- patchInstr reg instr
-
- modify $ \s -> s
- { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
-
- return ( instr'
- , ( [RELOAD slot nReg]
- , []) )
-
- | 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
-
- modify $ \s -> s
- { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
-
- return ( instr'
- , ( []
- , [SPILL nReg slot]))
-
- | 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
-
- modify $ \s -> s
- { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
-
- return ( instr'
- , ( [RELOAD slot nReg]
- , [SPILL nReg slot]))
-
- | 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)
-patchInstr reg instr
- = do nUnique <- newUnique
- let nReg = renameVirtualReg nUnique reg
- let instr' = patchReg1 reg nReg instr
- return (instr', nReg)
-
-patchReg1 :: Reg -> Reg -> Instr -> Instr
-patchReg1 old new instr
- = let patchF r
- | r == old = new
- | otherwise = r
- in patchRegs instr patchF
-
-
-------------------------------------------------------
--- Spiller monad
-
-data SpillS
- = SpillS
- { stateUS :: UniqSupply
- , stateSpillSL :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
-
-initSpillS uniqueSupply
- = SpillS
- { stateUS = uniqueSupply
- , stateSpillSL = emptyUFM }
-
-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
-
-accSpillSL (r1, s1, l1) (_, s2, l2)
- = (r1, s1 + s2, l1 + l2)
-
-
-----------------------------------------------------
--- Spiller stats
-
-data SpillStats
- = SpillStats
- { spillStoreLoad :: UniqFM (Reg, Int, Int) }
-
-makeSpillStats :: SpillS -> SpillStats
-makeSpillStats s
- = SpillStats
- { spillStoreLoad = stateSpillSL s }
-
-instance Outputable SpillStats where
- ppr stats
- = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
- $ eltsUFM (spillStoreLoad stats))
-
projects / ghc-hetmet.git / blobdiff