diff options
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Monad.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Pipeline.hs | 22 |
3 files changed, 28 insertions, 20 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index d7c0c23b0f..7486086406 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -435,7 +435,9 @@ lint_banner string pass = text "*** Core Lint" <+> text string showLintWarnings :: CoreToDo -> Bool -- Disable Lint warnings on the first simplifier pass, because -- there may be some INLINE knots still tied, which is tiresomely noisy -showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False +showLintWarnings (CoreDoSimplify cfg) = case sm_phase (cds_mode cfg) of + InitialPhase -> False + _ -> True showLintWarnings _ = True interactiveInScope :: InteractiveContext -> [Var] diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 777c3d36cf..7b44a6534e 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -11,7 +11,7 @@ module GHC.Core.Opt.Monad ( -- * Configuration of the core-to-core passes CoreToDo(..), runWhen, runMaybe, - SimplMode(..), + CoreDoSimplifyOpts(..), SimplMode(..), FloatOutSwitches(..), FloatEnable(..), floatEnable, @@ -105,13 +105,17 @@ import GHC.Utils.Panic (throwGhcException, GhcException(..), panic) ************************************************************************ -} +data CoreDoSimplifyOpts = CoreDoSimplifyOpts + { cds_max_iterations :: Int -- ^ Max iterations + , cds_mode :: SimplMode + } + data CoreToDo -- These are diff core-to-core passes, -- which may be invoked in any order, -- as many times as you like. - = CoreDoSimplify -- The core-to-core simplifier. - Int -- Max iterations - SimplMode + = CoreDoSimplify !CoreDoSimplifyOpts + -- ^ The core-to-core simplifier. | CoreDoPluginPass String CorePluginPass | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches @@ -141,7 +145,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreAddLateCcs instance Outputable CoreToDo where - ppr (CoreDoSimplify _ _) = text "Simplifier" + ppr (CoreDoSimplify _) = text "Simplifier" ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s ppr CoreDoFloatInwards = text "Float inwards" ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) @@ -167,8 +171,12 @@ instance Outputable CoreToDo where ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n - , ppr md ] +pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n + , ppr md ] + where + n = cds_max_iterations cfg + md = cds_mode cfg + pprPassDetails _ = Outputable.empty diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 910b24061b..b8ac982021 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -184,7 +184,7 @@ getCoreToDo logger dflags simpl_phase phase name iter = CoreDoPasses $ [ maybe_strictness_before phase - , CoreDoSimplify iter + , CoreDoSimplify $ CoreDoSimplifyOpts iter (base_mode { sm_phase = phase , sm_names = [name] }) @@ -195,7 +195,7 @@ getCoreToDo logger dflags simplify name = simpl_phase FinalPhase name max_iter -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify max_iter + simpl_gently = CoreDoSimplify $ CoreDoSimplifyOpts max_iter (base_mode { sm_phase = InitialPhase , sm_names = ["Gentle"] , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase] @@ -491,8 +491,8 @@ doCorePass pass guts = do let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } case pass of - CoreDoSimplify {} -> {-# SCC "Simplify" #-} - simplifyPgm pass guts + CoreDoSimplify cfg -> {-# SCC "Simplify" #-} + simplifyPgm cfg guts CoreCSE -> {-# SCC "CommonSubExpr" #-} updateBinds cseProgram @@ -650,20 +650,20 @@ simplExprGently env expr = do ************************************************************************ -} -simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts -simplifyPgm pass guts +simplifyPgm :: CoreDoSimplifyOpts -> ModGuts -> CoreM ModGuts +simplifyPgm cfg guts = do { hsc_env <- getHscEnv ; rb <- getRuleBase ; liftIOWithCount $ - simplifyPgmIO pass hsc_env rb guts } + simplifyPgmIO cfg hsc_env rb guts } -simplifyPgmIO :: CoreToDo +simplifyPgmIO :: CoreDoSimplifyOpts -> HscEnv -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts) -- New bindings -simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) +simplifyPgmIO cfg@(CoreDoSimplifyOpts max_iterations mode) hsc_env hpt_rule_base guts@(ModGuts { mg_module = this_mod , mg_rdr_env = rdr_env @@ -779,7 +779,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- Dump the result of this iteration let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ; dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ; - lintPassResult hsc_env pass binds2 ; + lintPassResult hsc_env (CoreDoSimplify cfg) binds2 ; -- Loop do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 @@ -793,8 +793,6 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) totalise = foldr (\c acc -> acc `plusSimplCount` c) (zeroSimplCount dflags) -simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO" - ------------------- dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () |