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

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

{-# LANGUAGE CPP #-}

module SimplCore ( core2core, simplifyExpr ) where

#include "HsVersions.h"

import GhcPrelude

import DynFlags
import CoreSyn
import HscTypes
import CSE              ( cseProgram )
import Rules            ( mkRuleBase, unionRuleBase,
                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,
                          getRules )
import PprCore          ( pprCoreBindings, pprCoreExpr )
import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo
import CoreStats        ( coreBindsSize, coreBindsStats, exprSize )
import CoreUtils        ( mkTicks, stripTicksTop )
import CoreLint         ( endPass, lintPassResult, dumpPassResult,
                          lintAnnots )
import Simplify         ( simplTopBinds, simplExpr, simplRules )
import SimplUtils       ( simplEnvForGHCi, activeRule, activeUnfolding )
import SimplEnv
import SimplMonad
import CoreMonad
import qualified ErrUtils as Err
import FloatIn          ( floatInwards )
import FloatOut         ( floatOutwards )
import FamInstEnv
import Id
import ErrUtils         ( withTiming, withTimingD )
import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )
import VarSet
import VarEnv
import LiberateCase     ( liberateCase )
import SAT              ( doStaticArgs )
import Specialise       ( specProgram)
import SpecConstr       ( specConstrProgram)
import DmdAnal          ( dmdAnalProgram )
import CallArity        ( callArityAnalProgram )
import Exitify          ( exitifyProgram )
import WorkWrap         ( wwTopBinds )
import SrcLoc
import Util
import Module
import Plugins          ( withPlugins, installCoreToDos )
import DynamicLoading  -- ( initializePlugins )

import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import UniqFM
import Outputable
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 { -- make sure all plugins are loaded

       ; let builtin_passes :: [CoreToDo]
builtin_passes = DynFlags -> [CoreToDo]
getCoreToDo 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
                              ; DynFlags
dflags' <- IO DynFlags -> CoreM DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> CoreM DynFlags) -> IO DynFlags -> CoreM DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
hsc_env'
                                                      (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env')
                              ; [CoreToDo]
all_passes <- DynFlags
-> PluginOperation CoreM [CoreToDo]
-> [CoreToDo]
-> CoreM [CoreToDo]
forall (m :: * -> *) a.
Monad m =>
DynFlags -> PluginOperation m a -> a -> m a
withPlugins DynFlags
dflags'
                                                PluginOperation CoreM [CoreToDo]
installCoreToDos
                                                [CoreToDo]
builtin_passes
                              ; [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
all_passes ModGuts
guts }

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

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

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

getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo 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 :: IsBootInterface
call_arity    = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_CallArity                    DynFlags
dflags
    exitification :: IsBootInterface
exitification = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_Exitification                DynFlags
dflags
    strictness :: IsBootInterface
strictness    = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_Strictness                   DynFlags
dflags
    full_laziness :: IsBootInterface
full_laziness = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_FullLaziness                 DynFlags
dflags
    do_specialise :: IsBootInterface
do_specialise = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_Specialise                   DynFlags
dflags
    do_float_in :: IsBootInterface
do_float_in   = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_FloatIn                      DynFlags
dflags
    cse :: IsBootInterface
cse           = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_CSE                          DynFlags
dflags
    spec_constr :: IsBootInterface
spec_constr   = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_SpecConstr                   DynFlags
dflags
    liberate_case :: IsBootInterface
liberate_case = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_LiberateCase                 DynFlags
dflags
    late_dmd_anal :: IsBootInterface
late_dmd_anal = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_LateDmdAnal                  DynFlags
dflags
    late_specialise :: IsBootInterface
late_specialise = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_LateSpecialise             DynFlags
dflags
    static_args :: IsBootInterface
static_args   = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_StaticArgumentTransformation DynFlags
dflags
    rules_on :: IsBootInterface
rules_on      = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_EnableRewriteRules           DynFlags
dflags
    eta_expand_on :: IsBootInterface
eta_expand_on = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_DoLambdaEtaExpansion         DynFlags
dflags
    ww_on :: IsBootInterface
ww_on         = GeneralFlag -> DynFlags -> IsBootInterface
gopt GeneralFlag
Opt_WorkerWrapper                DynFlags
dflags
    static_ptrs :: IsBootInterface
static_ptrs   = Extension -> DynFlags -> IsBootInterface
xopt Extension
LangExt.StaticPointers           DynFlags
dflags

    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 :: Int -> CoreToDo
maybe_strictness_before Int
phase
      = IsBootInterface -> CoreToDo -> CoreToDo
runWhen (Int
phase Int -> [Int] -> IsBootInterface
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> IsBootInterface
`elem` DynFlags -> [Int]
strictnessBefore DynFlags
dflags) CoreToDo
CoreDoStrictness

    base_mode :: SimplMode
base_mode = SimplMode :: [String]
-> CompilerPhase
-> DynFlags
-> IsBootInterface
-> IsBootInterface
-> IsBootInterface
-> IsBootInterface
-> SimplMode
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_rules :: IsBootInterface
sm_rules      = IsBootInterface
rules_on
                          , sm_eta_expand :: IsBootInterface
sm_eta_expand = IsBootInterface
eta_expand_on
                          , sm_inline :: IsBootInterface
sm_inline     = IsBootInterface
True
                          , sm_case_case :: IsBootInterface
sm_case_case  = IsBootInterface
True }

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

          , CompilerPhase -> CoreToDo
maybe_rule_check (Int -> CompilerPhase
Phase Int
phase) ]

    simpl_phases :: CoreToDo
