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

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

{-# LANGUAGE CPP #-}

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

import GHC.Prelude

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

import GHC.Core
import GHC.Core.Opt.CSE  ( cseProgram )
import GHC.Core.Rules   ( RuleBase, mkRuleBase, ruleCheckProgram, getRules )
import GHC.Core.Ppr     ( pprCoreBindings )
import GHC.Core.Utils   ( dumpIdInfoOfProgram )
import GHC.Core.Lint    ( lintAnnots )
import GHC.Core.Lint.Interactive ( interactiveInScope )
import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.Monad
import GHC.Core.Opt.Pipeline.Types
import GHC.Core.Opt.FloatIn      ( floatInwards )
import GHC.Core.Opt.FloatOut     ( floatOutwards )
import GHC.Core.Opt.LiberateCase ( liberateCase )
import GHC.Core.Opt.StaticArgs   ( doStaticArgs )
import GHC.Core.Opt.Specialise   ( specProgram)
import GHC.Core.Opt.SpecConstr   ( specConstrProgram)
import GHC.Core.Opt.DmdAnal
import GHC.Core.Opt.CprAnal      ( cprAnalProgram )
import GHC.Core.Opt.CallArity    ( callArityAnalProgram )
import GHC.Core.Opt.Exitify      ( exitifyProgram )
import GHC.Core.Opt.WorkWrap     ( wwTopBinds )
import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )
import GHC.Core.LateCC           (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.ModGuts

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

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

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

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

       ; (ModGuts
guts2, SimplCount
stats) <- HscEnv
-> RuleBase
-> Char
-> Module
-> NamePprCtx
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount)
forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> NamePprCtx
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM HscEnv
hsc_env RuleBase
hpt_rule_base Char
uniq_mask Module
mod
                                    NamePprCtx
name_ppr_ctx SrcSpan
loc (CoreM ModGuts -> IO (ModGuts, SimplCount))
-> CoreM ModGuts -> IO (ModGuts, SimplCount)
forall a b. (a -> b) -> a -> b
$
                           do { HscEnv
hsc_env' <- CoreM HscEnv
getHscEnv
                              ; [CoreToDo]
all_passes <- Plugins
-> PluginOperation CoreM [CoreToDo]
-> [CoreToDo]
-> CoreM [CoreToDo]
forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env')
                                                PluginOperation CoreM [CoreToDo]
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)

       ; ModGuts -> IO ModGuts
forall a. a -> IO a
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 = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod
                                                               , gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot })
    hpt_rule_base :: RuleBase
hpt_rule_base  = [CoreRule] -> RuleBase
mkRuleBase [CoreRule]
home_pkg_rules
    name_ppr_ctx :: NamePprCtx
name_ppr_ctx   = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
forall info.
Outputable info =>
PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env
    ptc :: PromotionTickContext
ptc            = DynFlags -> PromotionTickContext
initPromotionTickContext DynFlags
dflags
    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
    -- This is very convienent for the users of the monad (e.g. plugins do not have to
    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
    -- would mean our cached value would go out of date.

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,

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

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

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

        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,

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

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

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

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

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

        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,

        CoreToDo
add_caller_ccs,
        CoreToDo
add_late_ccs
     ]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
passes ModGuts
guts
  = (ModGuts -> CoreToDo -> CoreM ModGuts)
-> ModGuts -> [CoreToDo] -> CoreM ModGuts
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ModGuts -> CoreToDo -> CoreM ModGuts
do_pass ModGuts
guts [CoreToDo]
passes
  where
    do_pass :: ModGuts -> CoreToDo -> CoreM ModGuts
do_pass ModGuts
guts CoreToDo
CoreDoNothing = ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
    do_pass ModGuts
guts (CoreDoPasses [CoreToDo]
ps) = [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
ps ModGuts
guts
    do_pass ModGuts
guts CoreToDo
pass = do
      Logger
logger <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
      Logger -> SDoc -> (ModGuts -> ()) -> CoreM ModGuts -> CoreM ModGuts
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod))
                   (() -> ModGuts -> ()
forall a b. a -> b -> a
const ()) (CoreM ModGuts -> CoreM ModGuts) -> CoreM ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ do
            ModGuts
guts' <- SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
lintAnnots (CoreToDo -> SDoc
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')
            ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
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    <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  HscEnv
hsc_env   <- CoreM HscEnv
getHscEnv
  DynFlags
dflags    <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  UniqSupply
us        <- CoreM UniqSupply
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 = ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ ModGuts
guts { mg_binds = f (mg_binds guts) }
  let updateBindsM :: (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM CoreProgram -> CoreM CoreProgram
f = CoreProgram -> CoreM CoreProgram
f (ModGuts -> CoreProgram
mg_binds ModGuts
guts) CoreM CoreProgram
-> (CoreProgram -> CoreM ModGuts) -> CoreM ModGuts
forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CoreProgram
b' -> ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ ModGuts
guts { mg_binds = b' }
  let name_ppr_ctx :: NamePprCtx
name_ppr_ctx =
        PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
forall info.
Outputable info =>
PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
mkNamePprCtx
          (DynFlags -> PromotionTickContext
initPromotionTickContext DynFlags
dflags)
          (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
          (ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass CompilerPhase
current_phase String
pat ModGuts
guts = do
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    Logger -> SDoc -> (ModGuts -> ()) -> CoreM ModGuts -> CoreM ModGuts
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RuleCheck"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> SDoc) -> Module -> SDoc
forall a b. (a -> b) -> a -> b
$ ModGuts -> Module
mg_module ModGuts
guts))
                (() -> ModGuts -> ()
forall a b. a -> b -> a
const ()) (CoreM ModGuts -> CoreM ModGuts) -> CoreM ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ do
        RuleEnv
rule_env <- ModGuts -> CoreM RuleEnv
initRuleEnv ModGuts
guts
        let rule_fn :: CoreBndr -> [CoreRule]
rule_fn CoreBndr
fn = RuleEnv -> CoreBndr -> [CoreRule]
getRules RuleEnv
rule_env CoreBndr
fn
            ropts :: RuleOpts
ropts = DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags
        IO () -> CoreM ()
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
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))
        ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
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 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
    Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram (DynFlags -> Bool
hasPprDebug DynFlags
dflags) (DmdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DmdSig -> SDoc) -> (IdInfo -> DmdSig) -> IdInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DmdSig -> DmdSig
zapDmdEnvSig (DmdSig -> DmdSig) -> (IdInfo -> DmdSig) -> IdInfo -> DmdSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> DmdSig
dmdSigInfo) CoreProgram
binds_plus_dmds
  -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
  CoreProgram -> ()
seqBinds CoreProgram
binds_plus_dmds () -> IO CoreProgram -> IO CoreProgram
forall a b. a -> b -> b
`seq` CoreProgram -> IO CoreProgram
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_plus_dmds