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

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

{-# LANGUAGE CPP #-}

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

#include "HsVersions.h"

import GHC.Prelude

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

import GHC.Core
import GHC.Core.Opt.CSE  ( cseProgram )
import GHC.Core.Rules   ( mkRuleBase, unionRuleBase,
                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,
                          getRules, initRuleOpts )
import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )
import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )
import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram )
import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,
                          lintAnnots )
import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplRules )
import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.Monad
import GHC.Core.Opt.FloatIn      ( floatInwards )
import GHC.Core.Opt.FloatOut     ( floatOutwards )
import GHC.Core.Opt.LiberateCase ( liberateCase )
import GHC.Core.Opt.StaticArgs   ( doStaticArgs )
import GHC.Core.Opt.Specialise   ( specProgram)
import GHC.Core.Opt.SpecConstr   ( specConstrProgram)
import GHC.Core.Opt.DmdAnal
import GHC.Core.Opt.CprAnal      ( cprAnalProgram )
import GHC.Core.Opt.CallArity    ( callArityAnalProgram )
import GHC.Core.Opt.Exitify      ( exitifyProgram )
import GHC.Core.Opt.WorkWrap     ( wwTopBinds )
import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )
import GHC.Core.Seq (seqBinds)
import GHC.Core.FamInstEnv

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

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

import GHC.Runtime.Context

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

import Control.Monad
import qualified GHC.LanguageExtensions as LangExt
{-
************************************************************************
*                                                                      *
\subsection{The driver for the simplifier}
*                                                                      *
************************************************************************
-}

core2core :: HscEnv -> ModGuts -> IO ModGuts
core2core :: HscEnv -> ModGuts -> IO ModGuts
core2core HscEnv
hsc_env guts :: ModGuts
guts@(ModGuts { mg_module :: ModGuts -> Module
mg_module  = Module
mod
                                , mg_loc :: ModGuts -> SrcSpan
mg_loc     = SrcSpan
loc
                                , mg_deps :: ModGuts -> Dependencies
mg_deps    = Dependencies
deps
                                , mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env })
  = do { let builtin_passes :: [CoreToDo]
builtin_passes = Logger -> DynFlags -> [CoreToDo]
getCoreToDo Logger
logger DynFlags
dflags
             orph_mods :: ModuleSet
orph_mods = [Module] -> ModuleSet
mkModuleSet (Module
mod forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs Dependencies
deps)
             uniq_mask :: Char
uniq_mask = Char
's'
       ;
       ; (ModGuts
guts2, SimplCount
stats) <- forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM HscEnv
hsc_env RuleBase
hpt_rule_base Char
uniq_mask Module
mod
                                    ModuleSet
orph_mods PrintUnqualified
print_unqual SrcSpan
loc forall a b. (a -> b) -> a -> b
$
                           do { HscEnv
hsc_env' <- CoreM HscEnv
getHscEnv
                              ; [CoreToDo]
all_passes <- forall (m :: * -> *) a.
Monad m =>
HscEnv -> PluginOperation m a -> a -> m a
withPlugins HscEnv
hsc_env'
                                                Plugin -> CorePlugin
installCoreToDos
                                                [CoreToDo]
builtin_passes
                              ; [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
all_passes ModGuts
guts }

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

       ; forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts2 }
  where
    logger :: Logger
logger         = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    dflags :: DynFlags
dflags         = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    home_pkg_rules :: [CoreRule]
home_pkg_rules = HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules HscEnv
hsc_env (Dependencies -> [ModuleNameWithIsBoot]
dep_mods Dependencies
deps)
    hpt_rule_base :: RuleBase
hpt_rule_base  = [CoreRule] -> RuleBase
mkRuleBase [CoreRule]
home_pkg_rules
    print_unqual :: PrintUnqualified
print_unqual   = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env
    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
    -- This is very convienent for the users of the monad (e.g. plugins do not have to
    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
    -- would mean our cached value would go out of date.

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

getCoreToDo :: Logger -> DynFlags -> [CoreToDo]
getCoreToDo :: Logger -> DynFlags -> [CoreToDo]
getCoreToDo Logger
logger DynFlags
dflags
  = [CoreToDo] -> [CoreToDo]
flatten_todos [CoreToDo]
core_todo
  where
    opt_level :: Int
opt_level     = DynFlags -> Int
optLevel           DynFlags
dflags
    phases :: Int
phases        = DynFlags -> Int
simplPhases        DynFlags
dflags
    max_iter :: Int
max_iter      = DynFlags -> Int
maxSimplIterations DynFlags
dflags
    rule_check :: Maybe String
rule_check    = DynFlags -> Maybe String
ruleCheck          DynFlags
dflags
    call_arity :: Bool
call_arity    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CallArity                    DynFlags
dflags
    exitification :: Bool
exitification = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Exitification                DynFlags
dflags
    strictness :: Bool
strictness    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Strictness                   DynFlags
dflags
    full_laziness :: Bool
full_laziness = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FullLaziness                 DynFlags
dflags
    do_specialise :: Bool
do_specialise = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Specialise                   DynFlags
dflags
    do_float_in :: Bool
do_float_in   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FloatIn                      DynFlags
dflags
    cse :: Bool
cse           = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CSE                          DynFlags
dflags
    spec_constr :: Bool
spec_constr   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SpecConstr                   DynFlags
dflags
    liberate_case :: Bool
liberate_case = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LiberateCase                 DynFlags
dflags
    late_dmd_anal :: Bool
late_dmd_anal = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LateDmdAnal                  DynFlags
dflags
    late_specialise :: Bool
late_specialise = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LateSpecialise             DynFlags
dflags
    static_args :: Bool
static_args   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_StaticArgumentTransformation DynFlags
dflags
    rules_on :: Bool
rules_on      = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules           DynFlags
dflags
    eta_expand_on :: Bool
eta_expand_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion         DynFlags
dflags
    pre_inline_on :: Bool
pre_inline_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining             DynFlags
dflags
    ww_on :: Bool
ww_on         = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WorkerWrapper                DynFlags
dflags
    static_ptrs :: Bool
static_ptrs   = Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers           DynFlags
dflags
    profiling :: Bool
profiling     = DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayProf

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

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

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

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

          , CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
phase ]

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

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

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


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

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

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

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

     else {- opt_level >= 1 -} [

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

        -- initial simplify: mk specialiser happy: minimum effort please
        CoreToDo
simpl_gently,

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

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

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

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

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

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

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

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

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


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

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

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

        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,

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

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

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

        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,

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

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

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

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

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

        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,

        CoreToDo
add_caller_ccs
     ]

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass CoreToDo
pass ModGuts
guts = do
  Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
  case CoreToDo
pass of
    CoreDoSimplify {}         -> {-# SCC "Simplify" #-}
                                 CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm CoreToDo
pass ModGuts
guts

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

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

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

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

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

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

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

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

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

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

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

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

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

    CoreToDo
CoreDoPrintCore           -> forall a.
(DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
observe (Logger -> DynFlags -> CoreProgram -> IO ()
printCore Logger
logger) ModGuts
guts

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

If we have this:

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

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

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

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

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

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

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

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

This got shorted out to:

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

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

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

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

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

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

Hence hasShortableIdinfo.


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

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

        x_exported2 = x_exported1
\end{verbatim}

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

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

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

Which we want to become:

        x_exported =  tick<x> <expression>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Overwriting, rather than merging, seems to work ok.

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

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



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