import qualified GraphColor as Color
import RegLiveness
import RegSpill
+import RegSpillClean
import RegAllocStats
import MachRegs
import MachInstrs
-- patch the registers using the info in the graph
let code_patched = map (patchRegsFromGraph graph_colored) code
+ -- clean out unneeded SPILL/RELOADs
+ let code_spillclean = map cleanSpills code_patched
+
-- strip off liveness information
let code_nat = map stripLive code_patched
let stat =
RegAllocStatsColored
{ raGraph = graph_colored
- , raPatchedCmm = code_patched
- , raFinalCmm = code_final }
+ , raPatched = code_patched
+ , raSpillClean = code_spillclean
+ , raFinal = code_final }
- return ( code_nat
+ return ( code_final
, if dump
then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
else []
-- a successful coloring
| RegAllocStatsColored
{ raGraph :: Color.Graph Reg RegClass Reg -- ^ the colored graph
- , raPatchedCmm :: [LiveCmmTop] -- ^ code after register allocation
- , raFinalCmm :: [NatCmmTop] } -- ^ final code
+ , raPatched :: [LiveCmmTop] -- ^ code with vregs replaced by hregs
+ , raSpillClean :: [LiveCmmTop] -- ^ code with unneeded spill/reloads cleaned out
+ , raFinal :: [NatCmmTop] } -- ^ final code
instance Outputable RegAllocStats where
$$ Color.dotGraph regDotColor trivColorable (raGraph s)
$$ text ""
$$ text "# Native code after register allocation."
- $$ ppr (raPatchedCmm s)
+ $$ ppr (raPatched s)
+ $$ text ""
+ $$ text "# Clean out unneeded spill/reloads."
+ $$ ppr (raSpillClean s)
$$ text ""
$$ text "# Final code, after rewriting spill/rewrite pseudo instrs."
- $$ ppr (raFinalCmm s)
+ $$ ppr (raFinal s)
$$ text ""
--- /dev/null
+-- | Clean out unneeded spill/reload instrs
+--
+module RegSpillClean (
+ cleanSpills
+)
+where
+
+import RegLiveness
+import RegAllocInfo
+import MachRegs
+import MachInstrs
+import Cmm
+
+import UniqSet
+
+
+-- | Clean out unneeded spill/reloads from this top level thing.
+cleanSpills :: LiveCmmTop -> LiveCmmTop
+cleanSpills cmm
+ = mapBlockTop cleanBlock cmm
+ where
+ cleanBlock (BasicBlock id instrs)
+ = BasicBlock id
+ $ cleanSpill emptyUniqSet []
+ $ cleanReload emptyUniqSet []
+ $ instrs
+
+
+-- | Clean out unneeded reload instructions.
+-- Walking forwards across the code
+-- If there are no writes to a reg between a reload and the
+-- last spill or reload then we don't need the reload.
+--
+cleanReload
+ :: UniqSet Reg -- ^ hregs that were reloaded but not written to yet
+ -> [LiveInstr] -- ^ acc
+ -> [LiveInstr] -- ^ instrs to clean (in backwards order)
+ -> [LiveInstr] -- ^ cleaned instrs (in forward order)
+
+cleanReload valid acc [] = acc
+cleanReload valid acc (li@(Instr instr live) : instrs)
+ | SPILL reg slot <- instr
+ , valid' <- addOneToUniqSet valid reg
+ = cleanReload valid' (li : acc) instrs
+
+ | RELOAD slot reg <- instr
+ = if elementOfUniqSet reg valid
+ then cleanReload valid acc instrs
+ else cleanReload (addOneToUniqSet valid reg) (li : acc) instrs
+
+ | RU read written <- regUsage instr
+ , valid' <- minusUniqSet valid (mkUniqSet written)
+ = cleanReload valid' (li : acc) instrs
+
+
+-- | Clean out unneeded spill instructions.
+-- Walking backwards across the code.
+-- If there were no reloads from a slot between a spill and the last one
+-- then the slot was never read and we don't need the spill.
+
+cleanSpill
+ :: UniqSet Int -- ^ slots that have been spilled, but not reload from
+ -> [LiveInstr] -- ^ acc
+ -> [LiveInstr] -- ^ instrs to clean (in forwards order)
+ -> [LiveInstr] -- ^ cleaned instrs (in backwards order)
+
+cleanSpill unused acc [] = acc
+cleanSpill unused acc (li@(Instr instr live) : instrs)
+ | SPILL reg slot <- instr
+ = if elementOfUniqSet slot unused
+ then cleanSpill unused acc instrs
+ else cleanSpill (addOneToUniqSet unused slot) (li : acc) instrs
+
+ | RELOAD slot reg <- instr
+ , unused' <- delOneFromUniqSet unused slot
+ = cleanSpill unused' (li : acc) instrs
+
+ | otherwise
+ = cleanSpill unused (li : acc) instrs
+