Give infinite fuel to required C-- transformations. Fixes #4971.

Signed-off-by: Edward Z. Yang <ezyang@mit.edu>

diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index 372562c..b9f6db3 100644 (file)
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -71,10 +71,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 +91,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)
 
@@ -146,12 +146,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
 

diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs
index 057a965..8d3a06b 100644 (file)
--- a/compiler/cmm/OptimizationFuel.hs
+++ b/compiler/cmm/OptimizationFuel.hs
@@ -6,12 +6,12 @@
 -- the optimiser with varying amount of fuel to find out the exact number of
 -- steps where a bug is introduced in the output.
 module OptimizationFuel
-    ( OptimizationFuel, amountOfFuel, tankFilledTo, anyFuelLeft, oneLessFuel
+    ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel
     , OptFuelState, initOptFuelState
     , FuelConsumer, FuelUsingMonad, FuelState
     , fuelGet, fuelSet, lastFuelPass, setFuelPass
     , fuelExhausted, fuelDec1, tryWithFuel
-    , runFuelIO, fuelConsumingPass
+    , runFuelIO, runInfiniteFuelIO, fuelConsumingPass
     , FuelUniqSM
     , liftUniq
     )
@@ -51,6 +51,7 @@ amountOfFuel :: OptimizationFuel -> Int
 
 anyFuelLeft :: OptimizationFuel -> Bool
 oneLessFuel :: OptimizationFuel -> OptimizationFuel
+unlimitedFuel :: OptimizationFuel
 
 #ifdef DEBUG
 newtype OptimizationFuel = OptimizationFuel Int
@@ -61,6 +62,7 @@ amountOfFuel (OptimizationFuel f) = f
 
 anyFuelLeft (OptimizationFuel f) = f > 0
 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
+unlimitedFuel = OptimizationFuel infiniteFuel
 #else
 -- type OptimizationFuel = State# () -- would like this, but it won't work
 data OptimizationFuel = OptimizationFuel
@@ -70,6 +72,7 @@ amountOfFuel _ = maxBound
 
 anyFuelLeft _ = True
 oneLessFuel _ = OptimizationFuel
+unlimitedFuel = OptimizationFuel
 #endif
 
 data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String }
@@ -92,6 +95,16 @@ runFuelIO fs (FUSM f) =
        writeIORef (fuel_ref fs) fuel'
        return a
 
+-- ToDo: Do we need the pass_ref when we are doing infinite fueld
+-- transformations?
+runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a
+runInfiniteFuelIO fs (FUSM f) =
+    do pass <- readIORef (pass_ref fs)
+       u <- mkSplitUniqSupply 'u'
+       let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass)
+       writeIORef (pass_ref fs) pass'
+       return a
+
 instance Monad FuelUniqSM where
   FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s')
   return a     = FUSM (\s -> return (a, s))