Erase unneeded spill/reloads after register allocation

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 45727c5..5a3401f 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -23,6 +23,7 @@ where
 import qualified GraphColor    as Color
 import RegLiveness
 import RegSpill
 import qualified GraphColor    as Color
 import RegLiveness
 import RegSpill

+import RegSpillClean

 import RegAllocStats
 import MachRegs
 import MachInstrs
 import RegAllocStats
 import MachRegs
 import MachInstrs

@@ -108,6 +109,9 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                -- patch the registers using the info in the graph
                let code_patched        = map (patchRegsFromGraph graph_colored) code
 
                -- 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
 
                -- strip off liveness information
                let code_nat            = map stripLive code_patched
 

@@ -119,10 +123,11 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
                let stat                =
                        RegAllocStatsColored
                        { raGraph       = graph_colored
                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 []
                        , if dump
                                then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
                                else []

diff --git a/compiler/nativeGen/RegAllocStats.hs b/compiler/nativeGen/RegAllocStats.hs
index a762f83..7e08c1c 100644 (file)
--- a/compiler/nativeGen/RegAllocStats.hs
+++ b/compiler/nativeGen/RegAllocStats.hs
@@ -47,8 +47,9 @@ data RegAllocStats
        -- a successful coloring
        | RegAllocStatsColored
        { raGraph       :: Color.Graph Reg RegClass Reg -- ^ the colored graph
        -- 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
 
 
 instance Outputable RegAllocStats where
 

@@ -77,10 +78,13 @@ instance Outputable RegAllocStats where
        $$ Color.dotGraph regDotColor trivColorable (raGraph s)
        $$ text ""
        $$ text "#  Native code after register allocation."
        $$ 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."
        $$ text ""
        $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."

-       $$ ppr (raFinalCmm s)
+       $$ ppr (raFinal s)

        $$ text ""
 
 
        $$ text ""
 
 

diff --git a/compiler/nativeGen/RegSpillClean.hs b/compiler/nativeGen/RegSpillClean.hs
new file mode 100644 (file)
index 0000000..c451dc4
--- /dev/null
+++ b/compiler/nativeGen/RegSpillClean.hs
@@ -0,0 +1,80 @@
+-- | 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
+