simpl_phases = [CoreToDo] -> CoreToDo
CoreDoPasses [ Int -> [String] -> Int -> CoreToDo
simpl_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] ]


        -- 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 :: IsBootInterface
sm_rules = IsBootInterface
rules_on   -- Note [RULEs enabled in SimplGently]
                                  , sm_inline :: IsBootInterface
sm_inline = IsBootInterface
True
                                              -- See Note [Inline in InitialPhase]
                                  , sm_case_case :: IsBootInterface
sm_case_case = IsBootInterface
False })
                          -- Don't do case-of-case transformations.
                          -- This makes full laziness work better

    strictness_pass :: [CoreToDo]
strictness_pass = if IsBootInterface
ww_on
                       then [CoreToDo
CoreDoStrictness,CoreToDo
CoreDoWorkerWrapper]
                       else [CoreToDo
CoreDoStrictness]


    -- New demand analyser
    demand_analyser :: CoreToDo
demand_analyser = ([CoreToDo] -> CoreToDo
CoreDoPasses (
                           [CoreToDo]
strictness_pass [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++
                           [Int -> [String] -> Int -> CoreToDo
simpl_phase Int
0 [String
"post-worker-wrapper"] Int
max_iter]
                           ))

    -- Static forms are moved to the top level with the FloatOut pass.
    -- See Note [Grand plan for static forms] in StaticPtrTable.
    static_ptrs_float_outwards :: CoreToDo
static_ptrs_float_outwards =
      IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
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 :: Maybe Int
-> IsBootInterface
-> IsBootInterface
-> IsBootInterface
-> FloatOutSwitches
FloatOutSwitches
          { floatOutLambdas :: Maybe Int
floatOutLambdas   = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
          , floatOutConstants :: IsBootInterface
floatOutConstants = IsBootInterface
True
          , floatOutOverSatApps :: IsBootInterface
floatOutOverSatApps = IsBootInterface
False
          , floatToTopLevelOnly :: IsBootInterface
floatToTopLevelOnly = IsBootInterface
True
          }
        ]

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

     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
        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
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
        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
do_specialise CoreToDo
CoreDoSpecialising,

        if IsBootInterface
full_laziness then
           FloatOutSwitches -> CoreToDo
