{-
(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.Session
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 )
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   ( 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.Env( SimplMode(..) )
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           (addLateCostCentresMG)
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.Env
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.Deps

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_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 = DynFlags -> RuleBase -> [CoreBndr] -> [CoreToDo]
getCoreToDo DynFlags
dflags RuleBase
hpt_rule_base [CoreBndr]
extra_vars
             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 =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env')
                                                Plugin -> CorePlugin
installCoreToDos
                                                [CoreToDo]
builtin_passes
                              ; [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
all_passes ModGuts
guts }

       ; Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger 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
    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 = 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
    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 :: DynFlags -> RuleBase -> [Var] -> [CoreToDo]
getCoreToDo :: DynFlags -> RuleBase -> [CoreBndr] -> [CoreToDo]
getCoreToDo DynFlags
dflags RuleBase
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 = 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 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

    ----------------------------
    base_simpl_mode :: SimplMode
    base_simpl_mode :: SimplMode
base_simpl_mode = DynFlags -> SimplMode
initSimplMode DynFlags
dflags

    -- gentle_mode: make specialiser happy: minimum effort please
    -- See Note [Inline in InitialPhase]
    -- See Note [RULEs enabled in InitialPhase]
    gentle_mode :: SimplMode
gentle_mode = SimplMode
base_simpl_mode { sm_names :: [String]
sm_names     = [String
"Gentle"]
                                  , sm_phase :: CompilerPhase
sm_phase     = CompilerPhase
InitialPhase
                                  , sm_case_case :: Bool
sm_case_case = Bool
False }

    simpl_mode :: CompilerPhase -> String -> SimplMode
simpl_mode CompilerPhase
phase String
name
      = SimplMode
base_simpl_mode { sm_names :: [String]
sm_names = [String
name], sm_phase :: CompilerPhase
sm_phase = CompilerPhase
phase }

    keep_exits :: SimplMode -> SimplMode
    -- See Note [Be selective about not-inlining exit join points]
    -- in GHC.Core.Opt.Exitify
    keep_exits :: SimplMode -> SimplMode
keep_exits SimplMode
mode = SimplMode
mode { sm_keep_exits :: Bool
sm_keep_exits = Bool
True }

    ----------------------------
    run_simplifier :: SimplMode -> PhaseNum -> CoreToDo
run_simplifier SimplMode
mode PhaseNum
iter
      = SimplifyOpts -> CoreToDo
CoreDoSimplify forall a b. (a -> b) -> a -> b
$ DynFlags
-> [CoreBndr] -> PhaseNum -> SimplMode -> RuleBase -> SimplifyOpts
initSimplifyOpts DynFlags
dflags [CoreBndr]
extra_vars PhaseNum
iter SimplMode
mode RuleBase
rule_base

    simpl_phase :: CompilerPhase -> String -> PhaseNum -> CoreToDo
simpl_phase CompilerPhase
phase String
name PhaseNum
iter = [CoreToDo] -> CoreToDo
CoreDoPasses forall a b. (a -> b) -> a -> b
$
                                  [ CompilerPhase -> CoreToDo
maybe_strictness_before CompilerPhase
phase
                                  , SimplMode -> PhaseNum -> CoreToDo
run_simplifier (CompilerPhase -> String -> SimplMode
simpl_mode CompilerPhase
phase String
name) PhaseNum
iter
                                  , 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
    simpl_gently :: CoreToDo
simpl_gently          = SimplMode -> PhaseNum -> CoreToDo
run_simplifier SimplMode
gentle_mode  PhaseNum
max_iter
    simplify_final :: String -> CoreToDo
simplify_final   String
name = SimplMode -> PhaseNum -> CoreToDo
run_simplifier (             CompilerPhase -> String -> SimplMode
simpl_mode CompilerPhase
FinalPhase String
name) PhaseNum
max_iter
    simpl_keep_exits :: String -> CoreToDo
simpl_keep_exits String
name = SimplMode -> PhaseNum -> CoreToDo
run_simplifier (SimplMode -> SimplMode
keep_exits forall a b. (a -> b) -> a -> b
$ CompilerPhase -> String -> SimplMode
simpl_mode CompilerPhase
FinalPhase String
name) PhaseNum
max_iter

    ----------------------------
    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]


    -- 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 PhaseNum
floatOutLambdas   = 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null 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) 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   = 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 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
phasesforall a. Num a => a -> a -> a
-PhaseNum
1 .. PhaseNum
1] ] forall a. [a] -> [a] -> [a]
++
                            [ CompilerPhase -> String -> PhaseNum -> CoreToDo
simpl_phase (PhaseNum -> CompilerPhase
Phase PhaseNum
0) String
"main" (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 forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
            [ CoreToDo
CoreDoCallArity
            , String -> CoreToDo
simplify_final String
"post-call-arity"
            ],

        -- Strictness analysis
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
strictness forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
            ([CoreToDo]
dmd_cpr_ww forall a. [a] -> [a] -> [a]
++ [String -> CoreToDo
simplify_final String
"post-worker-wrapper"]),

        Bool -> CoreToDo -> CoreToDo
runWhen Bool
exitification CoreToDo
CoreDoExitify,
            -- See Note [Placement of the exitification pass]
            -- in GHC.Core.Opt.Exitify

        Bool -> CoreToDo -> CoreToDo
runWhen Bool
full_laziness 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,

        -- Final tidy-up run of the simplifier
        String -> CoreToDo
simpl_keep_exits String
"final tidy up",
            -- Keep exit join point because this is the first
            -- Simplifier run after Exitify. Subsequent runs will
            -- re-inline those exit join points; their work is done.
            -- See Note [Be selective about not-inlining exit join points]
            -- in GHC.Core.Opt.Exitify
            --
            -- Annoyingly, we only /have/ a subsequent run with -O2.  With
            -- plain -O we'll still have those exit join points hanging around.
            -- Oh well.

        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_final 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_final 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_final 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_final 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_final 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 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

-- 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
  = 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
      Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
      forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (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
  HscEnv
hsc_env   <- CoreM HscEnv
getHscEnv
  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 platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
  let fam_envs :: (PackageFamInstEnv, PackageFamInstEnv)
fam_envs = (PackageFamInstEnv
p_fam_env, ModGuts -> PackageFamInstEnv
mg_fam_inst_env ModGuts
guts)
  let updateBinds :: (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds  CoreProgram -> CoreProgram
f = 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
f (ModGuts -> CoreProgram
mg_binds ModGuts
guts) }
  let updateBindsM :: (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM CoreProgram -> CoreM CoreProgram
f = CoreProgram -> CoreM CoreProgram
f (ModGuts -> CoreProgram
mg_binds ModGuts
guts) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CoreProgram
b' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModGuts
guts { mg_binds :: CoreProgram
mg_binds = CoreProgram
b' }

  case CoreToDo
pass of
    CoreDoSimplify SimplifyOpts
opts       -> {-# SCC "Simplify" #-}
                                 forall a. IO (SimplCount, a) -> CoreM a
liftIOWithCount forall a b. (a -> b) -> a -> b
$ Logger
-> UnitEnv -> SimplifyOpts -> ModGuts -> IO (SimplCount, ModGuts)
simplifyPgm Logger
logger (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) 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 (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
addLateCostCentresMG ModGuts
guts

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

{-
************************************************************************
*                                                                      *
\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" (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 -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (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 :: CoreBndr -> [CoreRule]
rule_fn CoreBndr
fn = RuleEnv -> CoreBndr -> [CoreRule]
getRules ([RuleBase] -> ModuleSet -> RuleEnv
RuleEnv [RuleBase
rb] ModuleSet
vis_orphs) CoreBndr
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 -> String -> SDoc -> IO ()
logDumpMsg Logger
logger String
"Rule check"
                     (RuleOpts
-> CompilerPhase
-> String
-> (CoreBndr -> [CoreRule])
-> CoreProgram
-> SDoc
ruleCheckProgram RuleOpts
ropts CompilerPhase
current_phase String
pat
                        CoreBndr -> [CoreRule]
rule_fn (ModGuts -> CoreProgram
mg_binds ModGuts
guts))
        forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
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_str_signatures String
"Strictness signatures" DumpFormat
FormatText forall a b. (a -> b) -> a -> b
$
    Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram (DynFlags -> Bool
hasPprDebug DynFlags
dflags) (forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. DmdSig -> DmdSig
zapDmdEnvSig 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 seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_plus_dmds