{-
(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.Platform.Ways  ( hasWay, Way(WayProf) )

import GHC.Core
import GHC.Core.Opt.CSE  ( cseProgram )
import GHC.Core.Rules   ( mkRuleBase,
                          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, simplImpRules )
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.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.Utils.Constants (debugIsOn)
import GHC.Utils.Trace

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.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.FM
import GHC.Types.Name.Ppr

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 = Logger -> DynFlags -> [CoreToDo]
getCoreToDo Logger
logger DynFlags
dflags
             orph_mods :: ModuleSet
orph_mods = [Module] -> ModuleSet
mkModuleSet (Module
mod Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs Dependencies
deps)
             uniq_mask :: Char
uniq_mask = Char
's'
       ;
       ; (ModGuts
guts2, SimplCount
stats) <- HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount)
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 (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
    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 -> 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
    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
    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
    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
    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

    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 Int
phase)
      | Int
phase Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
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        = String -> CompilerPhase
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
      ([CoreToDo] -> CoreToDo) -> [CoreToDo] -> CoreToDo
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 [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 Int
floatOutLambdas   = Int -> Maybe Int
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 ([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 Int
floatOutLambdas   = Int -> Maybe Int
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
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_simpl3
            ([CoreToDo] -> CoreToDo
CoreDoPasses ([CoreToDo] -> CoreToDo) -> [CoreToDo] -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [ CompilerPhase -> String -> Int -> CoreToDo
simpl_phase (Int -> CompilerPhase
Phase Int
phase) String
"main" Int
max_iter
                            | Int
phase <- [Int
phases, Int
phasesInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 .. Int
1] ] [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++
                            [ CompilerPhase -> String -> Int -> CoreToDo
simpl_phase (Int -> CompilerPhase
Phase Int
0) String
"main" (Int -> Int -> Int
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 (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 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 (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) CoreToDo
CoreDoDemand,

        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

{- 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
  = (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
<+> SDoc -> SDoc
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
  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 :: 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) 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 :: CoreProgram
mg_binds = CoreProgram
b' }

  case CoreToDo
pass of
    CoreDoSimplify {}         -> {-# SCC "Simplify" #-}
                                 CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm CoreToDo
pass ModGuts
guts

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

    CoreToDo
CoreLiberateCase          -> {-# SCC "LiberateCase" #-}
                                 (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (DynFlags -> CoreProgram -> CoreProgram
liberateCase 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

    CoreToDo
CoreDoDemand              -> {-# 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
-> DynFlags
-> (PackageFamInstEnv, PackageFamInstEnv)
-> [CoreRule]
-> CoreProgram
-> IO CoreProgram
dmdAnal Logger
logger 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 (Module
-> DynFlags
-> (PackageFamInstEnv, PackageFamInstEnv)
-> UniqSupply
-> CoreProgram
-> CoreProgram
wwTopBinds (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)
    CoreToDo
CoreOccurAnal             -> 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
text String
"RuleCheck"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
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
        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
                          [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ (ModGuts -> [CoreRule]
mg_rules ModGuts
guts)
        let 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
-> (Id -> [CoreRule])
-> CoreProgram
-> SDoc
ruleCheckProgram RuleOpts
ropts CompilerPhase
current_phase String
pat
                        Id -> [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

{-
************************************************************************
*                                                                      *
        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
  = Logger -> SDoc -> (CoreExpr -> ()) -> IO CoreExpr -> IO CoreExpr
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
text String
"Simplify [expr]") (() -> CoreExpr -> ()
forall a b. a -> b -> a
const ()) (IO CoreExpr -> IO CoreExpr) -> IO CoreExpr -> IO CoreExpr
forall a b. (a -> b) -> a -> b
$
    do  { ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env ;
        ; let fi_env :: (PackageFamInstEnv, PackageFamInstEnv)
fi_env    = ( ExternalPackageState -> PackageFamInstEnv
eps_fam_inst_env ExternalPackageState
eps
                          , PackageFamInstEnv -> [FamInst] -> PackageFamInstEnv
extendFamInstEnvList PackageFamInstEnv
emptyFamInstEnv ([FamInst] -> PackageFamInstEnv) -> [FamInst] -> PackageFamInstEnv
forall a b. (a -> b) -> a -> b
$
                            (InstEnv, [FamInst]) -> [FamInst]
forall a b. (a, b) -> b
snd ((InstEnv, [FamInst]) -> [FamInst])
-> (InstEnv, [FamInst]) -> [FamInst]
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> (InstEnv, [FamInst])
ic_instances (InteractiveContext -> (InstEnv, [FamInst]))
-> InteractiveContext -> (InstEnv, [FamInst])
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) <- Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (PackageFamInstEnv, PackageFamInstEnv)
-> Int
-> SimplM CoreExpr
-> IO (CoreExpr, SimplCount)
forall a.
Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (PackageFamInstEnv, PackageFamInstEnv)
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger DynFlags
dflags (ExternalPackageState -> RuleBase
eps_rule_base (ExternalPackageState -> RuleBase)
-> IO ExternalPackageState -> IO RuleBase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env) RuleEnv
emptyRuleEnv (PackageFamInstEnv, PackageFamInstEnv)
fi_env Int
sz (SimplM CoreExpr -> IO (CoreExpr, SimplCount))
-> SimplM CoreExpr -> IO (CoreExpr, SimplCount)
forall a b. (a -> b) -> a -> b
$
                             SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExprGently SimplEnv
simpl_env CoreExpr
expr

        ; Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_simpl_stats
                  String
"Simplifier statistics" DumpFormat
FormatText (SimplCount -> SDoc
pprSimplCount SimplCount
counts)

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

        ; CoreExpr -> IO CoreExpr
forall a. a -> IO a
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 [Simplify rule LHS] 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
       ; 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
$
         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

        ; Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_verbose_core2core
                Bool -> Bool -> Bool
&& Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_simpl_stats) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Logger -> String -> SDoc -> IO ()
logDumpMsg Logger
logger
                  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
<+> Int -> 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])

        ; (SimplCount, ModGuts) -> IO (SimplCount, ModGuts)
forall a. a -> IO a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
max_iterations   -- Stop if we've run out of iterations
      = Bool
-> String
-> SDoc
-> IO (String, Int, SimplCount, ModGuts)
-> IO (String, Int, SimplCount, ModGuts)
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool
debugIsOn Bool -> Bool -> Bool
&& (Int
max_iterations Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2))
            String
"Simplifier bailing out"
            ( SDoc -> Int -> SDoc -> SDoc
hang (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", after"
                    SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
max_iterations SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"iterations"
                    SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                         (SimplCount -> SDoc) -> [SimplCount] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> SDoc
int (Int -> SDoc) -> (SimplCount -> Int) -> SimplCount -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimplCount -> Int
simplCountN) ([SimplCount] -> [SimplCount]
forall a. [a] -> [a]
reverse [SimplCount]
counts_so_far)))
                 Int
2 (String -> SDoc
text String
"Size =" SDoc -> SDoc -> SDoc
<+> CoreStats -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreProgram -> CoreStats
coreBindsStats CoreProgram
binds))) (IO (String, Int, SimplCount, ModGuts)
 -> IO (String, Int, SimplCount, ModGuts))
-> IO (String, Int, SimplCount, ModGuts)
-> IO (String, Int, SimplCount, ModGuts)
forall a b. (a -> b) -> a -> b
$

                -- Subtract 1 from iteration_no to get the
                -- number of iterations we actually completed
        (String, Int, SimplCount, ModGuts)
-> IO (String, Int, SimplCount, ModGuts)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( String
"Simplifier baled out", Int
iteration_no Int -> Int -> Int
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 Int -> () -> ()
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 -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_occur_anal String
"Occurrence analysis"
                     DumpFormat
FormatCore
                     (CoreProgram -> SDoc
forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings CoreProgram
tagged_binds);

                -- read_eps_rules:
                -- We need to read rules from the EPS 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
                -- Hence just before attempting to match rules we read on the EPS
                -- value and then combine it when the existing rule base.
                -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.
           ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env ;
           let  { read_eps_rules :: IO RuleBase
read_eps_rules = ExternalPackageState -> RuleBase
eps_rule_base (ExternalPackageState -> RuleBase)
-> IO ExternalPackageState -> IO RuleBase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
                ; rule_base :: RuleBase
rule_base = RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
hpt_rule_base [CoreRule]
rules
                ; fam_envs :: (PackageFamInstEnv, PackageFamInstEnv)
fam_envs = (ExternalPackageState -> PackageFamInstEnv
eps_fam_inst_env ExternalPackageState
eps, PackageFamInstEnv
fam_inst_env)
                ; vis_orphs :: [Module]
vis_orphs = Module
this_mod Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs Dependencies
deps } ;

                -- Simplify the program
           ((CoreProgram
binds1, [CoreRule]
rules1), SimplCount
counts1) <-
             Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (PackageFamInstEnv, PackageFamInstEnv)
-> Int
-> SimplM (CoreProgram, [CoreRule])
-> IO ((CoreProgram, [CoreRule]), SimplCount)
forall a.
Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (PackageFamInstEnv, PackageFamInstEnv)
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger DynFlags
dflags IO RuleBase
read_eps_rules (RuleBase -> [Module] -> RuleEnv
mkRuleEnv RuleBase
rule_base [Module]
vis_orphs) (PackageFamInstEnv, PackageFamInstEnv)
fam_envs Int
sz (SimplM (CoreProgram, [CoreRule])
 -> IO ((CoreProgram, [CoreRule]), SimplCount))
-> SimplM (CoreProgram, [CoreRule])
-> IO ((CoreProgram, [CoreRule]), SimplCount)
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 -> [CoreRule] -> SimplM [CoreRule]
simplImpRules SimplEnv
env1 [CoreRule]
rules

                  ; (CoreProgram, [CoreRule]) -> SimplM (CoreProgram, [CoreRule])
forall a. a -> SimplM a
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
                (String, Int, SimplCount, ModGuts)
-> IO (String, Int, SimplCount, ModGuts)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( String
"Simplifier reached fixed point", Int
iteration_no
                       , [SimplCount] -> SimplCount
totalise (SimplCount
counts1 SimplCount -> [SimplCount] -> [SimplCount]
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
           let { dump_core_sizes :: Bool
dump_core_sizes = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressCoreSizes DynFlags
dflags) } ;
           Logger
-> Bool
-> PrintUnqualified
-> Int
-> SimplCount
-> CoreProgram
-> [CoreRule]
-> IO ()
dump_end_iteration Logger
logger Bool
dump_core_sizes 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (SimplCount
counts1SimplCount -> [SimplCount] -> [SimplCount]
forall 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 = (SimplCount -> SimplCount -> SimplCount)
-> SimplCount -> [SimplCount] -> SimplCount
forall a b. (a -> b -> b) -> b -> [a] -> b
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
_ = String -> IO (SimplCount, ModGuts)
forall a. String -> a
panic String
"simplifyPgmIO"

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

    hdr :: String
hdr = String
"Simplifier iteration=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
iteration_no
    pp_counts :: SDoc
pp_counts = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"---- Simplifier counts for" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
hdr
                     , SimplCount -> SDoc
pprSimplCount SimplCount
counts
                     , String -> SDoc
text String
"---- End of simplifier counts for" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
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
  | VarEnv (Id, [CoreTickish]) -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarEnv (Id, [CoreTickish])
ind_env = CoreProgram
binds
  | Bool
no_need_to_flatten    = CoreProgram
binds'                      -- See Note [Rules and indirection-zapping]
  | Bool
otherwise             = [[(Id, CoreExpr)] -> Bind Id
forall b. [(b, Expr b)] -> Bind b
Rec (CoreProgram -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds')] -- for this no_need_to_flatten stuff
  where
    ind_env :: VarEnv (Id, [CoreTickish])
ind_env            = CoreProgram -> VarEnv (Id, [CoreTickish])
makeIndEnv CoreProgram
binds
    -- These exported Ids are the subjects  of the indirection-elimination
    exp_ids :: [Id]
exp_ids            = ((Id, [CoreTickish]) -> Id) -> [(Id, [CoreTickish])] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, [CoreTickish]) -> Id
forall a b. (a, b) -> a
fst ([(Id, [CoreTickish])] -> [Id]) -> [(Id, [CoreTickish])] -> [Id]
forall a b. (a -> b) -> a -> b
$ VarEnv (Id, [CoreTickish]) -> [(Id, [CoreTickish])]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM VarEnv (Id, [CoreTickish])
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 = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([CoreRule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CoreRule] -> Bool) -> (Id -> [CoreRule]) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleInfo -> [CoreRule]
ruleInfoRules (RuleInfo -> [CoreRule]) -> (Id -> RuleInfo) -> Id -> [CoreRule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> RuleInfo
idSpecialisation) [Id]
exp_ids
    binds' :: CoreProgram
binds'             = (Bind Id -> CoreProgram) -> CoreProgram -> CoreProgram
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) = [Id -> CoreExpr -> Bind Id
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)       = [[(Id, CoreExpr)] -> Bind Id
forall b. [(b, Expr b)] -> Bind b
Rec (((Id, CoreExpr) -> [(Id, CoreExpr)])
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
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) <- VarEnv (Id, [CoreTickish]) -> Id -> Maybe (Id, [CoreTickish])
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv (Id, [CoreTickish])
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', Id -> CoreExpr
forall b. Id -> Expr b
Var Id
exp_id') ]

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

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

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

-----------------
shortMeOut :: IndEnv -> Id -> Id -> Bool
shortMeOut :: VarEnv (Id, [CoreTickish]) -> Id -> Id -> Bool
shortMeOut VarEnv (Id, [CoreTickish])
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 Id -> VarEnv (Id, [CoreTickish]) -> Bool
forall a. Id -> VarEnv a -> Bool
`elemVarEnv` VarEnv (Id, [CoreTickish])
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 RULES]
        else Bool -> String -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"Not shorting out" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
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 RULES]
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
realUnfoldingInfo IdInfo
info))
  where
     info :: IdInfo
info = (() :: Constraint) => Id -> IdInfo
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.

For the lcl_id we

* Zap the InlinePragma. 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!

* Zap any Stable unfolding.  agian, we want lcl_id = gbl_id to inline,
  replacing lcl_id by gbl_id. That won't happen if lcl_id has its original
  great big Stable unfolding
-}

transferIdInfo :: Id -> Id -> (Id, Id)
-- See Note [Transferring IdInfo]
transferIdInfo :: Id -> Id -> (Id, Id)
transferIdInfo Id
exported_id Id
local_id
  = ( (() :: Constraint) => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo IdInfo -> IdInfo
transfer Id
exported_id
    , (() :: Constraint) => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo IdInfo -> IdInfo
zap_info Id
local_id )
  where
    local_info :: IdInfo
local_info = (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
local_id
    transfer :: IdInfo -> IdInfo
transfer IdInfo
exp_info = IdInfo
exp_info IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo`     IdInfo -> DmdSig
dmdSigInfo IdInfo
local_info
                                 IdInfo -> CprSig -> IdInfo
`setCprSigInfo`     IdInfo -> CprSig
cprSigInfo IdInfo
local_info
                                 IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  IdInfo -> Unfolding
realUnfoldingInfo 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

    zap_info :: IdInfo -> IdInfo
zap_info IdInfo
lcl_info = IdInfo
lcl_info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
defaultInlinePragma
                                 IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  Unfolding
noUnfolding


dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
dmdAnal :: Logger
-> DynFlags
-> (PackageFamInstEnv, PackageFamInstEnv)
-> [CoreRule]
-> CoreProgram
-> IO CoreProgram
dmdAnal Logger
logger 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_unbox_width :: Int
dmd_unbox_width     = DynFlags -> Int
dmdUnboxWidth DynFlags
dflags
               , dmd_max_worker_args :: Int
dmd_max_worker_args = DynFlags -> Int
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