{-# 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
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
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 ]
simplify :: String -> CoreToDo
simplify String
name = CompilerPhase -> String -> Int -> CoreToDo
simpl_phase CompilerPhase
FinalPhase String
name Int
max_iter
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
, sm_inline :: Bool
sm_inline = Bool
True
, sm_case_case :: Bool
sm_case_case = Bool
False })
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_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
, 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 [
Bool -> CoreToDo -> CoreToDo
runWhen Bool
static_args ([CoreToDo] -> CoreToDo
CoreDoPasses [ CoreToDo
simpl_gently, CoreToDo
CoreDoStaticArgs ]),
CoreToDo
simpl_gently,
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 }
else
CoreToDo
static_ptrs_float_outwards,
[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),
Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_float_in CoreToDo
CoreDoFloatInwards,
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"
],
Bool -> CoreToDo -> CoreToDo
runWhen Bool
strictness CoreToDo
demand_analyser,
Bool -> CoreToDo -> CoreToDo
runWhen Bool
exitification CoreToDo
CoreDoExitify,
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 },
Bool -> CoreToDo -> CoreToDo
runWhen Bool
cse CoreToDo
CoreCSE,
Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_float_in CoreToDo
CoreDoFloatInwards,
String -> CoreToDo
simplify String
"final",
CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,
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" ],
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"],
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"],
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" ],
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"]
),
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
]
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
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)
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
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) }
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
simplifyExpr :: HscEnv
-> CoreExpr
-> IO CoreExpr
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
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)
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)
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
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> 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
| Int
iteration_no forall a. Ord a => a -> a -> Bool
> Int
max_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)))
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 } )
| let sz :: Int
sz = CoreProgram -> Int
coreBindsSize CoreProgram
binds
, () <- Int
sz seq :: forall a b. a -> b -> b
`seq` ()
= do {
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);
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 } ;
((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
; [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) } ;
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)
, ModGuts
guts { mg_binds :: CoreProgram
mg_binds = CoreProgram
binds1, mg_rules :: [CoreRule]
mg_rules = [CoreRule]
rules1 } )
else do {
let { binds2 :: CoreProgram
binds2 = {-# SCC "ZapInd" #-} CoreProgram -> CoreProgram
shortOutIndirections CoreProgram
binds1 } ;
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 ;
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
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
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 ]
type IndEnv = IdEnv (Id, [CoreTickish])
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'
| Bool
otherwise = [forall b. [(b, Expr b)] -> Bind b
Rec (forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds')]
where
ind_env :: IndEnv
ind_env = CoreProgram -> IndEnv
makeIndEnv CoreProgram
binds
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
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
= []
| 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
=
[ (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
= if Id -> Bool
isExportedId Id
exported_id Bool -> Bool -> Bool
&&
Id -> Bool
isLocalId Id
local_id Bool -> Bool -> Bool
&&
Bool -> Bool
not (Id -> Bool
isExportedId Id
local_id) Bool -> Bool -> Bool
&&
Bool -> Bool
not (Id
local_id forall a. Id -> VarEnv a -> Bool
`elemVarEnv` IndEnv
ind_env)
then
if Id -> Bool
hasShortableIdInfo Id
exported_id
then Bool
True
else WARN( True, text "Not shorting out:" <+> ppr exported_id )
Bool
False
else
Bool
False
hasShortableIdInfo :: Id -> Bool
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
transferIdInfo :: Id -> Id -> (Id, Id)
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)
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
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