    {-
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

    \section[SimplCore]{Driver for simplifying @Core@ programs}
    -}

    {-# LANGUAGE CPP #-}

    module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where

    import GHC.Prelude

    import GHC.Driver.DynFlags
    import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
    import GHC.Driver.Env
    import GHC.Driver.Config.Core.Lint ( endPass )
    import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
    import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode )
    import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts )
    import GHC.Driver.Config.Core.Rules ( initRuleOpts )
    import GHC.Platform.Ways  ( hasWay, Way(WayProf) )

    import GHC.Core
    import GHC.Core.Opt.CSE  ( cseProgram )
    import GHC.Core.Rules   ( RuleBase, mkRuleBase, ruleCheckProgram, getRules )
    import GHC.Core.Ppr     ( pprCoreBindings )
    import GHC.Core.Utils   ( dumpIdInfoOfProgram )
    import GHC.Core.Lint    ( lintAnnots )
    import GHC.Core.Lint.Interactive ( interactiveInScope )
    import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm )
    import GHC.Core.Opt.Simplify.Monad
    import GHC.Core.Opt.Monad
    import GHC.Core.Opt.Pipeline.Types
    import GHC.Core.Opt.FloatIn      ( floatInwards )
    import GHC.Core.Opt.FloatOut     ( floatOutwards )
    import GHC.Core.Opt.LiberateCase ( liberateCase )
    import GHC.Core.Opt.StaticArgs   ( doStaticArgs )
    import GHC.Core.Opt.Specialise   ( specProgram)
    import GHC.Core.Opt.SpecConstr   ( specConstrProgram)
    import GHC.Core.Opt.DmdAnal
    import GHC.Core.Opt.CprAnal      ( cprAnalProgram )
    import GHC.Core.Opt.CallArity    ( callArityAnalProgram )
    import GHC.Core.Opt.Exitify      ( exitifyProgram )
    import GHC.Core.Opt.WorkWrap     ( wwTopBinds )
    import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )
    import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG)
    import GHC.Core.Seq (seqBinds)
    import GHC.Core.FamInstEnv

    import GHC.Utils.Error  ( withTiming )
    import GHC.Utils.Logger as Logger
    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    import GHC.Unit.Module.ModGuts

    import GHC.Types.Id.Info
    import GHC.Types.Basic
    import GHC.Types.Demand ( zapDmdEnvSig )
    import GHC.Types.Name.Ppr
    import GHC.Types.Var ( Var )

    import Control.Monad
    import qualified GHC.LanguageExtensions as LangExt
    import GHC.Unit.Module

    {-
    ************************************************************************
    *                                                                      *
    \subsection{The driver for the simplifier}
    *                                                                      *
    ************************************************************************
    -}

    core2core :: HscEnv -> ModGuts -> IO ModGuts
    core2core :: HscEnv -> ModGuts -> IO ModGuts
    core2core HscEnv
    hsc_env guts :: ModGuts
    guts@(ModGuts { mg_module :: ModGuts -> Module
    mg_module  = Module
    mod
                                    , mg_loc :: ModGuts -> SrcSpan
    mg_loc     = SrcSpan
    loc
                                    , mg_rdr_env :: ModGuts -> GlobalRdrEnv
    mg_rdr_env = GlobalRdrEnv
    rdr_env })
      = do { let builtin_passes :: [CoreToDo]
    builtin_passes = DynFlags -> RuleBase -> [CoreBndr] -> [CoreToDo]
    getCoreToDo DynFlags
    dflags RuleBase
    hpt_rule_base [CoreBndr]
    extra_vars
                 uniq_tag :: Char
    uniq_tag = Char
    's'

           ; (guts2, stats) <- HscEnv
    -> RuleBase
    -> Char
    -> Module
    -> NamePprCtx
    -> SrcSpan
    -> CoreM ModGuts
    -> IO (ModGuts, SimplCount)
    forall a.
    HscEnv
    -> RuleBase
    -> Char
    -> Module
    -> NamePprCtx
    -> SrcSpan
    -> CoreM a
    -> IO (a, SimplCount)
    runCoreM HscEnv
    hsc_env RuleBase
    hpt_rule_base Char
    uniq_tag Module
    mod
                                        NamePprCtx
    name_ppr_ctx SrcSpan
    loc (CoreM ModGuts -> IO (ModGuts, SimplCount))
    -> CoreM ModGuts -> IO (ModGuts, SimplCount)
    forall a b. (a -> b) -> a -> b
    $
                               do { hsc_env' <- CoreM HscEnv
    getHscEnv
                                  ; all_passes <- withPlugins (hsc_plugins hsc_env')
                                                    installCoreToDos
                                                    builtin_passes
                                  ; runCorePasses all_passes guts }

           ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats
                 "Grand total simplifier statistics"
                 FormatText
                 (pprSimplCount stats)

           ; return guts2 }
      where
        dflags :: DynFlags
    dflags         = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
        logger :: Logger
    logger         = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env
        extra_vars :: [CoreBndr]
    extra_vars     = InteractiveContext -> [CoreBndr]
    interactiveInScope (HscEnv -> InteractiveContext
    hsc_IC HscEnv
    hsc_env)
        home_pkg_rules :: [CoreRule]
    home_pkg_rules = HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
    hptRules HscEnv
    hsc_env (Module -> UnitId
    moduleUnitId Module
    mod) (GWIB { gwib_mod :: ModuleName
    gwib_mod = Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Module
    mod
                                                                   , gwib_isBoot :: IsBootInterface
    gwib_isBoot = IsBootInterface
    NotBoot })
        hpt_rule_base :: RuleBase
    hpt_rule_base  = [CoreRule] -> RuleBase
    mkRuleBase [CoreRule]
    home_pkg_rules
        name_ppr_ctx :: NamePprCtx
    name_ppr_ctx   = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
    forall info.
    Outputable info =>
    PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
    mkNamePprCtx PromotionTickContext
    ptc (HscEnv -> UnitEnv
    hsc_unit_env HscEnv
    hsc_env) GlobalRdrEnv
    rdr_env
        ptc :: PromotionTickContext
    ptc            = DynFlags -> PromotionTickContext
    initPromotionTickContext DynFlags
    dflags
        -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
        -- This is very convienent for the users of the monad (e.g. plugins do not have to
        -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
        -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
        -- would mean our cached value would go out of date.

    {-
    ************************************************************************
    *                                                                      *
               Generating the main optimisation pipeline
    *                                                                      *
    ************************************************************************
    -}

    getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo]
    -- This function builds the pipeline of optimisations
    getCoreToDo :: DynFlags -> RuleBase -> [CoreBndr] -> [CoreToDo]
    getCoreToDo DynFlags
    dflags RuleBase
    hpt_rule_base [CoreBndr]
    extra_vars
      = [CoreToDo] -> [CoreToDo]
    flatten_todos [CoreToDo]
    core_todo
      where
        phases :: PhaseNum
    phases        = DynFlags -> PhaseNum
    simplPhases        DynFlags
    dflags
        max_iter :: PhaseNum
    max_iter      = DynFlags -> PhaseNum
    maxSimplIterations DynFlags
    dflags
        rule_check :: Maybe String
    rule_check    = DynFlags -> Maybe String
    ruleCheck          DynFlags
    dflags
        const_fold :: Bool
    const_fold    = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_CoreConstantFolding          DynFlags
    dflags
        call_arity :: Bool
    call_arity    = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_CallArity                    DynFlags
    dflags
        exitification :: Bool
    exitification = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Exitification                DynFlags
    dflags
        strictness :: Bool
    strictness    = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Strictness                   DynFlags
    dflags
        full_laziness :: Bool
    full_laziness = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_FullLaziness                 DynFlags
    dflags
        do_specialise :: Bool
    do_specialise = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Specialise                   DynFlags
    dflags
        do_float_in :: Bool
    do_float_in   = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_FloatIn                      DynFlags
    dflags
        cse :: Bool
    cse           = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_CSE                          DynFlags
    dflags
        spec_constr :: Bool
    spec_constr   = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_SpecConstr                   DynFlags
    dflags
        liberate_case :: Bool
    liberate_case = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_LiberateCase                 DynFlags
    dflags
        late_dmd_anal :: Bool
    late_dmd_anal = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_LateDmdAnal                  DynFlags
    dflags
        late_specialise :: Bool
    late_specialise = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_LateSpecialise             DynFlags
    dflags
        static_args :: Bool
    static_args   = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_StaticArgumentTransformation DynFlags
    dflags
        rules_on :: Bool
    rules_on      = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_EnableRewriteRules           DynFlags
    dflags
        ww_on :: Bool
    ww_on         = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_WorkerWrapper                DynFlags
    dflags
        static_ptrs :: Bool
    static_ptrs   = Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.StaticPointers           DynFlags
    dflags
        profiling :: Bool
    profiling     = DynFlags -> Ways
    ways DynFlags
    dflags Ways -> Way -> Bool
    `hasWay` Way
    WayProf

        do_presimplify :: Bool
    do_presimplify = Bool
    do_specialise -- TODO: any other optimizations benefit from pre-simplification?
        do_simpl3 :: Bool
    do_simpl3      = Bool
    const_fold Bool -> Bool -> Bool
    || Bool
    rules_on -- TODO: any other optimizations benefit from three-phase simplification?

        maybe_rule_check :: CompilerPhase -> CoreToDo
    maybe_rule_check CompilerPhase
    phase = Maybe String -> (String -> CoreToDo) -> CoreToDo
    forall a. Maybe a -> (a -> CoreToDo) -> CoreToDo
    runMaybe Maybe String
    rule_check (CompilerPhase -> String -> CoreToDo
    CoreDoRuleCheck CompilerPhase
    phase)

        maybe_strictness_before :: CompilerPhase -> CoreToDo
    maybe_strictness_before (Phase PhaseNum
    phase)
          | PhaseNum
    phase PhaseNum -> [PhaseNum] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` DynFlags -> [PhaseNum]
    strictnessBefore DynFlags
    dflags = Bool -> CoreToDo
    CoreDoDemand Bool
    False
        maybe_strictness_before CompilerPhase
    _
          = CoreToDo
    CoreDoNothing

        simpl_phase :: CompilerPhase -> String -> PhaseNum -> CoreToDo
    simpl_phase CompilerPhase
    phase String
    name PhaseNum
    iter
          = [CoreToDo] -> CoreToDo
    CoreDoPasses
          ([CoreToDo] -> CoreToDo) -> [CoreToDo] -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $   [ CompilerPhase -> CoreToDo
    maybe_strictness_before CompilerPhase
    phase
              , SimplifyOpts -> CoreToDo
    CoreDoSimplify (SimplifyOpts -> CoreToDo) -> SimplifyOpts -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ DynFlags
    -> [CoreBndr] -> PhaseNum -> SimplMode -> RuleBase -> SimplifyOpts
    initSimplifyOpts DynFlags
    dflags [CoreBndr]
    extra_vars PhaseNum
    iter
                                 (DynFlags -> CompilerPhase -> String -> SimplMode
    initSimplMode DynFlags
    dflags CompilerPhase
    phase String
    name) RuleBase
    hpt_rule_base
              , CompilerPhase -> CoreToDo
    maybe_rule_check CompilerPhase
    phase ]

        -- Run GHC's internal simplification phase, after all rules have run.
        -- See Note [Compiler phases] in GHC.Types.Basic
        simplify :: String -> CoreToDo
    simplify String
    name = CompilerPhase -> String -> PhaseNum -> CoreToDo
    simpl_phase CompilerPhase
    FinalPhase String
    name PhaseNum
    max_iter

        -- initial simplify: mk specialiser happy: minimum effort please
        -- See Note [Inline in InitialPhase]
        -- See Note [RULEs enabled in InitialPhase]
        simpl_gently :: CoreToDo
    simpl_gently = SimplifyOpts -> CoreToDo
    CoreDoSimplify (SimplifyOpts -> CoreToDo) -> SimplifyOpts -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ DynFlags
    -> [CoreBndr] -> PhaseNum -> SimplMode -> RuleBase -> SimplifyOpts
    initSimplifyOpts DynFlags
    dflags [CoreBndr]
    extra_vars PhaseNum
    max_iter
                                        (DynFlags -> SimplMode
    initGentleSimplMode DynFlags
    dflags) RuleBase
    hpt_rule_base

        dmd_cpr_ww :: [CoreToDo]
    dmd_cpr_ww = if Bool
    ww_on then [Bool -> CoreToDo
    CoreDoDemand Bool
    True,CoreToDo
    CoreDoCpr,CoreToDo
    CoreDoWorkerWrapper]
                              else [Bool -> CoreToDo
    CoreDoDemand Bool
    False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper]

        demand_analyser :: CoreToDo
    demand_analyser = ([CoreToDo] -> CoreToDo
    CoreDoPasses (
                               [CoreToDo]
    dmd_cpr_ww [CoreToDo] -> [CoreToDo] -> [CoreToDo]
    forall a. [a] -> [a] -> [a]
    ++
                               [String -> CoreToDo
    simplify String
    "post-worker-wrapper"]
                               ))

        -- Static forms are moved to the top level with the FloatOut pass.
        -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
        static_ptrs_float_outwards :: CoreToDo
    static_ptrs_float_outwards =
          Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    static_ptrs (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ [CoreToDo] -> CoreToDo
    CoreDoPasses
            [ CoreToDo
    simpl_gently -- Float Out can't handle type lets (sometimes created
                           -- by simpleOptPgm via mkParallelBindings)
            , FloatOutSwitches -> CoreToDo
    CoreDoFloatOutwards FloatOutSwitches
              { floatOutLambdas :: Maybe PhaseNum
    floatOutLambdas   = PhaseNum -> Maybe PhaseNum
    forall a. a -> Maybe a
    Just PhaseNum
    0
              , floatOutConstants :: Bool
    floatOutConstants = Bool
    True
              , floatOutOverSatApps :: Bool
    floatOutOverSatApps = Bool
    False
              , floatToTopLevelOnly :: Bool
    floatToTopLevelOnly = Bool
    True
              }
            ]

        add_caller_ccs :: CoreToDo
    add_caller_ccs =
            Bool -> CoreToDo -> CoreToDo
    runWhen (Bool
    profiling Bool -> Bool -> Bool
    && Bool -> Bool
    not ([CallerCcFilter] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null ([CallerCcFilter] -> Bool) -> [CallerCcFilter] -> Bool
    forall a b. (a -> b) -> a -> b
    $ DynFlags -> [CallerCcFilter]
    callerCcFilters DynFlags
    dflags)) CoreToDo
    CoreAddCallerCcs

        add_late_ccs :: CoreToDo
    add_late_ccs =
            Bool -> CoreToDo -> CoreToDo
    runWhen (Bool
    profiling Bool -> Bool -> Bool
    && GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_ProfLateInlineCcs DynFlags
    dflags) (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ CoreToDo
    CoreAddLateCcs

        core_todo :: [CoreToDo]
    core_todo =
         [
        -- We want to do the static argument transform before full laziness as it
        -- may expose extra opportunities to float things outwards. However, to fix
        -- up the output of the transformation we need at do at least one simplify
        -- after this before anything else
            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    static_args ([CoreToDo] -> CoreToDo
    CoreDoPasses [ CoreToDo
    simpl_gently, CoreToDo
    CoreDoStaticArgs ]),

            -- initial simplify: mk specialiser happy: minimum effort please
            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    do_presimplify CoreToDo
    simpl_gently,

            -- Specialisation is best done before full laziness
            -- so that overloaded functions have all their dictionary lambdas manifest
            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    do_specialise CoreToDo
    CoreDoSpecialising,

            if Bool
    full_laziness then
               FloatOutSwitches -> CoreToDo
    CoreDoFloatOutwards FloatOutSwitches {
                                     floatOutLambdas :: Maybe PhaseNum
    floatOutLambdas   = PhaseNum -> Maybe PhaseNum
    forall a. a -> Maybe a
    Just PhaseNum
    0,
                                     floatOutConstants :: Bool
    floatOutConstants = Bool
    True,
                                     floatOutOverSatApps :: Bool
    floatOutOverSatApps = Bool
    False,
                                     floatToTopLevelOnly :: Bool
    floatToTopLevelOnly = Bool
    False }
                    -- Was: gentleFloatOutSwitches
                    --
                    -- I have no idea why, but not floating constants to
                    -- top level is very bad in some cases.
                    --
                    -- Notably: p_ident in spectral/rewrite
                    --          Changing from "gentle" to "constantsOnly"
                    --          improved rewrite's allocation by 19%, and
                    --          made 0.0% difference to any other nofib
                    --          benchmark
                    --
                    -- Not doing floatOutOverSatApps yet, we'll do
                    -- that later on when we've had a chance to get more
                    -- accurate arity information.  In fact it makes no
                    -- difference at all to performance if we do it here,
                    -- but maybe we save some unnecessary to-and-fro in
                    -- the simplifier.
            else
               -- Even with full laziness turned off, we still need to float static
               -- forms to the top level. See Note [Grand plan for static forms] in
               -- GHC.Iface.Tidy.StaticPtrTable.
               CoreToDo
    static_ptrs_float_outwards,

            -- Run the simplifier phases 2,1,0 to allow rewrite rules to fire
            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    do_simpl3
                ([CoreToDo] -> CoreToDo
    CoreDoPasses ([CoreToDo] -> CoreToDo) -> [CoreToDo] -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ [ CompilerPhase -> String -> PhaseNum -> CoreToDo
    simpl_phase (PhaseNum -> CompilerPhase
    Phase PhaseNum
    phase) String
    "main" PhaseNum
    max_iter
                                | PhaseNum
    phase <- [PhaseNum
    phases, PhaseNum
    phasesPhaseNum -> PhaseNum -> PhaseNum
    forall a. Num a => a -> a -> a
    -PhaseNum
    1 .. PhaseNum
    1] ] [CoreToDo] -> [CoreToDo] -> [CoreToDo]
    forall a. [a] -> [a] -> [a]
    ++
                                [ CompilerPhase -> String -> PhaseNum -> CoreToDo
    simpl_phase (PhaseNum -> CompilerPhase
    Phase PhaseNum
    0) String
    "main" (PhaseNum -> PhaseNum -> PhaseNum
    forall a. Ord a => a -> a -> a
    max PhaseNum
    max_iter PhaseNum
    3) ]),
                    -- Phase 0: allow all Ids to be inlined now
                    -- This gets foldr inlined before strictness analysis

                    -- At least 3 iterations because otherwise we land up with
                    -- huge dead expressions because of an infelicity in the
                    -- simplifier.
                    --      let k = BIG in foldr k z xs
                    -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
                    -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
                    -- Don't stop now!

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    do_float_in CoreToDo
    CoreDoFloatInwards,
                -- Run float-inwards immediately before the strictness analyser
                -- Doing so pushes bindings nearer their use site and hence makes
                -- them more likely to be strict. These bindings might only show
                -- up after the inlining from simplification.  Example in fulsom,
                -- Csg.calc, where an arg of timesDouble thereby becomes strict.

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    call_arity (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ [CoreToDo] -> CoreToDo
    CoreDoPasses
                [ CoreToDo
    CoreDoCallArity
                , String -> CoreToDo
    simplify String
    "post-call-arity"
                ],

            -- Strictness analysis
            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    strictness CoreToDo
    demand_analyser,

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    exitification CoreToDo
    CoreDoExitify,
                -- See Note [Placement of the exitification pass]

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    full_laziness (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $
               FloatOutSwitches -> CoreToDo
    CoreDoFloatOutwards FloatOutSwitches {
                                     floatOutLambdas :: Maybe PhaseNum
    floatOutLambdas     = DynFlags -> Maybe PhaseNum
    floatLamArgs DynFlags
    dflags,
                                     floatOutConstants :: Bool
    floatOutConstants   = Bool
    True,
                                     floatOutOverSatApps :: Bool
    floatOutOverSatApps = Bool
    True,
                                     floatToTopLevelOnly :: Bool
    floatToTopLevelOnly = Bool
    False },
                    -- nofib/spectral/hartel/wang doubles in speed if you
                    -- do full laziness late in the day.  It only happens
                    -- after fusion and other stuff, so the early pass doesn't
                    -- catch it.  For the record, the redex is
                    --        f_el22 (f_el21 r_midblock)

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    cse CoreToDo
    CoreCSE,
                    -- We want CSE to follow the final full-laziness pass, because it may
                    -- succeed in commoning up things floated out by full laziness.
                    -- CSE used to rely on the no-shadowing invariant, but it doesn't any more

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    do_float_in CoreToDo
    CoreDoFloatInwards,

            String -> CoreToDo
    simplify String
    "final",  -- Final tidy-up

            CompilerPhase -> CoreToDo
    maybe_rule_check CompilerPhase
    FinalPhase,

            --------  After this we have -O2 passes -----------------
            -- None of them run with -O

                    -- Case-liberation for -O2.  This should be after
                    -- strictness analysis and the simplification which follows it.
            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    liberate_case (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ [CoreToDo] -> CoreToDo
    CoreDoPasses
               [ CoreToDo
    CoreLiberateCase, String -> CoreToDo
    simplify String
    "post-liberate-case" ],
               -- Run the simplifier after LiberateCase to vastly
               -- reduce the possibility of shadowing
               -- Reason: see Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecConstr

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    spec_constr (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ [CoreToDo] -> CoreToDo
    CoreDoPasses
               [ CoreToDo
    CoreDoSpecConstr, String -> CoreToDo
    simplify String
    "post-spec-constr"],
               -- See Note [Simplify after SpecConstr]

            CompilerPhase -> CoreToDo
    maybe_rule_check CompilerPhase
    FinalPhase,

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    late_specialise (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ [CoreToDo] -> CoreToDo
    CoreDoPasses
               [ CoreToDo
    CoreDoSpecialising, String -> CoreToDo
    simplify String
    "post-late-spec"],

            -- LiberateCase can yield new CSE opportunities because it peels
            -- off one layer of a recursive function (concretely, I saw this
            -- in wheel-sieve1), and I'm guessing that SpecConstr can too
            -- And CSE is a very cheap pass. So it seems worth doing here.
            Bool -> CoreToDo -> CoreToDo
    runWhen ((Bool
    liberate_case Bool -> Bool -> Bool
    || Bool
    spec_constr) Bool -> Bool -> Bool
    && Bool
    cse) (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ [CoreToDo] -> CoreToDo
    CoreDoPasses
               [ CoreToDo
    CoreCSE, String -> CoreToDo
    simplify String
    "post-final-cse" ],

            ---------  End of -O2 passes --------------

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    late_dmd_anal (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
    forall a b. (a -> b) -> a -> b
    $ [CoreToDo] -> CoreToDo
    CoreDoPasses (
                [CoreToDo]
    dmd_cpr_ww [CoreToDo] -> [CoreToDo] -> [CoreToDo]
    forall a. [a] -> [a] -> [a]
    ++ [String -> CoreToDo
    simplify String
    "post-late-ww"]
              ),

            -- Final run of the demand_analyser, ensures that one-shot thunks are
            -- really really one-shot thunks. Only needed if the demand analyser
            -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal
            -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution
            -- can become /exponentially/ more expensive. See #11731, #12996.
            Bool -> CoreToDo -> CoreToDo
    runWhen (Bool
    strictness Bool -> Bool -> Bool
    || Bool
    late_dmd_anal) (Bool -> CoreToDo
    CoreDoDemand Bool
    False),

            CompilerPhase -> CoreToDo
    maybe_rule_check CompilerPhase
    FinalPhase,

            CoreToDo
    add_caller_ccs,
            CoreToDo
    add_late_ccs
         ]

        -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.
        flatten_todos :: [CoreToDo] -> [CoreToDo]
    flatten_todos [] = []
        flatten_todos (CoreToDo
    CoreDoNothing : [CoreToDo]
    rest) = [CoreToDo] -> [CoreToDo]
    flatten_todos [CoreToDo]
    rest
        flatten_todos (CoreDoPasses [CoreToDo]
    passes : [CoreToDo]
    rest) =
          [CoreToDo] -> [CoreToDo]
    flatten_todos [CoreToDo]
    passes [CoreToDo] -> [CoreToDo] -> [CoreToDo]
    forall a. [a] -> [a] -> [a]
    ++ [CoreToDo] -> [CoreToDo]
    flatten_todos [CoreToDo]
    rest
        flatten_todos (CoreToDo
    todo : [CoreToDo]
    rest) = CoreToDo
    todo CoreToDo -> [CoreToDo] -> [CoreToDo]
    forall a. a -> [a] -> [a]
    : [CoreToDo] -> [CoreToDo]
    flatten_todos [CoreToDo]
    rest

    -- The core-to-core pass ordering is derived from the DynFlags:
    runWhen :: Bool -> CoreToDo -> CoreToDo
    runWhen :: Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    True  CoreToDo
    do_this = CoreToDo
    do_this
    runWhen Bool
    False CoreToDo
    _       = CoreToDo
    CoreDoNothing

    runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
    runMaybe :: forall a. Maybe a -> (a -> CoreToDo) -> CoreToDo
    runMaybe (Just a
    x) a -> CoreToDo
    f = a -> CoreToDo
    f a
    x
    runMaybe Maybe a
    Nothing  a -> CoreToDo
    _ = CoreToDo
    CoreDoNothing

    {- Note [Inline in InitialPhase]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is
    confusing for users because when they say INLINE they expect the function to inline
    right away.

    So now we do inlining immediately, even in the InitialPhase, assuming that the
    Id's Activation allows it.

    This is a surprisingly big deal. Compiler performance improved a lot
    when I made this change:

       perf/compiler/T5837.run            T5837 [stat too good] (normal)
       perf/compiler/parsing001.run       parsing001 [stat too good] (normal)
       perf/compiler/T12234.run           T12234 [stat too good] (optasm)
       perf/compiler/T9020.run            T9020 [stat too good] (optasm)
       perf/compiler/T3064.run            T3064 [stat too good] (normal)
       perf/compiler/T9961.run            T9961 [stat too good] (normal)
       perf/compiler/T13056.run           T13056 [stat too good] (optasm)
       perf/compiler/T9872d.run           T9872d [stat too good] (normal)
       perf/compiler/T783.run             T783 [stat too good] (normal)
       perf/compiler/T12227.run           T12227 [stat too good] (normal)
       perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)
       perf/compiler/T1969.run            T1969 [stat too good] (normal)
       perf/compiler/T9872a.run           T9872a [stat too good] (normal)
       perf/compiler/T9872c.run           T9872c [stat too good] (normal)
       perf/compiler/T9872b.run           T9872b [stat too good] (normal)
       perf/compiler/T9872d.run           T9872d [stat too good] (normal)

    Note [RULEs enabled in InitialPhase]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    RULES are enabled when doing "gentle" simplification in InitialPhase,
    or with -O0.  Two reasons:

      * We really want the class-op cancellation to happen:
            op (df d1 d2) --> $cop3 d1 d2
        because this breaks the mutual recursion between 'op' and 'df'

      * I wanted the RULE
            lift String ===> ...
        to work in Template Haskell when simplifying
        splices, so we get simpler code for literal strings

    But watch out: list fusion can prevent floating.  So use phase control
    to switch off those rules until after floating.

    Note [Simplify after SpecConstr]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We want to run the simplifier after SpecConstr, and before late-Specialise,
    for two reasons, both shown up in test perf/compiler/T16473,
    with -O2 -flate-specialise

    1.  I found that running late-Specialise after SpecConstr, with no
        simplification in between meant that the carefully constructed
        SpecConstr rule never got to fire.  (It was something like
              lvl = f a   -- Arity 1
              ....g lvl....
        SpecConstr specialised g for argument lvl; but Specialise then
        specialised lvl = f a to lvl = $sf, and inlined. Or something like
        that.)

    2.  Specialise relies on unfoldings being available for top-level dictionary
        bindings; but SpecConstr kills them all!  The Simplifer restores them.

    This extra run of the simplifier has a cost, but this is only with -O2.

    ************************************************************************
    *                                                                      *
                      The CoreToDo interpreter
    *                                                                      *
    ************************************************************************
    -}

    runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
    runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
    runCorePasses [CoreToDo]
    passes ModGuts
    guts
      = (ModGuts -> CoreToDo -> CoreM ModGuts)
    -> ModGuts -> [CoreToDo] -> CoreM ModGuts
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM ModGuts -> CoreToDo -> CoreM ModGuts
    do_pass ModGuts
    guts [CoreToDo]
    passes
      where
        do_pass :: ModGuts -> CoreToDo -> CoreM ModGuts
    do_pass ModGuts
    guts CoreToDo
    CoreDoNothing = ModGuts -> CoreM ModGuts
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ModGuts
    guts
        do_pass ModGuts
    guts (CoreDoPasses [CoreToDo]
    ps) = [CoreToDo] -> ModGuts -> CoreM ModGuts
    runCorePasses [CoreToDo]
    ps ModGuts
    guts
        do_pass ModGuts
    guts CoreToDo
    pass = do
          logger <- CoreM Logger
    forall (m :: * -> *). HasLogger m => m Logger
    getLogger
          withTiming logger (ppr pass <+> brackets (ppr mod))
                       (const ()) $ do
                guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
                endPass pass (mg_binds guts') (mg_rules guts')
                return guts'

        mod :: Module
    mod = ModGuts -> Module
    mg_module ModGuts
    guts

    doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
    doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
    doCorePass CoreToDo
    pass ModGuts
    guts = do
      logger    <- CoreM Logger
    forall (m :: * -> *). HasLogger m => m Logger
    getLogger
      hsc_env   <- getHscEnv
      dflags    <- getDynFlags
      us        <- getUniqueSupplyM
      p_fam_env <- getPackageFamInstEnv
      let platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
      let fam_envs = (PackageFamInstEnv
    p_fam_env, ModGuts -> PackageFamInstEnv
    mg_fam_inst_env ModGuts
    guts)
      let updateBinds  CoreProgram -> CoreProgram
    f = ModGuts -> CoreM ModGuts
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
    forall a b. (a -> b) -> a -> b
    $ ModGuts
    guts { mg_binds = f (mg_binds guts) }
      let updateBindsM CoreProgram -> CoreM CoreProgram
    f = CoreProgram -> CoreM CoreProgram
    f (ModGuts -> CoreProgram
    mg_binds ModGuts
    guts) CoreM CoreProgram
    -> (CoreProgram -> CoreM ModGuts) -> CoreM ModGuts
    forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \CoreProgram
    b' -> ModGuts -> CoreM ModGuts
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
    forall a b. (a -> b) -> a -> b
    $ ModGuts
    guts { mg_binds = b' }
      -- Important to force this now as name_ppr_ctx lives through an entire phase in
      -- the optimiser and if it's not forced then the entire previous `ModGuts` will
      -- be retained until the end of the phase. (See #24328 for more analysis)
      let !rdr_env = ModGuts -> GlobalRdrEnv
    mg_rdr_env ModGuts
    guts
      let name_ppr_ctx =
            PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
    forall info.
    Outputable info =>
    PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
    mkNamePprCtx
              (DynFlags -> PromotionTickContext
    initPromotionTickContext DynFlags
    dflags)
              (HscEnv -> UnitEnv
    hsc_unit_env HscEnv
    hsc_env)
              GlobalRdrEnv
    rdr_env

      case pass of
        CoreDoSimplify SimplifyOpts
    opts       -> {-# SCC "Simplify" #-}
                                     IO (SimplCount, ModGuts) -> CoreM ModGuts
    forall a. IO (SimplCount, a) -> CoreM a
    liftIOWithCount (IO (SimplCount, ModGuts) -> CoreM ModGuts)
    -> IO (SimplCount, ModGuts) -> CoreM ModGuts
    forall a b. (a -> b) -> a -> b
    $ Logger
    -> UnitEnv
    -> NamePprCtx
    -> SimplifyOpts
    -> ModGuts
    -> IO (SimplCount, ModGuts)
    simplifyPgm Logger
    logger (HscEnv -> UnitEnv
    hsc_unit_env HscEnv
    hsc_env) NamePprCtx
    name_ppr_ctx SimplifyOpts
    opts ModGuts
    guts

        CoreToDo
    CoreCSE                   -> {-# SCC "CommonSubExpr" #-}
                                     (CoreProgram -> CoreProgram) -> CoreM ModGuts
    updateBinds CoreProgram -> CoreProgram
    cseProgram

        CoreToDo
    CoreLiberateCase          -> {-# SCC "LiberateCase" #-}
                                     (CoreProgram -> CoreProgram) -> CoreM ModGuts
    updateBinds (LibCaseOpts -> CoreProgram -> CoreProgram
    liberateCase (DynFlags -> LibCaseOpts
    initLiberateCaseOpts DynFlags
    dflags))

        CoreToDo
    CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}
                                     (CoreProgram -> CoreProgram) -> CoreM ModGuts
    updateBinds (Platform -> CoreProgram -> CoreProgram
    floatInwards Platform
    platform)

        CoreDoFloatOutwards FloatOutSwitches
    f     -> {-# SCC "FloatOutwards" #-}
                                     (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
    updateBindsM (IO CoreProgram -> CoreM CoreProgram
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO CoreProgram -> CoreM CoreProgram)
    -> (CoreProgram -> IO CoreProgram)
    -> CoreProgram
    -> CoreM CoreProgram
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Logger
    -> FloatOutSwitches -> UniqSupply -> CoreProgram -> IO CoreProgram
    floatOutwards Logger
    logger FloatOutSwitches
    f UniqSupply
    us)

        CoreToDo
    CoreDoStaticArgs          -> {-# SCC "StaticArgs" #-}
                                     (CoreProgram -> CoreProgram) -> CoreM ModGuts
    updateBinds (UniqSupply -> CoreProgram -> CoreProgram
    doStaticArgs UniqSupply
    us)

        CoreToDo
    CoreDoCallArity           -> {-# SCC "CallArity" #-}
                                     (CoreProgram -> CoreProgram) -> CoreM ModGuts
    updateBinds CoreProgram -> CoreProgram
    callArityAnalProgram

        CoreToDo
    CoreDoExitify             -> {-# SCC "Exitify" #-}
                                     (CoreProgram -> CoreProgram) -> CoreM ModGuts
    updateBinds CoreProgram -> CoreProgram
    exitifyProgram

        CoreDoDemand Bool
    before_ww    -> {-# SCC "DmdAnal" #-}
                                     (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
    updateBindsM (IO CoreProgram -> CoreM CoreProgram
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO CoreProgram -> CoreM CoreProgram)
    -> (CoreProgram -> IO CoreProgram)
    -> CoreProgram
    -> CoreM CoreProgram
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Logger
    -> Bool
    -> DynFlags
    -> (PackageFamInstEnv, PackageFamInstEnv)
    -> [CoreRule]
    -> CoreProgram
    -> IO CoreProgram
    dmdAnal Logger
    logger Bool
    before_ww DynFlags
    dflags (PackageFamInstEnv, PackageFamInstEnv)
    fam_envs (ModGuts -> [CoreRule]
    mg_rules ModGuts
    guts))

        CoreToDo
    CoreDoCpr                 -> {-# SCC "CprAnal" #-}
                                     (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
    updateBindsM (IO CoreProgram -> CoreM CoreProgram
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO CoreProgram -> CoreM CoreProgram)
    -> (CoreProgram -> IO CoreProgram)
    -> CoreProgram
    -> CoreM CoreProgram
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Logger
    -> (PackageFamInstEnv, PackageFamInstEnv)
    -> CoreProgram
    -> IO CoreProgram
    cprAnalProgram Logger
    logger (PackageFamInstEnv, PackageFamInstEnv)
    fam_envs)

        CoreToDo
    CoreDoWorkerWrapper       -> {-# SCC "WorkWrap" #-}
                                     (CoreProgram -> CoreProgram) -> CoreM ModGuts
    updateBinds (WwOpts -> UniqSupply -> CoreProgram -> CoreProgram
    wwTopBinds
                                                   (Module
    -> DynFlags -> (PackageFamInstEnv, PackageFamInstEnv) -> WwOpts
    initWorkWrapOpts (ModGuts -> Module
    mg_module ModGuts
    guts) DynFlags
    dflags (PackageFamInstEnv, PackageFamInstEnv)
    fam_envs)
                                                   UniqSupply
    us)

        CoreToDo
    CoreDoSpecialising        -> {-# SCC "Specialise" #-}
                                     ModGuts -> CoreM ModGuts
    specProgram ModGuts
    guts

        CoreToDo
    CoreDoSpecConstr          -> {-# SCC "SpecConstr" #-}
                                     ModGuts -> CoreM ModGuts
    specConstrProgram ModGuts
    guts

        CoreToDo
    CoreAddCallerCcs          -> {-# SCC "AddCallerCcs" #-}
                                     ModGuts -> CoreM ModGuts
    addCallerCostCentres ModGuts
    guts

        CoreToDo
    CoreAddLateCcs            -> {-# SCC "AddLateCcs" #-}
                                     ModGuts -> CoreM ModGuts
    topLevelBindsCCMG ModGuts
    guts

        CoreToDo
    CoreDoPrintCore           -> {-# SCC "PrintCore" #-}
                                     IO ModGuts -> CoreM ModGuts
    forall a. IO a -> CoreM a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO ModGuts -> CoreM ModGuts) -> IO ModGuts -> CoreM ModGuts
    forall a b. (a -> b) -> a -> b
    $ Logger -> CoreProgram -> IO ()
    printCore Logger
    logger (ModGuts -> CoreProgram
    mg_binds ModGuts
    guts) IO () -> IO ModGuts -> IO ModGuts
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> ModGuts -> IO ModGuts
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ModGuts
    guts

        CoreDoRuleCheck CompilerPhase
    phase String
    pat -> {-# SCC "RuleCheck" #-}
                                     CompilerPhase -> String -> ModGuts -> CoreM ModGuts
    ruleCheckPass CompilerPhase
    phase String
    pat ModGuts
    guts
        CoreToDo
    CoreDoNothing             -> ModGuts -> CoreM ModGuts
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ModGuts
    guts
        CoreDoPasses [CoreToDo]
    passes       -> [CoreToDo] -> ModGuts -> CoreM ModGuts
    runCorePasses [CoreToDo]
    passes ModGuts
    guts

        CoreDoPluginPass String
    _ ModGuts -> CoreM ModGuts
    p      -> {-# SCC "Plugin" #-} ModGuts -> CoreM ModGuts
    p ModGuts
    guts

        CoreToDo
    CoreDesugar               -> String -> SDoc -> CoreM ModGuts
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (CoreToDo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)
        CoreToDo
    CoreDesugarOpt            -> String -> SDoc -> CoreM ModGuts
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (CoreToDo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)
        CoreToDo
    CoreTidy                  -> String -> SDoc -> CoreM ModGuts
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (CoreToDo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)
        CoreToDo
    CorePrep                  -> String -> SDoc -> CoreM ModGuts
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (CoreToDo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Core pass combinators}
    *                                                                      *
    ************************************************************************
    -}

    printCore :: Logger -> CoreProgram -> IO ()
    printCore :: Logger -> CoreProgram -> IO ()
    printCore Logger
    logger CoreProgram
    binds
        = Logger -> String -> SDoc -> IO ()
    Logger.logDumpMsg Logger
    logger String
    "Print Core" (CoreProgram -> SDoc
    forall b. OutputableBndr b => [Bind b] -> SDoc
    pprCoreBindings CoreProgram
    binds)

    ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
    ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
    ruleCheckPass CompilerPhase
    current_phase String
    pat ModGuts
    guts = do
        dflags <- CoreM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        logger <- getLogger
        withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
                    (const ()) $ do
            rule_env <- initRuleEnv guts
            let rule_fn CoreBndr
    fn = RuleEnv -> CoreBndr -> [CoreRule]
    getRules RuleEnv
    rule_env CoreBndr
    fn
                ropts = DynFlags -> RuleOpts
    initRuleOpts DynFlags
    dflags
            liftIO $ logDumpMsg logger "Rule check"
                         (ruleCheckProgram ropts current_phase pat
                            rule_fn (mg_binds guts))
            return guts

    dmdAnal :: Logger -> Bool -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
    dmdAnal :: Logger
    -> Bool
    -> DynFlags
    -> (PackageFamInstEnv, PackageFamInstEnv)
    -> [CoreRule]
    -> CoreProgram
    -> IO CoreProgram
    dmdAnal Logger
    logger Bool
    before_ww DynFlags
    dflags (PackageFamInstEnv, PackageFamInstEnv)
    fam_envs [CoreRule]
    rules CoreProgram
    binds = do
      let !opts :: DmdAnalOpts
    opts = DmdAnalOpts
                   { dmd_strict_dicts :: Bool
    dmd_strict_dicts    = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DictsStrict DynFlags
    dflags
                   , dmd_do_boxity :: Bool
    dmd_do_boxity       = Bool
    before_ww -- only run Boxity Analysis immediately preceding WW
                   , dmd_unbox_width :: PhaseNum
    dmd_unbox_width     = DynFlags -> PhaseNum
    dmdUnboxWidth DynFlags
    dflags
                   , dmd_max_worker_args :: PhaseNum
    dmd_max_worker_args = DynFlags -> PhaseNum
    maxWorkerArgs DynFlags
    dflags
                   }
          binds_plus_dmds :: CoreProgram
    binds_plus_dmds = DmdAnalOpts
    -> (PackageFamInstEnv, PackageFamInstEnv)
    -> [CoreRule]
    -> CoreProgram
    -> CoreProgram
    dmdAnalProgram DmdAnalOpts
    opts (PackageFamInstEnv, PackageFamInstEnv)
    fam_envs [CoreRule]
    rules CoreProgram
    binds
      Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    Logger.putDumpFileMaybe Logger
    logger DumpFlag
    Opt_D_dump_dmd_signatures String
    "Demand signatures" DumpFormat
    FormatText (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $
        Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
    dumpIdInfoOfProgram (DynFlags -> Bool
    hasPprDebug DynFlags
    dflags) (DmdSig -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (DmdSig -> SDoc) -> (IdInfo -> DmdSig) -> IdInfo -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DmdSig -> DmdSig
    zapDmdEnvSig (DmdSig -> DmdSig) -> (IdInfo -> DmdSig) -> IdInfo -> DmdSig
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IdInfo -> DmdSig
    dmdSigInfo) CoreProgram
    binds_plus_dmds
      -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
      CoreProgram -> ()
    seqBinds CoreProgram
    binds_plus_dmds () -> IO CoreProgram -> IO CoreProgram
    forall a b. a -> b -> b
    `seq` CoreProgram -> IO CoreProgram
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CoreProgram
    binds_plus_dmds