Merge remote branch 'origin/master' into ghc-new-co

[ghc-hetmet.git] / compiler / cmm / CmmCPS.hs

diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index 372562c..6e97100 100644 (file)
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
 -- Norman likes local bindings
 -- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmCPS (
   -- | Converts C-- with full proceedures and parameters
   -- to a CPS transformed C-- with the stack made manifest.
@@ -71,10 +72,10 @@ cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
 cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
     do
        -- Why bother doing it this early?
-       -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+       -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
        --                       (dualLivenessWithInsertion callPPs) g
        -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
-       -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+       -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
        --                   (removeDeadAssignmentsAndReloads callPPs) g
        dump Opt_D_dump_cmmz "Pre common block elimination" g
        g <- return $ elimCommonBlocks g
@@ -91,16 +92,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        ----------- Spills and reloads -------------------
        g     <- 
               -- pprTrace "pre Spills" (ppr g) $
-                dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+                dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
                              (dualLivenessWithInsertion procPoints) g
                     -- Insert spills at defns; reloads at return points
        g     <-
               -- pprTrace "pre insertLateReloads" (ppr g) $
-                run $ insertLateReloads g -- Duplicate reloads just before uses
+                runOptimization $ insertLateReloads g -- Duplicate reloads just before uses
        dump Opt_D_dump_cmmz "Post late reloads" g
        g     <-
                -- pprTrace "post insertLateReloads" (ppr g) $
-                dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+                dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
                                         (removeDeadAssignmentsAndReloads procPoints) g
                     -- Remove redundant reloads (and any other redundant asst)
 
@@ -112,12 +113,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
 
        --------------- Stack layout ----------------
        slotEnv <- run $ liveSlotAnal g
+       let spEntryMap = getSpEntryMap entry_off g
        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
-       let areaMap = layout procPoints slotEnv entry_off g
+       let areaMap = layout procPoints spEntryMap slotEnv entry_off g
        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 
        ------------  Manifest the stack pointer --------
-       g  <- run $ manifestSP areaMap entry_off g
+       g  <- run $ manifestSP spEntryMap areaMap entry_off g
        dump Opt_D_dump_cmmz "after manifestSP" g
        -- UGH... manifestSP can require updates to the procPointMap.
        -- We can probably do something quicker here for the update...
@@ -146,12 +148,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
   where dflags = hsc_dflags hsc_env
         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
-
-        run = runFuelIO (hsc_OptFuel hsc_env)
-
-        dual_rewrite flag txt pass g =
+        -- Runs a required transformation/analysis
+        run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
+        -- Runs an optional transformation/analysis (and should
+        -- thus be subject to optimization fuel)
+        runOptimization = runFuelIO (hsc_OptFuel hsc_env)
+
+        -- pass 'run' or 'runOptimization' for 'r'
+        dual_rewrite r flag txt pass g =
           do dump flag ("Pre " ++ txt)  g
-             g <- run $ pass g
+             g <- r $ pass g
              dump flag ("Post " ++ txt) $ g
              return g