+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module RegSpill (
- regSpill
+ regSpill,
+ SpillStats(..),
+ accSpillSL
)
where
import MachInstrs
import Cmm
+import State
import Unique
import UniqFM
import UniqSet
-> UniqSet Int -- ^ available stack slots
-> UniqSet Reg -- ^ the regs to spill
-> UniqSM
- ([LiveCmmTop] -- ^ code will spill instructions
- , UniqSet Int) -- ^ left over slots
+ ([LiveCmmTop] -- code will spill instructions
+ , UniqSet Int -- left over slots
+ , SpillStats ) -- stats about what happened during spilling
regSpill code slotsFree regs
us <- getUs
-- run the spiller on all the blocks
- let (# code', _ #) =
- runSpill (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
+ let (code', state') =
+ runState (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
(initSpillS us)
return ( code'
- , minusUniqSet slotsFree (mkUniqSet slots) )
+ , 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 (DELTA delta) _)
- = do
- setDelta delta
- return [li]
-
regSpill_instr _ li@(Instr _ Nothing)
= do return [li]
-
regSpill_instr regSlotMap
(Instr instr (Just live))
= do
spillRead regSlotMap instr reg
| Just slot <- lookupUFM regSlotMap reg
- = do delta <- getDelta
- (instr', nReg) <- patchInstr reg instr
+ = do (instr', nReg) <- patchInstr reg instr
- let pre = [ COMMENT FSLIT("spill read")
- , mkLoadInstr nReg delta slot ]
+ modify $ \s -> s
+ { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
- return ( instr', (pre, []))
+ 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 delta <- getDelta
- (instr', nReg) <- patchInstr reg instr
+ = do (instr', nReg) <- patchInstr reg instr
- let post = [ COMMENT FSLIT("spill write")
- , mkSpillInstr nReg delta slot ]
+ modify $ \s -> s
+ { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
- return ( instr', ([], post))
+ 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 delta <- getDelta
- (instr', nReg) <- patchInstr reg instr
-
- let pre = [ COMMENT FSLIT("spill mod load")
- , mkLoadInstr nReg delta slot ]
+ = do (instr', nReg) <- patchInstr reg instr
- let post = [ COMMENT FSLIT("spill mod write")
- , mkSpillInstr nReg delta slot ]
+ modify $ \s -> s
+ { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
- return ( instr', (pre, post))
+ 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
in patchRegs instr patchF
--------------------------------------------------------------------------------------------
+------------------------------------------------------
-- Spiller monad
data SpillS
= SpillS
- { stateDelta :: Int
- , stateUS :: UniqSupply }
+ { stateUS :: UniqSupply
+ , stateSpillSL :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
initSpillS uniqueSupply
= SpillS
- { stateDelta = 0
- , stateUS = uniqueSupply }
+ { stateUS = uniqueSupply
+ , stateSpillSL = emptyUFM }
-newtype SpillM a
- = SpillM
- { runSpill :: SpillS -> (# a, SpillS #) }
+type SpillM a = State SpillS a
-instance Monad SpillM where
- return x = SpillM $ \s -> (# x, s #)
+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
- m >>= n = SpillM $ \s ->
- case runSpill m s of
- (# r, s' #) -> runSpill (n r) s'
+accSpillSL (r1, s1, l1) (r2, s2, l2)
+ = (r1, s1 + s2, l1 + l2)
-setDelta :: Int -> SpillM ()
-setDelta delta
- = SpillM $ \s -> (# (), s { stateDelta = delta } #)
-getDelta :: SpillM Int
-getDelta = SpillM $ \s -> (# stateDelta s, s #)
+----------------------------------------------------
+-- Spiller stats
-newUnique :: SpillM Unique
-newUnique
- = SpillM $ \s
- -> case splitUniqSupply (stateUS s) of
- (us1, us2)
- -> (# uniqFromSupply us1
- , s { stateUS = us2 } #)
-
-mapAccumLM _ s [] = return (s, [])
-mapAccumLM f s (x:xs)
- = do
- (s1, x') <- f s x
- (s2, xs') <- mapAccumLM f s1 xs
- return (s2, x' : xs')
+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