    {-
    (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

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Driver.Session
    import GHC.Driver.Ppr
    import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
    import GHC.Driver.Env
    import GHC.Platform.Ways  ( hasWay, Way(WayProf) )

    import GHC.Core
    import GHC.Core.Opt.CSE  ( cseProgram )
    import GHC.Core.Rules   ( mkRuleBase, unionRuleBase,
                              extendRuleBaseList, ruleCheckProgram, addRuleInfo,
                              getRules, initRuleOpts )
    import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )
    import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
    import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )
    import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram )
    import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,
                              lintAnnots )
    import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplRules )
    import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )
    import GHC.Core.Opt.Simplify.Env
    import GHC.Core.Opt.Simplify.Monad
    import GHC.Core.Opt.Monad
    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.Seq (seqBinds)
    import GHC.Core.FamInstEnv

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

    import GHC.Unit.External
    import GHC.Unit.Module.Env
    import GHC.Unit.Module.ModGuts
    import GHC.Unit.Module.Deps

    import GHC.Runtime.Context

    import GHC.Types.SrcLoc
    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.Basic
    import GHC.Types.Demand ( zapDmdEnvSig )
    import GHC.Types.Var.Set
    import GHC.Types.Var.Env
    import GHC.Types.Tickish
    import GHC.Types.Unique.Supply ( UniqSupply )
    import GHC.Types.Unique.FM
    import GHC.Types.Name.Ppr

    import Control.Monad
    import qualified GHC.LanguageExtensions as LangExt
    {-
    ************************************************************************
    *                                                                      *
    \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_deps :: ModGuts -> Dependencies
    mg_deps    = Dependencies
    deps
                                    , mg_rdr_env :: ModGuts -> GlobalRdrEnv
    mg_rdr_env = GlobalRdrEnv
    rdr_env })
      = do { let builtin_passes :: [CoreToDo]
    builtin_passes = Logger -> DynFlags -> [CoreToDo]
    getCoreToDo Logger
    logger DynFlags
    dflags
                 orph_mods :: ModuleSet
    orph_mods = [Module] -> ModuleSet
    mkModuleSet (Module
    mod forall a. a -> [a] -> [a]
    : Dependencies -> [Module]
    dep_orphs Dependencies
    deps)
                 uniq_mask :: Char
    uniq_mask = Char
    's'
           ;
           ; (ModGuts
    guts2, SimplCount
    stats) <- forall a.
    HscEnv
    -> RuleBase
    -> Char
    -> Module
    -> ModuleSet
    -> PrintUnqualified
    -> SrcSpan
    -> CoreM a
    -> IO (a, SimplCount)
    runCoreM HscEnv
    hsc_env RuleBase
    hpt_rule_base Char
    uniq_mask Module
    mod
                                        ModuleSet
    orph_mods PrintUnqualified
    print_unqual SrcSpan
    loc forall a b. (a -> b) -> a -> b
    $
                               do { HscEnv
    hsc_env' <- CoreM HscEnv
    getHscEnv
                                  ; [CoreToDo]
    all_passes <- forall (m :: * -> *) a.
    Monad m =>
    HscEnv -> PluginOperation m a -> a -> m a
    withPlugins HscEnv
    hsc_env'
                                                    Plugin -> CorePlugin
    installCoreToDos
                                                    [CoreToDo]
    builtin_passes
                                  ; [CoreToDo] -> ModGuts -> CoreM ModGuts
    runCorePasses [CoreToDo]
    all_passes ModGuts
    guts }

           ; Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    Logger.dumpIfSet_dyn Logger
    logger DynFlags
    dflags DumpFlag
    Opt_D_dump_simpl_stats
                 String
    "Grand total simplifier statistics"
                 DumpFormat
    FormatText
                 (SimplCount -> SDoc
    pprSimplCount SimplCount
    stats)

           ; forall (m :: * -> *) a. Monad m => a -> m a
    return ModGuts
    guts2 }
      where
        logger :: Logger
    logger         = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env
        dflags :: DynFlags
    dflags         = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
        home_pkg_rules :: [CoreRule]
    home_pkg_rules = HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
    hptRules HscEnv
    hsc_env (Dependencies -> [ModuleNameWithIsBoot]
    dep_mods Dependencies
    deps)
        hpt_rule_base :: RuleBase
    hpt_rule_base  = [CoreRule] -> RuleBase
    mkRuleBase [CoreRule]
    home_pkg_rules
        print_unqual :: PrintUnqualified
    print_unqual   = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
    mkPrintUnqualified (HscEnv -> UnitEnv
    hsc_unit_env HscEnv
    hsc_env) GlobalRdrEnv
    rdr_env
        -- 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 :: Logger -> DynFlags -> [CoreToDo]
    getCoreToDo :: Logger -> DynFlags -> [CoreToDo]
    getCoreToDo Logger
    logger DynFlags
    dflags
      = [CoreToDo] -> [CoreToDo]
    flatten_todos [CoreToDo]
    core_todo
      where
        opt_level :: Int
    opt_level     = DynFlags -> Int
    optLevel           DynFlags
    dflags
        phases :: Int
    phases        = DynFlags -> Int
    simplPhases        DynFlags
    dflags
        max_iter :: Int
    max_iter      = DynFlags -> Int
    maxSimplIterations DynFlags
    dflags
        rule_check :: Maybe String
    rule_check    = DynFlags -> Maybe String
    ruleCheck          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
        eta_expand_on :: Bool
    eta_expand_on = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DoLambdaEtaExpansion         DynFlags
    dflags
        pre_inline_on :: Bool
    pre_inline_on = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_SimplPreInlining             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

        maybe_rule_check :: CompilerPhase -> CoreToDo
    maybe_rule_check CompilerPhase
    phase = 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 Int
    phase)
          | Int
    phase forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` DynFlags -> [Int]
    strictnessBefore DynFlags
    dflags = CoreToDo
    CoreDoDemand
        maybe_strictness_before CompilerPhase
    _
          = CoreToDo
    CoreDoNothing

        base_mode :: SimplMode
    base_mode = SimplMode { sm_phase :: CompilerPhase
    sm_phase        = forall a. String -> a
    panic String
    "base_mode"
                              , sm_names :: [String]
    sm_names        = []
                              , sm_dflags :: DynFlags
    sm_dflags       = DynFlags
    dflags
                              , sm_logger :: Logger
    sm_logger       = Logger
    logger
                              , sm_uf_opts :: UnfoldingOpts
    sm_uf_opts      = DynFlags -> UnfoldingOpts
    unfoldingOpts DynFlags
    dflags
                              , sm_rules :: Bool
    sm_rules        = Bool
    rules_on
                              , sm_eta_expand :: Bool
    sm_eta_expand   = Bool
    eta_expand_on
                              , sm_cast_swizzle :: Bool
    sm_cast_swizzle = Bool
    True
                              , sm_inline :: Bool
    sm_inline       = Bool
    True
                              , sm_case_case :: Bool
    sm_case_case    = Bool
    True
                              , sm_pre_inline :: Bool
    sm_pre_inline   = Bool
    pre_inline_on
                              }

        simpl_phase :: CompilerPhase -> String -> Int -> CoreToDo
    simpl_phase CompilerPhase
    phase String
    name Int
    iter
          = [CoreToDo] -> CoreToDo
    CoreDoPasses
          forall a b. (a -> b) -> a -> b
    $   [ CompilerPhase -> CoreToDo
    maybe_strictness_before CompilerPhase
    phase
              , Int -> SimplMode -> CoreToDo
    CoreDoSimplify Int
    iter
                    (SimplMode
    base_mode { sm_phase :: CompilerPhase
    sm_phase = CompilerPhase
    phase
                               , sm_names :: [String]
    sm_names = [String
    name] })

              , 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 -> Int -> CoreToDo
    simpl_phase CompilerPhase
    FinalPhase String
    name Int
    max_iter

        -- initial simplify: mk specialiser happy: minimum effort please
        simpl_gently :: CoreToDo
    simpl_gently = Int -> SimplMode -> CoreToDo
    CoreDoSimplify Int
    max_iter
                           (SimplMode
    base_mode { sm_phase :: CompilerPhase
    sm_phase = CompilerPhase
    InitialPhase
                                      , sm_names :: [String]
    sm_names = [String
    "Gentle"]
                                      , sm_rules :: Bool
    sm_rules = Bool
    rules_on   -- Note [RULEs enabled in InitialPhase]
                                      , sm_inline :: Bool
    sm_inline = Bool
    True
                                                  -- See Note [Inline in InitialPhase]
                                      , sm_case_case :: Bool
    sm_case_case = Bool
    False })
                              -- Don't do case-of-case transformations.
                              -- This makes full laziness work better

        dmd_cpr_ww :: [CoreToDo]
    dmd_cpr_ww = if Bool
    ww_on then [CoreToDo
    CoreDoDemand,CoreToDo
    CoreDoCpr,CoreToDo
    CoreDoWorkerWrapper]
                              else [CoreToDo
    CoreDoDemand,CoreToDo
    CoreDoCpr]

        demand_analyser :: CoreToDo
    demand_analyser = ([CoreToDo] -> CoreToDo
    CoreDoPasses (
                               [CoreToDo]
    dmd_cpr_ww 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 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 Int
    floatOutLambdas   = forall a. a -> Maybe a
    Just Int
    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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
    null forall a b. (a -> b) -> a -> b
    $ DynFlags -> [CallerCcFilter]
    callerCcFilters DynFlags
    dflags)) CoreToDo
    CoreAddCallerCcs

        core_todo :: [CoreToDo]
    core_todo =
         if Int
    opt_level forall a. Eq a => a -> a -> Bool
    == Int
    0 then
           [ CoreToDo
    static_ptrs_float_outwards,
             Int -> SimplMode -> CoreToDo
    CoreDoSimplify Int
    max_iter
                 (SimplMode
    base_mode { sm_phase :: CompilerPhase
    sm_phase = CompilerPhase
    FinalPhase
                            , sm_names :: [String]
    sm_names = [String
    "Non-opt simplification"] })
           , CoreToDo
    add_caller_ccs
           ]

         else {- opt_level >= 1 -} [

        -- 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
            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 Int
    floatOutLambdas   = forall a. a -> Maybe a
    Just Int
    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 simplier phases 2,1,0 to allow rewrite rules to fire
            [CoreToDo] -> CoreToDo
    CoreDoPasses [ CompilerPhase -> String -> Int -> CoreToDo
    simpl_phase (Int -> CompilerPhase
    Phase Int
    phase) String
    "main" Int
    max_iter
                         | Int
    phase <- [Int
    phases, Int
    phasesforall a. Num a => a -> a -> a
    -Int
    1 .. Int
    1] ],
            CompilerPhase -> String -> Int -> CoreToDo
    simpl_phase (Int -> CompilerPhase
    Phase Int
    0) String
    "main" (forall a. Ord a => a -> a -> a
    max Int
    max_iter Int
    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 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 forall a b. (a -> b) -> a -> b
    $
               FloatOutSwitches -> CoreToDo
    CoreDoFloatOutwards FloatOutSwitches {
                                     floatOutLambdas :: Maybe Int
    floatOutLambdas     = DynFlags -> Maybe Int
    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 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 GHC.Core.Opt.SpecConstr

            Bool -> CoreToDo -> CoreToDo
    runWhen Bool
    spec_constr 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 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) 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 forall a b. (a -> b) -> a -> b
    $ [CoreToDo] -> CoreToDo
    CoreDoPasses (
                [CoreToDo]
    dmd_cpr_ww 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) CoreToDo
    CoreDoDemand,

            CompilerPhase -> CoreToDo
    maybe_rule_check CompilerPhase
    FinalPhase,

            CoreToDo
    add_caller_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 forall a. [a] -> [a] -> [a]
    ++ [CoreToDo] -> [CoreToDo]
    flatten_todos [CoreToDo]
    rest
        flatten_todos (CoreToDo
    todo : [CoreToDo]
    rest) = CoreToDo
    todo forall a. a -> [a] -> [a]
    : [CoreToDo] -> [CoreToDo]
    flatten_todos [CoreToDo]
    rest

    {- 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 carefullly 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
      = 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 = 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
          DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
          Logger
    logger <- forall (m :: * -> *). HasLogger m => m Logger
    getLogger
          forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger DynFlags
    dflags (forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    brackets (forall a. Outputable a => a -> SDoc
    ppr Module
    mod))
                       (forall a b. a -> b -> a
    const ()) forall a b. (a -> b) -> a -> b
    $ do
                ModGuts
    guts' <- SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
    lintAnnots (forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass) (CoreToDo -> ModGuts -> CoreM ModGuts
    doCorePass CoreToDo
    pass) ModGuts
    guts
                CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
    endPass CoreToDo
    pass (ModGuts -> CoreProgram
    mg_binds ModGuts
    guts') (ModGuts -> [CoreRule]
    mg_rules ModGuts
    guts')
                forall (m :: * -> *) a. Monad m => a -> m a
    return ModGuts
    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
    logger <- forall (m :: * -> *). HasLogger m => m Logger
    getLogger
      case CoreToDo
    pass of
        CoreDoSimplify {}         -> {-# SCC "Simplify" #-}
                                     CoreToDo -> ModGuts -> CoreM ModGuts
    simplifyPgm CoreToDo
    pass ModGuts
    guts

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

        CoreToDo
    CoreLiberateCase          -> {-# SCC "LiberateCase" #-}
                                     (DynFlags -> CoreProgram -> CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassD DynFlags -> CoreProgram -> CoreProgram
    liberateCase ModGuts
    guts

        CoreToDo
    CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}
                                     ModGuts -> CoreM ModGuts
    floatInwards ModGuts
    guts

        CoreDoFloatOutwards FloatOutSwitches
    f     -> {-# SCC "FloatOutwards" #-}
                                     (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDUM (Logger
    -> FloatOutSwitches
    -> DynFlags
    -> UniqSupply
    -> CoreProgram
    -> IO CoreProgram
    floatOutwards Logger
    logger FloatOutSwitches
    f) ModGuts
    guts

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

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

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

        CoreToDo
    CoreDoDemand              -> {-# SCC "DmdAnal" #-}
                                     (DynFlags
     -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDFRM (Logger
    -> DynFlags
    -> FamInstEnvs
    -> [CoreRule]
    -> CoreProgram
    -> IO CoreProgram
    dmdAnal Logger
    logger) ModGuts
    guts

        CoreToDo
    CoreDoCpr                 -> {-# SCC "CprAnal" #-}
                                     (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDFM (Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
    cprAnalProgram Logger
    logger) ModGuts
    guts

        CoreToDo
    CoreDoWorkerWrapper       -> {-# SCC "WorkWrap" #-}
                                     (DynFlags
     -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDFU DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
    wwTopBinds ModGuts
    guts

        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
    CoreDoPrintCore           -> forall a.
    (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
    observe (Logger -> DynFlags -> CoreProgram -> IO ()
    printCore Logger
    logger) ModGuts
    guts

        CoreDoRuleCheck CompilerPhase
    phase String
    pat -> CompilerPhase -> String -> ModGuts -> CoreM ModGuts
    ruleCheckPass CompilerPhase
    phase String
    pat ModGuts
    guts
        CoreToDo
    CoreDoNothing             -> 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               -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)
        CoreToDo
    CoreDesugarOpt            -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)
        CoreToDo
    CoreTidy                  -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)
        CoreToDo
    CorePrep                  -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)
        CoreToDo
    CoreOccurAnal             -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "doCorePass" (forall a. Outputable a => a -> SDoc
    ppr CoreToDo
    pass)

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

    printCore :: Logger -> DynFlags -> CoreProgram -> IO ()
    printCore :: Logger -> DynFlags -> CoreProgram -> IO ()
    printCore Logger
    logger DynFlags
    dflags CoreProgram
    binds
        = Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
    Logger.dumpIfSet Logger
    logger DynFlags
    dflags Bool
    True String
    "Print Core" (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
        DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        Logger
    logger <- forall (m :: * -> *). HasLogger m => m Logger
    getLogger
        forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger DynFlags
    dflags (String -> SDoc
    text String
    "RuleCheck"SDoc -> SDoc -> SDoc
    <+>SDoc -> SDoc
    brackets (forall a. Outputable a => a -> SDoc
    ppr forall a b. (a -> b) -> a -> b
    $ ModGuts -> Module
    mg_module ModGuts
    guts))
                    (forall a b. a -> b -> a
    const ()) forall a b. (a -> b) -> a -> b
    $ do
            RuleBase
    rb <- CoreM RuleBase
    getRuleBase
            ModuleSet
    vis_orphs <- CoreM ModuleSet
    getVisibleOrphanMods
            let rule_fn :: Id -> [CoreRule]
    rule_fn Id
    fn = RuleEnv -> Id -> [CoreRule]
    getRules (RuleBase -> ModuleSet -> RuleEnv
    RuleEnv RuleBase
    rb ModuleSet
    vis_orphs) Id
    fn
                              forall a. [a] -> [a] -> [a]
    ++ (ModGuts -> [CoreRule]
    mg_rules ModGuts
    guts)
            let ropts :: RuleOpts
    ropts = DynFlags -> RuleOpts
    initRuleOpts DynFlags
    dflags
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall a b. (a -> b) -> a -> b
    $ Logger -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    NoReason Severity
    Err.SevDump SrcSpan
    noSrcSpan
                         forall a b. (a -> b) -> a -> b
    $ PprStyle -> SDoc -> SDoc
    withPprStyle PprStyle
    defaultDumpStyle
                         (RuleOpts
    -> CompilerPhase
    -> String
    -> (Id -> [CoreRule])
    -> CoreProgram
    -> SDoc
    ruleCheckProgram RuleOpts
    ropts CompilerPhase
    current_phase String
    pat
                            Id -> [CoreRule]
    rule_fn (ModGuts -> CoreProgram
    mg_binds ModGuts
    guts))
            forall (m :: * -> *) a. Monad m => a -> m a
    return ModGuts
    guts

    doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
    doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDUM DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram
    do_pass = forall (m :: * -> *).
    Monad m =>
    (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
    doPassM forall a b. (a -> b) -> a -> b
    $ \CoreProgram
    binds -> do
        DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        UniqSupply
    us     <- forall (m :: * -> *). MonadUnique m => m UniqSupply
    getUniqueSupplyM
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall a b. (a -> b) -> a -> b
    $ DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram
    do_pass DynFlags
    dflags UniqSupply
    us CoreProgram
    binds

    doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
    doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDM DynFlags -> CoreProgram -> IO CoreProgram
    do_pass = (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDUM (\DynFlags
    dflags -> forall a b. a -> b -> a
    const (DynFlags -> CoreProgram -> IO CoreProgram
    do_pass DynFlags
    dflags))

    doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
    doPassD :: (DynFlags -> CoreProgram -> CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassD DynFlags -> CoreProgram -> CoreProgram
    do_pass = (DynFlags -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDM (\DynFlags
    dflags -> forall (m :: * -> *) a. Monad m => a -> m a
    return forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DynFlags -> CoreProgram -> CoreProgram
    do_pass DynFlags
    dflags)

    doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
    doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDU DynFlags -> UniqSupply -> CoreProgram -> CoreProgram
    do_pass = (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDUM (\DynFlags
    dflags UniqSupply
    us -> forall (m :: * -> *) a. Monad m => a -> m a
    return forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DynFlags -> UniqSupply -> CoreProgram -> CoreProgram
    do_pass DynFlags
    dflags UniqSupply
    us)

    doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
    doPassU :: (UniqSupply -> CoreProgram -> CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassU UniqSupply -> CoreProgram -> CoreProgram
    do_pass = (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDU (forall a b. a -> b -> a
    const UniqSupply -> CoreProgram -> CoreProgram
    do_pass)

    doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
    doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDFM DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
    do_pass ModGuts
    guts = do
        DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        PackageFamInstEnv
    p_fam_env <- CoreM PackageFamInstEnv
    getPackageFamInstEnv
        let fam_envs :: FamInstEnvs
    fam_envs = (PackageFamInstEnv
    p_fam_env, ModGuts -> PackageFamInstEnv
    mg_fam_inst_env ModGuts
    guts)
        forall (m :: * -> *).
    Monad m =>
    (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
    doPassM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
    do_pass DynFlags
    dflags FamInstEnvs
    fam_envs) ModGuts
    guts

    doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
    doPassDFRM :: (DynFlags
     -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDFRM DynFlags
    -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
    do_pass ModGuts
    guts = do
        DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        PackageFamInstEnv
    p_fam_env <- CoreM PackageFamInstEnv
    getPackageFamInstEnv
        let fam_envs :: FamInstEnvs
    fam_envs = (PackageFamInstEnv
    p_fam_env, ModGuts -> PackageFamInstEnv
    mg_fam_inst_env ModGuts
    guts)
        forall (m :: * -> *).
    Monad m =>
    (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
    doPassM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DynFlags
    -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
    do_pass DynFlags
    dflags FamInstEnvs
    fam_envs (ModGuts -> [CoreRule]
    mg_rules ModGuts
    guts)) ModGuts
    guts

    doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
    doPassDFU :: (DynFlags
     -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram)
    -> ModGuts -> CoreM ModGuts
    doPassDFU DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
    do_pass ModGuts
    guts = do
        DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        UniqSupply
    us     <- forall (m :: * -> *). MonadUnique m => m UniqSupply
    getUniqueSupplyM
        PackageFamInstEnv
    p_fam_env <- CoreM PackageFamInstEnv
    getPackageFamInstEnv
        let fam_envs :: FamInstEnvs
    fam_envs = (PackageFamInstEnv
    p_fam_env, ModGuts -> PackageFamInstEnv
    mg_fam_inst_env ModGuts
    guts)
        (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
    doPass (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
    do_pass DynFlags
    dflags FamInstEnvs
    fam_envs UniqSupply
    us) ModGuts
    guts

    -- Most passes return no stats and don't change rules: these combinators
    -- let us lift them to the full blown ModGuts+CoreM world
    doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
    doPassM :: forall (m :: * -> *).
    Monad m =>
    (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
    doPassM CoreProgram -> m CoreProgram
    bind_f ModGuts
    guts = do
        CoreProgram
    binds' <- CoreProgram -> m CoreProgram
    bind_f (ModGuts -> CoreProgram
    mg_binds ModGuts
    guts)
        forall (m :: * -> *) a. Monad m => a -> m a
    return (ModGuts
    guts { mg_binds :: CoreProgram
    mg_binds = CoreProgram
    binds' })

    doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
    doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
    doPass CoreProgram -> CoreProgram
    bind_f ModGuts
    guts = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ ModGuts
    guts { mg_binds :: CoreProgram
    mg_binds = CoreProgram -> CoreProgram
    bind_f (ModGuts -> CoreProgram
    mg_binds ModGuts
    guts) }

    -- Observer passes just peek; don't modify the bindings at all
    observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
    observe :: forall a.
    (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
    observe DynFlags -> CoreProgram -> IO a
    do_pass = forall (m :: * -> *).
    Monad m =>
    (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
    doPassM forall a b. (a -> b) -> a -> b
    $ \CoreProgram
    binds -> do
        DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        a
    _ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall a b. (a -> b) -> a -> b
    $ DynFlags -> CoreProgram -> IO a
    do_pass DynFlags
    dflags CoreProgram
    binds
        forall (m :: * -> *) a. Monad m => a -> m a
    return CoreProgram
    binds

    {-
    ************************************************************************
    *                                                                      *
            Gentle simplification
    *                                                                      *
    ************************************************************************
    -}

    simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do
                 -> CoreExpr
                 -> IO CoreExpr
    -- simplifyExpr is called by the driver to simplify an
    -- expression typed in at the interactive prompt
    simplifyExpr :: HscEnv -> CoreExpr -> IO CoreExpr
    simplifyExpr HscEnv
    hsc_env CoreExpr
    expr
      = forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger DynFlags
    dflags (String -> SDoc
    text String
    "Simplify [expr]") (forall a b. a -> b -> a
    const ()) forall a b. (a -> b) -> a -> b
    $
        do  { ExternalPackageState
    eps <- HscEnv -> IO ExternalPackageState
    hscEPS HscEnv
    hsc_env ;
            ; let rule_env :: RuleEnv
    rule_env  = RuleBase -> [Module] -> RuleEnv
    mkRuleEnv (ExternalPackageState -> RuleBase
    eps_rule_base ExternalPackageState
    eps) []
                  fi_env :: FamInstEnvs
    fi_env    = ( ExternalPackageState -> PackageFamInstEnv
    eps_fam_inst_env ExternalPackageState
    eps
                              , PackageFamInstEnv -> [FamInst] -> PackageFamInstEnv
    extendFamInstEnvList PackageFamInstEnv
    emptyFamInstEnv forall a b. (a -> b) -> a -> b
    $
                                forall a b. (a, b) -> b
    snd forall a b. (a -> b) -> a -> b
    $ InteractiveContext -> ([ClsInst], [FamInst])
    ic_instances forall a b. (a -> b) -> a -> b
    $ HscEnv -> InteractiveContext
    hsc_IC HscEnv
    hsc_env )
                  simpl_env :: SimplEnv
    simpl_env = Logger -> DynFlags -> SimplEnv
    simplEnvForGHCi Logger
    logger DynFlags
    dflags

            ; let sz :: Int
    sz = CoreExpr -> Int
    exprSize CoreExpr
    expr

            ; (CoreExpr
    expr', SimplCount
    counts) <- forall a.
    Logger
    -> DynFlags
    -> RuleEnv
    -> FamInstEnvs
    -> Int
    -> SimplM a
    -> IO (a, SimplCount)
    initSmpl Logger
    logger DynFlags
    dflags RuleEnv
    rule_env FamInstEnvs
    fi_env Int
    sz forall a b. (a -> b) -> a -> b
    $
                                 SimplEnv -> CoreExpr -> SimplM CoreExpr
    simplExprGently SimplEnv
    simpl_env CoreExpr
    expr

            ; Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
    Logger.dumpIfSet Logger
    logger DynFlags
    dflags (DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_dump_simpl_stats DynFlags
    dflags)
                      String
    "Simplifier statistics" (SimplCount -> SDoc
    pprSimplCount SimplCount
    counts)

            ; Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    Logger.dumpIfSet_dyn Logger
    logger DynFlags
    dflags DumpFlag
    Opt_D_dump_simpl String
    "Simplified expression"
                            DumpFormat
    FormatCore
                            (forall b. OutputableBndr b => Expr b -> SDoc
    pprCoreExpr CoreExpr
    expr')

            ; forall (m :: * -> *) a. Monad m => a -> m a
    return CoreExpr
    expr'
            }
      where
        dflags :: DynFlags
    dflags = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
        logger :: Logger
    logger = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env

    simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
    -- Simplifies an expression
    --      does occurrence analysis, then simplification
    --      and repeats (twice currently) because one pass
    --      alone leaves tons of crud.
    -- Used (a) for user expressions typed in at the interactive prompt
    --      (b) the LHS and RHS of a RULE
    --      (c) Template Haskell splices
    --
    -- The name 'Gently' suggests that the SimplMode is InitialPhase,
    -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
    -- enforce that; it just simplifies the expression twice

    -- It's important that simplExprGently does eta reduction; see
    -- Note [Simplifying the left-hand side of a RULE] above.  The
    -- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam)
    -- but only if -O is on.

    simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
    simplExprGently SimplEnv
    env CoreExpr
    expr = do
        CoreExpr
    expr1 <- SimplEnv -> CoreExpr -> SimplM CoreExpr
    simplExpr SimplEnv
    env (CoreExpr -> CoreExpr
    occurAnalyseExpr CoreExpr
    expr)
        SimplEnv -> CoreExpr -> SimplM CoreExpr
    simplExpr SimplEnv
    env (CoreExpr -> CoreExpr
    occurAnalyseExpr CoreExpr
    expr1)

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

    simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
    simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
    simplifyPgm CoreToDo
    pass ModGuts
    guts
      = do { HscEnv
    hsc_env <- CoreM HscEnv
    getHscEnv
           ; RuleBase
    rb <- CoreM RuleBase
    getRuleBase
           ; forall a. IO (SimplCount, a) -> CoreM a
    liftIOWithCount forall a b. (a -> b) -> a -> b
    $
             CoreToDo
    -> HscEnv -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts)
    simplifyPgmIO CoreToDo
    pass HscEnv
    hsc_env RuleBase
    rb ModGuts
    guts }

    simplifyPgmIO :: CoreToDo
                  -> HscEnv
                  -> RuleBase
                  -> ModGuts
                  -> IO (SimplCount, ModGuts)  -- New bindings

    simplifyPgmIO :: CoreToDo
    -> HscEnv -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts)
    simplifyPgmIO pass :: CoreToDo
    pass@(CoreDoSimplify Int
    max_iterations SimplMode
    mode)
                  HscEnv
    hsc_env RuleBase
    hpt_rule_base
                  guts :: ModGuts
    guts@(ModGuts { mg_module :: ModGuts -> Module
    mg_module = Module
    this_mod
                                , mg_rdr_env :: ModGuts -> GlobalRdrEnv
    mg_rdr_env = GlobalRdrEnv
    rdr_env
                                , mg_deps :: ModGuts -> Dependencies
    mg_deps = Dependencies
    deps
                                , mg_binds :: ModGuts -> CoreProgram
    mg_binds = CoreProgram
    binds, mg_rules :: ModGuts -> [CoreRule]
    mg_rules = [CoreRule]
    rules
                                , mg_fam_inst_env :: ModGuts -> PackageFamInstEnv
    mg_fam_inst_env = PackageFamInstEnv
    fam_inst_env })
      = do { (String
    termination_msg, Int
    it_count, SimplCount
    counts_out, ModGuts
    guts')
               <- Int
    -> [SimplCount]
    -> CoreProgram
    -> [CoreRule]
    -> IO (String, Int, SimplCount, ModGuts)
    do_iteration Int
    1 [] CoreProgram
    binds [CoreRule]
    rules

            ; Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
    Logger.dumpIfSet Logger
    logger DynFlags
    dflags (DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_verbose_core2core DynFlags
    dflags Bool -> Bool -> Bool
    &&
                                    DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_dump_simpl_stats  DynFlags
    dflags)
                      String
    "Simplifier statistics for following pass"
                      ([SDoc] -> SDoc
    vcat [String -> SDoc
    text String
    termination_msg SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "after" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr Int
    it_count
                                                  SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "iterations",
                             SDoc
    blankLine,
                             SimplCount -> SDoc
    pprSimplCount SimplCount
    counts_out])

            ; forall (m :: * -> *) a. Monad m => a -> m a
    return (SimplCount
    counts_out, ModGuts
    guts')
        }
      where
        dflags :: DynFlags
    dflags       = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
        logger :: Logger
    logger       = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env
        print_unqual :: PrintUnqualified
    print_unqual = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
    mkPrintUnqualified (HscEnv -> UnitEnv
    hsc_unit_env HscEnv
    hsc_env) GlobalRdrEnv
    rdr_env
        simpl_env :: SimplEnv
    simpl_env    = SimplMode -> SimplEnv
    mkSimplEnv SimplMode
    mode
        active_rule :: Activation -> Bool
    active_rule  = SimplMode -> Activation -> Bool
    activeRule SimplMode
    mode
        active_unf :: Id -> Bool
    active_unf   = SimplMode -> Id -> Bool
    activeUnfolding SimplMode
    mode

        do_iteration :: Int --UniqSupply
                    --  -> Int          -- Counts iterations
                     -> [SimplCount] -- Counts from earlier iterations, reversed
                     -> CoreProgram  -- Bindings in
                     -> [CoreRule]   -- and orphan rules
                     -> IO (String, Int, SimplCount, ModGuts)

        do_iteration :: Int
    -> [SimplCount]
    -> CoreProgram
    -> [CoreRule]
    -> IO (String, Int, SimplCount, ModGuts)
    do_iteration Int
    iteration_no [SimplCount]
    counts_so_far CoreProgram
    binds [CoreRule]
    rules
            -- iteration_no is the number of the iteration we are
            -- about to begin, with '1' for the first
          | Int
    iteration_no forall a. Ord a => a -> a -> Bool
    > Int
    max_iterations   -- Stop if we've run out of iterations
          = WARN( debugIsOn && (max_iterations > 2)
                , hang (text "Simplifier bailing out after" <+> int max_iterations
                        <+> text "iterations"
                        <+> (brackets $ hsep $ punctuate comma $
                             map (int . simplCountN) (reverse counts_so_far)))
                     2 (text "Size =" <+> ppr (coreBindsStats binds)))

                    -- Subtract 1 from iteration_no to get the
                    -- number of iterations we actually completed
            forall (m :: * -> *) a. Monad m => a -> m a
    return ( String
    "Simplifier baled out", Int
    iteration_no forall a. Num a => a -> a -> a
    - Int
    1
                   , [SimplCount] -> SimplCount
    totalise [SimplCount]
    counts_so_far
                   , ModGuts
    guts { mg_binds :: CoreProgram
    mg_binds = CoreProgram
    binds, mg_rules :: [CoreRule]
    mg_rules = [CoreRule]
    rules } )

          -- Try and force thunks off the binds; significantly reduces
          -- space usage, especially with -O.  JRS, 000620.
          | let sz :: Int
    sz = CoreProgram -> Int
    coreBindsSize CoreProgram
    binds
          , () <- Int
    sz seq :: forall a b. a -> b -> b
    `seq` ()     -- Force it
          = do {
                    -- Occurrence analysis
               let { tagged_binds :: CoreProgram
    tagged_binds = {-# SCC "OccAnal" #-}
                         Module
    -> (Id -> Bool)
    -> (Activation -> Bool)
    -> [CoreRule]
    -> CoreProgram
    -> CoreProgram
    occurAnalysePgm Module
    this_mod Id -> Bool
    active_unf Activation -> Bool
    active_rule [CoreRule]
    rules
                                         CoreProgram
    binds
                   } ;
               Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    Logger.dumpIfSet_dyn Logger
    logger DynFlags
    dflags DumpFlag
    Opt_D_dump_occur_anal String
    "Occurrence analysis"
                         DumpFormat
    FormatCore
                         (forall b. OutputableBndr b => [Bind b] -> SDoc
    pprCoreBindings CoreProgram
    tagged_binds);

                    -- Get any new rules, and extend the rule base
                    -- See Note [Overall plumbing for rules] in GHC.Core.Rules
                    -- We need to do this regularly, because simplification can
                    -- poke on IdInfo thunks, which in turn brings in new rules
                    -- behind the scenes.  Otherwise there's a danger we'll simply
                    -- miss the rules for Ids hidden inside imported inlinings
               ExternalPackageState
    eps <- HscEnv -> IO ExternalPackageState
    hscEPS HscEnv
    hsc_env ;
               let  { rule_base1 :: RuleBase
    rule_base1 = RuleBase -> RuleBase -> RuleBase
    unionRuleBase RuleBase
    hpt_rule_base (ExternalPackageState -> RuleBase
    eps_rule_base ExternalPackageState
    eps)
                    ; rule_base2 :: RuleBase
    rule_base2 = RuleBase -> [CoreRule] -> RuleBase
    extendRuleBaseList RuleBase
    rule_base1 [CoreRule]
    rules
                    ; fam_envs :: FamInstEnvs
    fam_envs = (ExternalPackageState -> PackageFamInstEnv
    eps_fam_inst_env ExternalPackageState
    eps, PackageFamInstEnv
    fam_inst_env)
                    ; vis_orphs :: [Module]
    vis_orphs = Module
    this_mod forall a. a -> [a] -> [a]
    : Dependencies -> [Module]
    dep_orphs Dependencies
    deps } ;

                    -- Simplify the program
               ((CoreProgram
    binds1, [CoreRule]
    rules1), SimplCount
    counts1) <-
                 forall a.
    Logger
    -> DynFlags
    -> RuleEnv
    -> FamInstEnvs
    -> Int
    -> SimplM a
    -> IO (a, SimplCount)
    initSmpl Logger
    logger DynFlags
    dflags (RuleBase -> [Module] -> RuleEnv
    mkRuleEnv RuleBase
    rule_base2 [Module]
    vis_orphs) FamInstEnvs
    fam_envs Int
    sz forall a b. (a -> b) -> a -> b
    $
                   do { (SimplFloats
    floats, SimplEnv
    env1) <- {-# SCC "SimplTopBinds" #-}
                                          SimplEnv -> CoreProgram -> SimplM (SimplFloats, SimplEnv)
    simplTopBinds SimplEnv
    simpl_env CoreProgram
    tagged_binds

                          -- Apply the substitution to rules defined in this module
                          -- for imported Ids.  Eg  RULE map my_f = blah
                          -- If we have a substitution my_f :-> other_f, we'd better
                          -- apply it to the rule to, or it'll never match
                      ; [CoreRule]
    rules1 <- SimplEnv
    -> Maybe Id -> [CoreRule] -> MaybeJoinCont -> SimplM [CoreRule]
    simplRules SimplEnv
    env1 forall a. Maybe a
    Nothing [CoreRule]
    rules forall a. Maybe a
    Nothing

                      ; forall (m :: * -> *) a. Monad m => a -> m a
    return (SimplFloats -> CoreProgram
    getTopFloatBinds SimplFloats
    floats, [CoreRule]
    rules1) } ;

                    -- Stop if nothing happened; don't dump output
                    -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad
               if SimplCount -> Bool
    isZeroSimplCount SimplCount
    counts1 then
                    forall (m :: * -> *) a. Monad m => a -> m a
    return ( String
    "Simplifier reached fixed point", Int
    iteration_no
                           , [SimplCount] -> SimplCount
    totalise (SimplCount
    counts1 forall a. a -> [a] -> [a]
    : [SimplCount]
    counts_so_far)  -- Include "free" ticks
                           , ModGuts
    guts { mg_binds :: CoreProgram
    mg_binds = CoreProgram
    binds1, mg_rules :: [CoreRule]
    mg_rules = [CoreRule]
    rules1 } )
               else do {
                    -- Short out indirections
                    -- We do this *after* at least one run of the simplifier
                    -- because indirection-shorting uses the export flag on *occurrences*
                    -- and that isn't guaranteed to be ok until after the first run propagates
                    -- stuff from the binding site to its occurrences
                    --
                    -- ToDo: alas, this means that indirection-shorting does not happen at all
                    --       if the simplifier does nothing (not common, I know, but unsavoury)
               let { binds2 :: CoreProgram
    binds2 = {-# SCC "ZapInd" #-} CoreProgram -> CoreProgram
    shortOutIndirections CoreProgram
    binds1 } ;

                    -- Dump the result of this iteration
               Logger
    -> DynFlags
    -> PrintUnqualified
    -> Int
    -> SimplCount
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dump_end_iteration Logger
    logger DynFlags
    dflags PrintUnqualified
    print_unqual Int
    iteration_no SimplCount
    counts1 CoreProgram
    binds2 [CoreRule]
    rules1 ;
               HscEnv -> CoreToDo -> CoreProgram -> IO ()
    lintPassResult HscEnv
    hsc_env CoreToDo
    pass CoreProgram
    binds2 ;

                    -- Loop
               Int
    -> [SimplCount]
    -> CoreProgram
    -> [CoreRule]
    -> IO (String, Int, SimplCount, ModGuts)
    do_iteration (Int
    iteration_no forall a. Num a => a -> a -> a
    + Int
    1) (SimplCount
    counts1forall a. a -> [a] -> [a]
    :[SimplCount]
    counts_so_far) CoreProgram
    binds2 [CoreRule]
    rules1
               } }
    #if __GLASGOW_HASKELL__ <= 810
          | otherwise = panic "do_iteration"
    #endif
          where
            -- Remember the counts_so_far are reversed
            totalise :: [SimplCount] -> SimplCount
            totalise :: [SimplCount] -> SimplCount
    totalise = forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\SimplCount
    c SimplCount
    acc -> SimplCount
    acc SimplCount -> SimplCount -> SimplCount
    `plusSimplCount` SimplCount
    c)
                             (DynFlags -> SimplCount
    zeroSimplCount DynFlags
    dflags)

    simplifyPgmIO CoreToDo
    _ HscEnv
    _ RuleBase
    _ ModGuts
    _ = forall a. String -> a
    panic String
    "simplifyPgmIO"

    -------------------
    dump_end_iteration :: Logger -> DynFlags -> PrintUnqualified -> Int
                       -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
    dump_end_iteration :: Logger
    -> DynFlags
    -> PrintUnqualified
    -> Int
    -> SimplCount
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dump_end_iteration Logger
    logger DynFlags
    dflags PrintUnqualified
    print_unqual Int
    iteration_no SimplCount
    counts CoreProgram
    binds [CoreRule]
    rules
      = Logger
    -> DynFlags
    -> PrintUnqualified
    -> Maybe DumpFlag
    -> SDoc
    -> SDoc
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dumpPassResult Logger
    logger DynFlags
    dflags PrintUnqualified
    print_unqual Maybe DumpFlag
    mb_flag SDoc
    hdr SDoc
    pp_counts CoreProgram
    binds [CoreRule]
    rules
      where
        mb_flag :: Maybe DumpFlag
    mb_flag | DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_dump_simpl_iterations DynFlags
    dflags = forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_simpl_iterations
                | Bool
    otherwise                               = forall a. Maybe a
    Nothing
                -- Show details if Opt_D_dump_simpl_iterations is on

        hdr :: SDoc
    hdr = String -> SDoc
    text String
    "Simplifier iteration=" SDoc -> SDoc -> SDoc
    <> Int -> SDoc
    int Int
    iteration_no
        pp_counts :: SDoc
    pp_counts = [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "---- Simplifier counts for" SDoc -> SDoc -> SDoc
    <+> SDoc
    hdr
                         , SimplCount -> SDoc
    pprSimplCount SimplCount
    counts
                         , String -> SDoc
    text String
    "---- End of simplifier counts for" SDoc -> SDoc -> SDoc
    <+> SDoc
    hdr ]

    {-
    ************************************************************************
    *                                                                      *
                    Shorting out indirections
    *                                                                      *
    ************************************************************************

    If we have this:

            x_local = <expression>
            ...bindings...
            x_exported = x_local

    where x_exported is exported, and x_local is not, then we replace it with this:

            x_exported = <expression>
            x_local = x_exported
            ...bindings...

    Without this we never get rid of the x_exported = x_local thing.  This
    save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
    makes strictness information propagate better.  This used to happen in
    the final phase, but it's tidier to do it here.

    Note [Messing up the exported Id's RULES]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We must be careful about discarding (obviously) or even merging the
    RULES on the exported Id. The example that went bad on me at one stage
    was this one:

        iterate :: (a -> a) -> a -> [a]
            [Exported]
        iterate = iterateList

        iterateFB c f x = x `c` iterateFB c f (f x)
        iterateList f x =  x : iterateList f (f x)
            [Not exported]

        {-# RULES
        "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
        "iterateFB"                 iterateFB (:) = iterateList
         #-}

    This got shorted out to:

        iterateList :: (a -> a) -> a -> [a]
        iterateList = iterate

        iterateFB c f x = x `c` iterateFB c f (f x)
        iterate f x =  x : iterate f (f x)

        {-# RULES
        "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
        "iterateFB"                 iterateFB (:) = iterate
         #-}

    And now we get an infinite loop in the rule system
            iterate f x -> build (\cn -> iterateFB c f x)
                        -> iterateFB (:) f x
                        -> iterate f x

    Old "solution":
            use rule switching-off pragmas to get rid
            of iterateList in the first place

    But in principle the user *might* want rules that only apply to the Id
    they say.  And inline pragmas are similar
       {-# NOINLINE f #-}
       f = local
       local = <stuff>
    Then we do not want to get rid of the NOINLINE.

    Hence hasShortableIdinfo.

    Note [Rules and indirection-zapping]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Problem: what if x_exported has a RULE that mentions something in ...bindings...?
    Then the things mentioned can be out of scope!  Solution
     a) Make sure that in this pass the usage-info from x_exported is
            available for ...bindings...
     b) If there are any such RULES, rec-ify the entire top-level.
        It'll get sorted out next time round

    Other remarks
    ~~~~~~~~~~~~~
    If more than one exported thing is equal to a local thing (i.e., the
    local thing really is shared), then we do one only:
    \begin{verbatim}
            x_local = ....
            x_exported1 = x_local
            x_exported2 = x_local
    ==>
            x_exported1 = ....

            x_exported2 = x_exported1
    \end{verbatim}

    We rely on prior eta reduction to simplify things like
    \begin{verbatim}
            x_exported = /\ tyvars -> x_local tyvars
    ==>
            x_exported = x_local
    \end{verbatim}
    Hence,there's a possibility of leaving unchanged something like this:
    \begin{verbatim}
            x_local = ....
            x_exported1 = x_local Int
    \end{verbatim}
    By the time we've thrown away the types in STG land this
    could be eliminated.  But I don't think it's very common
    and it's dangerous to do this fiddling in STG land
    because we might eliminate a binding that's mentioned in the
    unfolding for something.

    Note [Indirection zapping and ticks]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Unfortunately this is another place where we need a special case for
    ticks. The following happens quite regularly:

            x_local = <expression>
            x_exported = tick<x> x_local

    Which we want to become:

            x_exported =  tick<x> <expression>

    As it makes no sense to keep the tick and the expression on separate
    bindings. Note however that this might increase the ticks scoping
    over the execution of x_local, so we can only do this for floatable
    ticks. More often than not, other references will be unfoldings of
    x_exported, and therefore carry the tick anyway.
    -}

    type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks

    shortOutIndirections :: CoreProgram -> CoreProgram
    shortOutIndirections :: CoreProgram -> CoreProgram
    shortOutIndirections CoreProgram
    binds
      | forall a. VarEnv a -> Bool
    isEmptyVarEnv IndEnv
    ind_env = CoreProgram
    binds
      | Bool
    no_need_to_flatten    = CoreProgram
    binds'                      -- See Note [Rules and indirect-zapping]
      | Bool
    otherwise             = [forall b. [(b, Expr b)] -> Bind b
    Rec (forall b. [Bind b] -> [(b, Expr b)]
    flattenBinds CoreProgram
    binds')] -- for this no_need_to_flatten stuff
      where
        ind_env :: IndEnv
    ind_env            = CoreProgram -> IndEnv
    makeIndEnv CoreProgram
    binds
        -- These exported Ids are the subjects  of the indirection-elimination
        exp_ids :: [Id]
    exp_ids            = forall a b. (a -> b) -> [a] -> [b]
    map forall a b. (a, b) -> a
    fst forall a b. (a -> b) -> a -> b
    $ forall key elt. UniqFM key elt -> [elt]
    nonDetEltsUFM IndEnv
    ind_env
          -- It's OK to use nonDetEltsUFM here because we forget the ordering
          -- by immediately converting to a set or check if all the elements
          -- satisfy a predicate.
        exp_id_set :: VarSet
    exp_id_set         = [Id] -> VarSet
    mkVarSet [Id]
    exp_ids
        no_need_to_flatten :: Bool
    no_need_to_flatten = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (forall (t :: * -> *) a. Foldable t => t a -> Bool
    null forall b c a. (b -> c) -> (a -> b) -> a -> c
    . RuleInfo -> [CoreRule]
    ruleInfoRules forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> RuleInfo
    idSpecialisation) [Id]
    exp_ids
        binds' :: CoreProgram
    binds'             = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Bind Id -> CoreProgram
    zap CoreProgram
    binds

        zap :: Bind Id -> CoreProgram
    zap (NonRec Id
    bndr CoreExpr
    rhs) = [forall b. b -> Expr b -> Bind b
    NonRec Id
    b CoreExpr
    r | (Id
    b,CoreExpr
    r) <- (Id, CoreExpr) -> [(Id, CoreExpr)]
    zapPair (Id
    bndr,CoreExpr
    rhs)]
        zap (Rec [(Id, CoreExpr)]
    pairs)       = [forall b. [(b, Expr b)] -> Bind b
    Rec (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Id, CoreExpr) -> [(Id, CoreExpr)]
    zapPair [(Id, CoreExpr)]
    pairs)]

        zapPair :: (Id, CoreExpr) -> [(Id, CoreExpr)]
    zapPair (Id
    bndr, CoreExpr
    rhs)
            | Id
    bndr Id -> VarSet -> Bool
    `elemVarSet` VarSet
    exp_id_set
            = []   -- Kill the exported-id binding

            | Just (Id
    exp_id, [CoreTickish]
    ticks) <- forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv IndEnv
    ind_env Id
    bndr
            , (Id
    exp_id', Id
    lcl_id') <- Id -> Id -> (Id, Id)
    transferIdInfo Id
    exp_id Id
    bndr
            =      -- Turn a local-id binding into two bindings
                   --    exp_id = rhs; lcl_id = exp_id
              [ (Id
    exp_id', [CoreTickish] -> CoreExpr -> CoreExpr
    mkTicks [CoreTickish]
    ticks CoreExpr
    rhs),
                (Id
    lcl_id', forall b. Id -> Expr b
    Var Id
    exp_id') ]

            | Bool
    otherwise
            = [(Id
    bndr,CoreExpr
    rhs)]

    makeIndEnv :: [CoreBind] -> IndEnv
    makeIndEnv :: CoreProgram -> IndEnv
    makeIndEnv CoreProgram
    binds
      = forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' IndEnv -> Bind Id -> IndEnv
    add_bind forall a. VarEnv a
    emptyVarEnv CoreProgram
    binds
      where
        add_bind :: IndEnv -> CoreBind -> IndEnv
        add_bind :: IndEnv -> Bind Id -> IndEnv
    add_bind IndEnv
    env (NonRec Id
    exported_id CoreExpr
    rhs) = IndEnv -> (Id, CoreExpr) -> IndEnv
    add_pair IndEnv
    env (Id
    exported_id, CoreExpr
    rhs)
        add_bind IndEnv
    env (Rec [(Id, CoreExpr)]
    pairs)              = forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' IndEnv -> (Id, CoreExpr) -> IndEnv
    add_pair IndEnv
    env [(Id, CoreExpr)]
    pairs

        add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv
        add_pair :: IndEnv -> (Id, CoreExpr) -> IndEnv
    add_pair IndEnv
    env (Id
    exported_id, CoreExpr
    exported)
            | ([CoreTickish]
    ticks, Var Id
    local_id) <- forall b.
    (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
    stripTicksTop forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishFloatable CoreExpr
    exported
            , IndEnv -> Id -> Id -> Bool
    shortMeOut IndEnv
    env Id
    exported_id Id
    local_id
            = forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv IndEnv
    env Id
    local_id (Id
    exported_id, [CoreTickish]
    ticks)
        add_pair IndEnv
    env (Id, CoreExpr)
    _ = IndEnv
    env

    -----------------
    shortMeOut :: IndEnv -> Id -> Id -> Bool
    shortMeOut :: IndEnv -> Id -> Id -> Bool
    shortMeOut IndEnv
    ind_env Id
    exported_id Id
    local_id
    -- The if-then-else stuff is just so I can get a pprTrace to see
    -- how often I don't get shorting out because of IdInfo stuff
      = if Id -> Bool
    isExportedId Id
    exported_id Bool -> Bool -> Bool
    &&              -- Only if this is exported

           Id -> Bool
    isLocalId Id
    local_id Bool -> Bool -> Bool
    &&                    -- Only if this one is defined in this
                                                    --      module, so that we *can* change its
                                                    --      binding to be the exported thing!

           Bool -> Bool
    not (Id -> Bool
    isExportedId Id
    local_id) Bool -> Bool -> Bool
    &&           -- Only if this one is not itself exported,
                                                    --      since the transformation will nuke it

           Bool -> Bool
    not (Id
    local_id forall a. Id -> VarEnv a -> Bool
    `elemVarEnv` IndEnv
    ind_env)      -- Only if not already substituted for
        then
            if Id -> Bool
    hasShortableIdInfo Id
    exported_id
            then Bool
    True       -- See Note [Messing up the exported Id's IdInfo]
            else WARN( True, text "Not shorting out:" <+> ppr exported_id )
                 Bool
    False
        else
            Bool
    False

    -----------------
    hasShortableIdInfo :: Id -> Bool
    -- True if there is no user-attached IdInfo on exported_id,
    -- so we can safely discard it
    -- See Note [Messing up the exported Id's IdInfo]
    hasShortableIdInfo :: Id -> Bool
    hasShortableIdInfo Id
    id
      =  RuleInfo -> Bool
    isEmptyRuleInfo (IdInfo -> RuleInfo
    ruleInfo IdInfo
    info)
      Bool -> Bool -> Bool
    && InlinePragma -> Bool
    isDefaultInlinePragma (IdInfo -> InlinePragma
    inlinePragInfo IdInfo
    info)
      Bool -> Bool -> Bool
    && Bool -> Bool
    not (Unfolding -> Bool
    isStableUnfolding (IdInfo -> Unfolding
    unfoldingInfo IdInfo
    info))
      where
         info :: IdInfo
    info = HasDebugCallStack => Id -> IdInfo
    idInfo Id
    id

    -----------------
    {- Note [Transferring IdInfo]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    If we have
         lcl_id = e; exp_id = lcl_id

    and lcl_id has useful IdInfo, we don't want to discard it by going
         gbl_id = e; lcl_id = gbl_id

    Instead, transfer IdInfo from lcl_id to exp_id, specifically
    * (Stable) unfolding
    * Strictness
    * Rules
    * Inline pragma

    Overwriting, rather than merging, seems to work ok.

    We also zap the InlinePragma on the lcl_id. It might originally
    have had a NOINLINE, which we have now transferred; and we really
    want the lcl_id to inline now that its RHS is trivial!
    -}

    transferIdInfo :: Id -> Id -> (Id, Id)
    -- See Note [Transferring IdInfo]
    transferIdInfo :: Id -> Id -> (Id, Id)
    transferIdInfo Id
    exported_id Id
    local_id
      = ( HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
    modifyIdInfo IdInfo -> IdInfo
    transfer Id
    exported_id
        , Id
    local_id Id -> InlinePragma -> Id
    `setInlinePragma` InlinePragma
    defaultInlinePragma )
      where
        local_info :: IdInfo
    local_info = HasDebugCallStack => Id -> IdInfo
    idInfo Id
    local_id
        transfer :: IdInfo -> IdInfo
    transfer IdInfo
    exp_info = IdInfo
    exp_info IdInfo -> StrictSig -> IdInfo
    `setStrictnessInfo`    IdInfo -> StrictSig
    strictnessInfo IdInfo
    local_info
                                     IdInfo -> CprSig -> IdInfo
    `setCprInfo`           IdInfo -> CprSig
    cprInfo IdInfo
    local_info
                                     IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`     IdInfo -> Unfolding
    unfoldingInfo IdInfo
    local_info
                                     IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo`    IdInfo -> InlinePragma
    inlinePragInfo IdInfo
    local_info
                                     IdInfo -> RuleInfo -> IdInfo
    `setRuleInfo`          RuleInfo -> RuleInfo -> RuleInfo
    addRuleInfo (IdInfo -> RuleInfo
    ruleInfo IdInfo
    exp_info) RuleInfo
    new_info
        new_info :: RuleInfo
    new_info = Name -> RuleInfo -> RuleInfo
    setRuleInfoHead (Id -> Name
    idName Id
    exported_id)
                                   (IdInfo -> RuleInfo
    ruleInfo IdInfo
    local_info)
            -- Remember to set the function-name field of the
            -- rules as we transfer them from one function to another

    dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
    dmdAnal :: Logger
    -> DynFlags
    -> FamInstEnvs
    -> [CoreRule]
    -> CoreProgram
    -> IO CoreProgram
    dmdAnal Logger
    logger DynFlags
    dflags FamInstEnvs
    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
                   }
          binds_plus_dmds :: CoreProgram
    binds_plus_dmds = DmdAnalOpts
    -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
    dmdAnalProgram DmdAnalOpts
    opts FamInstEnvs
    fam_envs [CoreRule]
    rules CoreProgram
    binds
      Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    Logger.dumpIfSet_dyn Logger
    logger DynFlags
    dflags DumpFlag
    Opt_D_dump_str_signatures String
    "Strictness signatures" DumpFormat
    FormatText forall a b. (a -> b) -> a -> b
    $
        (IdInfo -> SDoc) -> CoreProgram -> SDoc
    dumpIdInfoOfProgram (forall a. Outputable a => a -> SDoc
    ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StrictSig -> StrictSig
    zapDmdEnvSig forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IdInfo -> StrictSig
    strictnessInfo) CoreProgram
    binds_plus_dmds
      -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
      CoreProgram -> ()
    seqBinds CoreProgram
    binds_plus_dmds seq :: forall a b. a -> b -> b
    `seq` forall (m :: * -> *) a. Monad m => a -> m a
    return CoreProgram
    binds_plus_dmds