| DELTA Int -- specify current stack offset for
-- benefit of subsequent passes
+ | SPILL Reg Int -- ^ spill this reg to a stack slot
+ | RELOAD Int Reg -- ^ reload this reg from a stack slot
+
-- -----------------------------------------------------------------------------
-- Alpha instructions
#if alpha_TARGET_ARCH
+pprInstr (SPILL reg slot)
+ = hcat [
+ ptext SLIT("\tSPILL"),
+ char '\t',
+ pprReg reg,
+ comma,
+ ptext SLIT("SLOT") <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+ = hcat [
+ ptext SLIT("\tRELOAD"),
+ char '\t',
+ ptext SLIT("SLOT") <> parens (int slot),
+ comma,
+ pprReg reg]
+
pprInstr (LD size reg addr)
= hcat [
ptext SLIT("\tld"),
#endif
-}
+pprInstr (SPILL reg slot)
+ = hcat [
+ ptext SLIT("\tSPILL"),
+ char ' ',
+ pprUserReg reg,
+ comma,
+ ptext SLIT("SLOT") <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+ = hcat [
+ ptext SLIT("\tRELOAD"),
+ char ' ',
+ ptext SLIT("SLOT") <> parens (int slot),
+ comma,
+ pprUserReg reg]
+
pprInstr (MOV size src dst)
= pprSizeOpOp SLIT("mov") size src dst
-- reads (bytearrays).
--
+pprInstr (SPILL reg slot)
+ = hcat [
+ ptext SLIT("\tSPILL"),
+ char '\t',
+ pprReg reg,
+ comma,
+ ptext SLIT("SLOT") <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+ = hcat [
+ ptext SLIT("\tRELOAD"),
+ char '\t',
+ ptext SLIT("SLOT") <> parens (int slot),
+ comma,
+ pprReg reg]
+
-- Translate to the following:
-- add g1,g2,g1
-- ld [g1],%fn
-- pprInstr for PowerPC
#if powerpc_TARGET_ARCH
+
+pprInstr (SPILL reg slot)
+ = hcat [
+ ptext SLIT("\tSPILL"),
+ char '\t',
+ pprReg reg,
+ comma,
+ ptext SLIT("SLOT") <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+ = hcat [
+ ptext SLIT("\tRELOAD"),
+ char '\t',
+ ptext SLIT("SLOT") <> parens (int slot),
+ comma,
+ pprReg reg]
+
pprInstr (LD sz reg addr) = hcat [
char '\t',
ptext SLIT("l"),
if isEmptyUniqSet rsSpill
then do
-- patch the registers using the info in the graph
+ -- also rewrite SPILL/REALOAD pseudos into real instructions
let code_patched = map (patchRegsFromGraph graph_colored) code
- let code_nat = map stripLive code_patched
+
+ let spillNatTop = mapGenBlockTop spillNatBlock
+ let code_nat = map (spillNatTop . stripLive) code_patched
+
-- record what happened in this stage for debugging
let stat =
#if alpha_TARGET_ARCH
regUsage instr = case instr of
+ SPILL reg slot -> usage ([reg], [])
+ RELOAD slot reg -> usage ([], [reg])
LD B reg addr -> usage (regAddr addr, [reg, t9])
LD Bu reg addr -> usage (regAddr addr, [reg, t9])
-- LD W reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED
COMMENT _ -> noUsage
DELTA _ -> noUsage
+ SPILL reg slot -> mkRU [reg] []
+ RELOAD slot reg -> mkRU [] [reg]
_other -> panic "regUsage: unrecognised instr"
#if sparc_TARGET_ARCH
regUsage instr = case instr of
+ SPILL reg slot -> usage ([reg], [])
+ RELOAD slot reg -> usage ([], [reg])
+
LD sz addr reg -> usage (regAddr addr, [reg])
ST sz reg addr -> usage (reg : regAddr addr, [])
ADD x cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
#if powerpc_TARGET_ARCH
regUsage instr = case instr of
+ SPILL reg slot -> usage ([reg], [])
+ RELOAD slot reg -> usage ([], [reg])
+
LD sz reg addr -> usage (regAddr addr, [reg])
LA sz reg addr -> usage (regAddr addr, [reg])
ST sz reg addr -> usage (reg : regAddr addr, [])
#if alpha_TARGET_ARCH
patchRegs instr env = case instr of
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
LD sz reg addr -> LD sz (env reg) (fixAddr addr)
LDA reg addr -> LDA (env reg) (fixAddr addr)
LDAH reg addr -> LDAH (env reg) (fixAddr addr)
NOP -> instr
COMMENT _ -> instr
DELTA _ -> instr
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
+
JXX _ _ -> instr
JXX_GBL _ _ -> instr
CLTD _ -> instr
#if sparc_TARGET_ARCH
patchRegs instr env = case instr of
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
LD sz addr reg -> LD sz (fixAddr addr) (env reg)
ST sz reg addr -> ST sz (env reg) (fixAddr addr)
ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
#if powerpc_TARGET_ARCH
patchRegs instr env = case instr of
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
+
LD sz reg addr -> LD sz (env reg) (fixAddr addr)
LA sz reg addr -> LA sz (env reg) (fixAddr addr)
ST sz reg addr -> ST sz (env reg) (fixAddr addr)
LiveInfo (..),
LiveBasicBlock,
- mapBlockTop,
- mapBlockTopM,
+ mapBlockTop, mapBlockTopM,
+ mapGenBlockTop, mapGenBlockTopM,
stripLive,
+ spillNatBlock,
slurpConflicts,
lifetimeCount,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
regLiveness
+
) where
#include "HsVersions.h"
return $ BasicBlock i blocks'
+-- map a function across all the basic blocks in this code
+mapGenBlockTop
+ :: (GenBasicBlock i -> GenBasicBlock i)
+ -> (GenCmmTop d h i -> GenCmmTop d h i)
+
+mapGenBlockTop f cmm
+ = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
+
+
+-- | map a function across all the basic blocks in this code (monadic version)
+mapGenBlockTopM
+ :: Monad m
+ => (GenBasicBlock i -> m (GenBasicBlock i))
+ -> (GenCmmTop d h i -> m (GenCmmTop d h i))
+
+mapGenBlockTopM f cmm@(CmmData{})
+ = return cmm
+
+mapGenBlockTopM f (CmmProc header label params blocks)
+ = do blocks' <- mapM f blocks
+ return $ CmmProc header label params blocks'
+
+
+
+
+
-- | Slurp out the list of register conflicts from this top level thing.
slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
stripLI (Instr instr _) = instr
+-- | Make real spill instructions out of SPILL, RELOAD pseudos
+
+spillNatBlock :: NatBasicBlock -> NatBasicBlock
+spillNatBlock (BasicBlock i instrs)
+ = BasicBlock i instrs'
+ where (instrs', _)
+ = runState (mapM spillNat instrs) 0
+
+ spillNat instr@(DELTA i)
+ = do put i
+ return instr
+
+ spillNat (SPILL reg slot)
+ = do delta <- get
+ return $ mkSpillInstr reg delta slot
+
+ spillNat (RELOAD slot reg)
+ = do delta <- get
+ return $ mkLoadInstr reg delta slot
+
+ spillNat instr
+ = return instr
+
+
-- | Slurp out a map of how many times each register was live upon entry to an instruction.
lifetimeCount
= 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
-
- let pre = [ COMMENT FSLIT("spill load")
- , mkLoadInstr nReg delta slot ]
+ = do (instr', nReg) <- patchInstr reg instr
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
-
- let post = [ COMMENT FSLIT("spill store")
- , mkSpillInstr nReg delta slot ]
+ = do (instr', nReg) <- patchInstr reg instr
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 ]
-
- let post = [ COMMENT FSLIT("spill mod store")
- , mkSpillInstr nReg delta slot ]
+ = do (instr', nReg) <- patchInstr reg instr
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"
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 }
type SpillM a = State SpillS a
-setDelta :: Int -> SpillM ()
-setDelta delta
- = modify $ \s -> s { stateDelta = delta }
-
-getDelta :: SpillM Int
-getDelta = gets stateDelta
-
newUnique :: SpillM Unique
newUnique
= do us <- gets stateUS
= (r1, s1 + s2, l1 + l2)
-
----------------------------------------------------
-- Spiller stats