CoreDoFloatOutwards FloatOutSwitches :: Maybe Int
-> IsBootInterface
-> IsBootInterface
-> IsBootInterface
-> FloatOutSwitches
FloatOutSwitches {
                                 floatOutLambdas :: Maybe Int
floatOutLambdas   = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0,
                                 floatOutConstants :: IsBootInterface
floatOutConstants = IsBootInterface
True,
                                 floatOutOverSatApps :: IsBootInterface
floatOutOverSatApps = IsBootInterface
False,
                                 floatToTopLevelOnly :: IsBootInterface
floatToTopLevelOnly = IsBootInterface
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
           -- StaticPtrTable.
           CoreToDo
static_ptrs_float_outwards,

        CoreToDo
simpl_phases,

                -- 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!
        Int -> [String] -> Int -> CoreToDo
simpl_phase Int
0 [String
"main"] (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
max_iter Int
3),

        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
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.

        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
call_arity (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
            [ CoreToDo
CoreDoCallArity
            , Int -> [String] -> Int -> CoreToDo
simpl_phase Int
0 [String
"post-call-arity"] Int
max_iter
            ],

        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
strictness CoreToDo
demand_analyser,

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

        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
full_laziness (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$
           FloatOutSwitches -> CoreToDo
CoreDoFloatOutwards FloatOutSwitches :: Maybe Int
-> IsBootInterface
-> IsBootInterface
-> IsBootInterface
-> FloatOutSwitches
FloatOutSwitches {
                                 floatOutLambdas :: Maybe Int
floatOutLambdas     = DynFlags -> Maybe Int
floatLamArgs DynFlags
dflags,
                                 floatOutConstants :: IsBootInterface
floatOutConstants   = IsBootInterface
True,
                                 floatOutOverSatApps :: IsBootInterface
floatOutOverSatApps = IsBootInterface
True,
                                 floatToTopLevelOnly :: IsBootInterface
floatToTopLevelOnly = IsBootInterface
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)


        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
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

        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
do_float_in CoreToDo
CoreDoFloatInwards,

        CompilerPhase -> CoreToDo
maybe_rule_check (Int -> CompilerPhase
Phase Int
0),

                -- Case-liberation for -O2.  This should be after
                -- strictness analysis and the simplification which follows it.
        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
liberate_case ([CoreToDo] -> CoreToDo
CoreDoPasses [
            CoreToDo
CoreLiberateCase,
            Int -> [String] -> Int -> CoreToDo
simpl_phase Int
0 [String
"post-liberate-case"] Int
max_iter
            ]),         -- Run the simplifier after LiberateCase to vastly
                        -- reduce the possibility of shadowing
                        -- Reason: see Note [Shadowing] in SpecConstr.hs

        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
spec_constr CoreToDo
CoreDoSpecConstr,

        CompilerPhase -> CoreToDo
maybe_rule_check (Int -> CompilerPhase
Phase Int
0),

        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
late_specialise
          ([CoreToDo] -> CoreToDo
CoreDoPasses [ CoreToDo
CoreDoSpecialising
                        , Int -> [String] -> Int -> CoreToDo
simpl_phase Int
0 [String
"post-late-spec"] Int
max_iter]),

        -- 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.
        IsBootInterface -> CoreToDo -> CoreToDo
runWhen ((IsBootInterface
liberate_case IsBootInterface -> IsBootInterface -> IsBootInterface
|| IsBootInterface
spec_constr) IsBootInterface -> IsBootInterface -> IsBootInterface
&& IsBootInterface
cse) CoreToDo
CoreCSE,

        -- Final clean-up simplification:
        Int -> [String] -> Int -> CoreToDo
simpl_phase Int
0 [String
"final"] Int
max_iter,

        IsBootInterface -> CoreToDo -> CoreToDo
runWhen IsBootInterface
late_dmd_anal (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses (
            [CoreToDo]
strictness_pass [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++
            [Int -> [String] -> Int -> CoreToDo
simpl_phase Int
0 [String
"post-late-ww"] Int
max_iter]
          ),

        -- 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 DmdAnal
        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution
        -- can become /exponentially/ more expensive. See #11731, #12996.
        IsBootInterface -> CoreToDo -> CoreToDo
runWhen (IsBootInterface
strictness IsBootInterface -> IsBootInterface -> IsBootInterface
|| IsBootInterface
late_dmd_anal) CoreToDo
CoreDoStrictness,

        CompilerPhase -> CoreToDo
maybe_rule_check (Int -> CompilerPhase
Phase Int
0)
     ]

    -- 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 SimplGently]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
RULES are enabled when doing "gentle" simplification.  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.

************************************************************************
*                                                                      *
                  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 (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
       SDoc -> (ModGuts -> ()) -> CoreM ModGuts -> CoreM ModGuts
forall (m :: * -> *) a.
(MonadIO m, HasDynFlags m) =>
SDoc -> (a -> ()) -> m a -> m a
withTimingD (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 (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 pass :: CoreToDo
pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
                                       CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm CoreToDo
pass

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

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

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

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

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

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

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

doCorePass CoreToDo
CoreDoStrictness          = {-# SCC "NewStranal" #-}
                                       (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram)
-> ModGuts -> CoreM ModGuts
doPassDFM DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram

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

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

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

doCorePass CoreToDo
CoreDoPrintCore              = (DynFlags -> CoreProgram -> IO ()) -> ModGuts -> CoreM ModGuts
forall a.
(DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
observe   DynFlags -> CoreProgram -> IO ()
printCore
doCorePass (CoreDoRuleCheck CompilerPhase
phase String
pat)  = CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass CompilerPhase
phase String
pat
doCorePass CoreToDo
CoreDoNothing                = ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return
doCorePass (CoreDoPasses [CoreToDo]
passes)        = [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
passes

doCorePass (CoreDoPluginPass String
_ ModGuts -> CoreM ModGuts
pass) = {-# SCC "Plugin" #-} ModGuts -> CoreM ModGuts
pass

doCorePass pass :: CoreToDo
pass@CoreToDo
CoreDesugar          = String -> SDoc -> ModGuts -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
doCorePass pass :: CoreToDo
pass@CoreToDo
CoreDesugarOpt       = String -> SDoc -> ModGuts -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
doCorePass pass :: CoreToDo
pass@CoreToDo
CoreTidy             = String -> SDoc -> ModGuts -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
doCorePass pass :: CoreToDo
pass@CoreToDo
CorePrep             = String -> SDoc -> ModGuts -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
doCorePass pass :: CoreToDo
pass@CoreToDo
CoreOccurAnal        = String -> SDoc -> ModGuts -> 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 :: DynFlags -> CoreProgram -> IO ()
printCore :: DynFlags -> CoreProgram -> IO ()
printCore DynFlags
dflags CoreProgram
binds
    = DynFlags -> IsBootInterface -> String -> SDoc -> IO ()
Err.dumpIfSet DynFlags
dflags IsBootInterface
True 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 =
    SDoc -> (ModGuts -> ()) -> CoreM ModGuts -> CoreM ModGuts
forall (m :: * -> *) a.
(MonadIO m, HasDynFlags m) =>
SDoc -> (a -> ()) -> m a -> m a
withTimingD (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
    ; DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    ; 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)
    ; IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
Err.SevDump SrcSpan
noSrcSpan
                   (DynFlags -> PprStyle
defaultDumpStyle DynFlags
dflags)
                   (CompilerPhase
-> String -> (Id -> [CoreRule]) -> CoreProgram -> SDoc
ruleCheckProgram CompilerPhase
current_phase String
pat
                      Id -> [CoreRule]
rule_fn (ModGuts -> CoreProgram
mg_binds ModGuts
guts))
    ; ModGuts -> CoreM ModGuts
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 = (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
forall (m :: * -> *).
Monad m =>
(CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
doPassM ((CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts)
-> (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ \CoreProgram
binds -> do
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    UniqSupply
us     <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
    IO CoreProgram -> CoreM CoreProgram
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CoreProgram -> CoreM CoreProgram)
-> IO CoreProgram -> CoreM CoreProgram
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 -> (CoreProgram -> IO CoreProgram)
-> UniqSupply -> CoreProgram -> IO CoreProgram
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 -> CoreProgram -> IO CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram -> IO CoreProgram)
-> (CoreProgram -> CoreProgram) -> CoreProgram -> IO CoreProgram
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 -> CoreProgram -> IO CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram -> IO CoreProgram)
-> (CoreProgram -> CoreProgram) -> CoreProgram -> IO CoreProgram
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 ((UniqSupply -> CoreProgram -> CoreProgram)
-> DynFlags -> UniqSupply -> CoreProgram -> CoreProgram
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 <- CoreM DynFlags
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)
    (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
forall (m :: * -> *).
Monad m =>
(CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
doPassM (IO CoreProgram -> CoreM CoreProgram
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
. DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
do_pass DynFlags
dflags FamInstEnvs
fam_envs) 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 <- 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 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 :: (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)
    ModGuts -> m ModGuts
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 = ModGuts -> CoreM ModGuts
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
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 :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
observe DynFlags -> CoreProgram -> IO a
do_pass = (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
forall (m :: * -> *).
Monad m =>
(CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
doPassM ((CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts)
-> (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ \CoreProgram
binds -> do
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    a
_ <- IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> CoreM a) -> IO a -> CoreM a
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreProgram -> IO a
do_pass DynFlags
dflags CoreProgram
binds
    CoreProgram -> CoreM CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds

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

simplifyExpr :: DynFlags -- 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
--
-- Also used by Template Haskell
simplifyExpr :: DynFlags -> CoreExpr -> IO CoreExpr
simplifyExpr DynFlags
dflags CoreExpr
expr
  = DynFlags -> SDoc -> (CoreExpr -> ()) -> IO CoreExpr -> IO CoreExpr
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags (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  {
        ; UniqSupply
us <-  Char -> IO UniqSupply
mkSplitUniqSupply Char
's'

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

        ; (CoreExpr
expr', SimplCount
counts) <- DynFlags
-> RuleEnv
-> FamInstEnvs
-> UniqSupply
-> Int
-> SimplM CoreExpr
-> IO (CoreExpr, SimplCount)
forall a.
DynFlags
-> RuleEnv
-> FamInstEnvs
-> UniqSupply
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl DynFlags
dflags RuleEnv
emptyRuleEnv
                               FamInstEnvs
emptyFamInstEnvs UniqSupply
us Int
sz
                               (SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExprGently (DynFlags -> SimplEnv
simplEnvForGHCi DynFlags
dflags) CoreExpr
expr)

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

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

        ; CoreExpr -> IO CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr'
        }

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 SimplGently,
-- 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 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
       ; UniqSupply
us <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
       ; 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
-> UniqSupply
-> RuleBase
-> ModGuts
-> IO (SimplCount, ModGuts)
simplifyPgmIO CoreToDo
pass HscEnv
hsc_env UniqSupply
us RuleBase
rb ModGuts
guts }

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

simplifyPgmIO :: CoreToDo
-> HscEnv
-> UniqSupply
-> RuleBase
-> ModGuts
-> IO (SimplCount, ModGuts)
simplifyPgmIO pass :: CoreToDo
pass@(CoreDoSimplify Int
max_iterations SimplMode
mode)
              HscEnv
hsc_env UniqSupply
us 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')
           <- UniqSupply
-> Int
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> IO (String, Int, SimplCount, ModGuts)
do_iteration UniqSupply
us Int
1 [] CoreProgram
binds [CoreRule]
rules

        ; DynFlags -> IsBootInterface -> String -> SDoc -> IO ()
Err.dumpIfSet DynFlags
dflags (DumpFlag -> DynFlags -> IsBootInterface
dopt DumpFlag
Opt_D_verbose_core2core DynFlags
dflags IsBootInterface -> IsBootInterface -> IsBootInterface
&&
                                DumpFlag -> DynFlags -> IsBootInterface
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
<+> 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 (m :: * -> *) a. Monad m => a -> m a
return (SimplCount
counts_out, ModGuts
guts')
    }
  where
    dflags :: DynFlags
dflags       = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    print_unqual :: PrintUnqualified
print_unqual = DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
rdr_env
    simpl_env :: SimplEnv
simpl_env    = SimplMode -> SimplEnv
mkSimplEnv SimplMode
mode
    active_rule :: Activation -> IsBootInterface
active_rule  = SimplMode -> Activation -> IsBootInterface
activeRule SimplMode
mode
    active_unf :: Id -> IsBootInterface
active_unf   = SimplMode -> Id -> IsBootInterface
activeUnfolding SimplMode
mode

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

    do_iteration :: UniqSupply
-> Int
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> IO (String, Int, SimplCount, ModGuts)
do_iteration UniqSupply
us 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 -> IsBootInterface
forall a. Ord a => a -> a -> IsBootInterface
> 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
        (String, Int, SimplCount, ModGuts)
-> IO (String, Int, SimplCount, ModGuts)
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 -> () -> ()
`seq` ()     -- Force it
      = do {
                -- Occurrence analysis
           let { tagged_binds :: CoreProgram
tagged_binds = {-# SCC "OccAnal" #-}
                     Module
-> (Id -> IsBootInterface)
-> (Activation -> IsBootInterface)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm Module
this_mod Id -> IsBootInterface
active_unf Activation -> IsBootInterface
active_rule [CoreRule]
rules
                                     CoreProgram
binds
               } ;
           DynFlags -> DumpFlag -> String -> SDoc -> IO ()
Err.dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_occur_anal String
"Occurrence analysis"
                     (CoreProgram -> SDoc
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 Rules.hs
                -- 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 Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs Dependencies
deps } ;

                -- Simplify the program
           ((CoreProgram
binds1, [CoreRule]
rules1), SimplCount
counts1) <-
             DynFlags
-> RuleEnv
-> FamInstEnvs
-> UniqSupply
-> Int
-> SimplM (CoreProgram, [CoreRule])
-> IO ((CoreProgram, [CoreRule]), SimplCount)
forall a.
DynFlags
-> RuleEnv
-> FamInstEnvs
-> UniqSupply
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl DynFlags
dflags (RuleBase -> [Module] -> RuleEnv
mkRuleEnv RuleBase
rule_base2 [Module]
vis_orphs) FamInstEnvs
fam_envs UniqSupply
us1 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
-> Maybe Id -> [CoreRule] -> MaybeJoinCont -> SimplM [CoreRule]
simplRules SimplEnv
env1 Maybe Id
forall a. Maybe a
Nothing [CoreRule]
rules MaybeJoinCont
forall a. Maybe a
Nothing

                  ; (CoreProgram, [CoreRule]) -> SimplM (CoreProgram, [CoreRule])
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 CoreMonad
           if SimplCount -> IsBootInterface
isZeroSimplCount SimplCount
counts1 then
                (String, Int, SimplCount, ModGuts)
-> IO (String, Int, SimplCount, ModGuts)
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
           DynFlags
-> PrintUnqualified
-> Int
-> SimplCount
-> CoreProgram
-> [CoreRule]
-> IO ()
dump_end_iteration 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
           UniqSupply
-> Int
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> IO (String, Int, SimplCount, ModGuts)
do_iteration UniqSupply
us2 (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
           } }
      | IsBootInterface
otherwise = String -> IO (String, Int, SimplCount, ModGuts)
forall a. String -> a
panic String
"do_iteration"
      where
        (UniqSupply
us1, UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us

        -- Remember the counts_so_far are reversed
        totalise :: [SimplCount] -> SimplCount
        totalise :: [SimplCount] -> SimplCount
totalise = (SimplCount -> SimplCount -> SimplCount)
-> SimplCount -> [SimplCount] -> SimplCount
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
_ UniqSupply
_ RuleBase
_ ModGuts
_ = String -> IO (SimplCount, ModGuts)
forall a. String -> a
panic String
"simplifyPgmIO"

-------------------
dump_end_iteration :: DynFlags -> PrintUnqualified -> Int
                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
dump_end_iteration :: DynFlags
-> PrintUnqualified
-> Int
-> SimplCount
-> CoreProgram
-> [CoreRule]
-> IO ()
dump_end_iteration DynFlags
dflags PrintUnqualified
print_unqual Int
iteration_no SimplCount
counts CoreProgram
binds [CoreRule]
rules
  = DynFlags
-> PrintUnqualified
-> Maybe DumpFlag
-> SDoc
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
dumpPassResult 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 -> IsBootInterface
dopt DumpFlag
Opt_D_dump_simpl_iterations DynFlags
dflags = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_simpl_iterations
            | IsBootInterface
otherwise                               = Maybe DumpFlag
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
he says.  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 elminate 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 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, [Tickish Var]) -- Maps local_id -> exported_id, ticks

shortOutIndirections :: CoreProgram -> CoreProgram
shortOutIndirections :: CoreProgram -> CoreProgram
shortOutIndirections CoreProgram
binds
  | VarEnv (Id, [Tickish Id]) -> IsBootInterface
forall a. VarEnv a -> IsBootInterface
isEmptyVarEnv VarEnv (Id, [Tickish Id])
ind_env = CoreProgram
binds
  | IsBootInterface
no_need_to_flatten    = CoreProgram
binds'                      -- See Note [Rules and indirect-zapping]
  | IsBootInterface
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, [Tickish Id])
ind_env            = CoreProgram -> VarEnv (Id, [Tickish Id])
makeIndEnv CoreProgram
binds
    -- These exported Ids are the subjects  of the indirection-elimination
    exp_ids :: [Id]
exp_ids            = ((Id, [Tickish Id]) -> Id) -> [(Id, [Tickish Id])] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, [Tickish Id]) -> Id
forall a b. (a, b) -> a
fst ([(Id, [Tickish Id])] -> [Id]) -> [(Id, [Tickish Id])] -> [Id]
forall a b. (a -> b) -> a -> b
$ VarEnv (Id, [Tickish Id]) -> [(Id, [Tickish Id])]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM VarEnv (Id, [Tickish Id])
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 :: IsBootInterface
no_need_to_flatten = (Id -> IsBootInterface) -> [Id] -> IsBootInterface
forall (t :: * -> *) a.
Foldable t =>
(a -> IsBootInterface) -> t a -> IsBootInterface
all ([CoreRule] -> IsBootInterface
forall (t :: * -> *) a. Foldable t => t a -> IsBootInterface
null ([CoreRule] -> IsBootInterface)
-> (Id -> [CoreRule]) -> Id -> IsBootInterface
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 -> IsBootInterface
`elemVarSet` VarSet
exp_id_set
        = []   -- Kill the exported-id binding

        | Just (Id
exp_id, [Tickish Id]
ticks) <- VarEnv (Id, [Tickish Id]) -> Id -> Maybe (Id, [Tickish Id])
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv (Id, [Tickish Id])
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', [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks [Tickish Id]
ticks CoreExpr
rhs),
            (Id
lcl_id', Id -> CoreExpr
forall b. Id -> Expr b
Var Id
exp_id') ]

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

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

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

-----------------
shortMeOut :: IndEnv -> Id -> Id -> Bool
shortMeOut :: VarEnv (Id, [Tickish Id]) -> Id -> Id -> IsBootInterface
shortMeOut VarEnv (Id, [Tickish Id])
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 -> IsBootInterface
isExportedId Id
exported_id IsBootInterface -> IsBootInterface -> IsBootInterface
&&              -- Only if this is exported

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

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

       IsBootInterface -> IsBootInterface
not (Id
local_id Id -> VarEnv (Id, [Tickish Id]) -> IsBootInterface
forall a. Id -> VarEnv a -> IsBootInterface
`elemVarEnv` VarEnv (Id, [Tickish Id])
ind_env)      -- Only if not already substituted for
    then
        if Id -> IsBootInterface
hasShortableIdInfo Id
exported_id
        then IsBootInterface
True       -- See Note [Messing up the exported Id's IdInfo]
        else WARN( True, text "Not shorting out:" <+> ppr exported_id )
             IsBootInterface
False
    else
        IsBootInterface
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 -> IsBootInterface
hasShortableIdInfo Id
id
  =  RuleInfo -> IsBootInterface
isEmptyRuleInfo (IdInfo -> RuleInfo
ruleInfo IdInfo
info)
  IsBootInterface -> IsBootInterface -> IsBootInterface
&& InlinePragma -> IsBootInterface
isDefaultInlinePragma (IdInfo -> InlinePragma
inlinePragInfo IdInfo
info)
  IsBootInterface -> IsBootInterface -> IsBootInterface
&& IsBootInterface -> IsBootInterface
not (Unfolding -> IsBootInterface
isStableUnfolding (IdInfo -> Unfolding
unfoldingInfo IdInfo
info))
  where
     info :: IdInfo
info = HasDebugCallStack => 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.

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