module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
import GHC.Driver.Env
import GHC.Platform.Ways ( hasWay, Way(WayProf) )
import GHC.Core
import GHC.Core.Opt.CSE ( cseProgram )
import GHC.Core.Rules ( mkRuleBase,
extendRuleBaseList, ruleCheckProgram, addRuleInfo,
getRules, initRuleOpts )
import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )
import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize )
import GHC.Core.Utils ( mkTicks, stripTicksTop, dumpIdInfoOfProgram )
import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult,
lintAnnots )
import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules )
import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.Monad
import GHC.Core.Opt.FloatIn ( floatInwards )
import GHC.Core.Opt.FloatOut ( floatOutwards )
import GHC.Core.Opt.LiberateCase ( liberateCase )
import GHC.Core.Opt.StaticArgs ( doStaticArgs )
import GHC.Core.Opt.Specialise ( specProgram)
import GHC.Core.Opt.SpecConstr ( specConstrProgram)
import GHC.Core.Opt.DmdAnal
import GHC.Core.Opt.CprAnal ( cprAnalProgram )
import GHC.Core.Opt.CallArity ( callArityAnalProgram )
import GHC.Core.Opt.Exitify ( exitifyProgram )
import GHC.Core.Opt.WorkWrap ( wwTopBinds )
import GHC.Core.Opt.CallerCC ( addCallerCostCentres )
import GHC.Core.LateCC (addLateCostCentresMG)
import GHC.Core.Seq (seqBinds)
import GHC.Core.FamInstEnv
import GHC.Utils.Error ( withTiming )
import GHC.Utils.Logger as Logger
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Trace
import GHC.Unit.External
import GHC.Unit.Module.Env
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.Deps
import GHC.Runtime.Context
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Basic
import GHC.Types.Demand ( zapDmdEnvSig )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Tickish
import GHC.Types.Unique.FM
import GHC.Types.Name.Ppr
import Control.Monad
import qualified GHC.LanguageExtensions as LangExt
import GHC.Unit.Module
core2core :: HscEnv -> ModGuts -> IO ModGuts
core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_loc = loc
, mg_deps = deps
, mg_rdr_env = rdr_env })
= do { let builtin_passes = getCoreToDo logger dflags
orph_mods = mkModuleSet (mod : dep_orphs deps)
uniq_mask = 's'
;
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod
orph_mods print_unqual loc $
do { hsc_env' <- getHscEnv
; all_passes <- withPlugins (hsc_plugins hsc_env')
installCoreToDos
builtin_passes
; runCorePasses all_passes guts }
; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
FormatText
(pprSimplCount stats)
; return guts2 }
where
logger = hsc_logger hsc_env
dflags = hsc_dflags hsc_env
home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
, gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env
getCoreToDo :: Logger -> DynFlags -> [CoreToDo]
getCoreToDo logger dflags
= flatten_todos core_todo
where
phases = simplPhases dflags
max_iter = maxSimplIterations dflags
rule_check = ruleCheck dflags
const_fold = gopt Opt_CoreConstantFolding dflags
call_arity = gopt Opt_CallArity dflags
exitification = gopt Opt_Exitification dflags
strictness = gopt Opt_Strictness dflags
full_laziness = gopt Opt_FullLaziness dflags
do_specialise = gopt Opt_Specialise dflags
do_float_in = gopt Opt_FloatIn dflags
cse = gopt Opt_CSE dflags
spec_constr = gopt Opt_SpecConstr dflags
liberate_case = gopt Opt_LiberateCase dflags
late_dmd_anal = gopt Opt_LateDmdAnal dflags
late_specialise = gopt Opt_LateSpecialise dflags
static_args = gopt Opt_StaticArgumentTransformation dflags
rules_on = gopt Opt_EnableRewriteRules dflags
eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
pre_inline_on = gopt Opt_SimplPreInlining dflags
ww_on = gopt Opt_WorkerWrapper dflags
static_ptrs = xopt LangExt.StaticPointers dflags
profiling = ways dflags `hasWay` WayProf
do_presimplify = do_specialise
do_simpl3 = const_fold || rules_on
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
maybe_strictness_before (Phase phase)
| phase `elem` strictnessBefore dflags = CoreDoDemand
maybe_strictness_before _
= CoreDoNothing
base_mode = SimplMode { sm_phase = panic "base_mode"
, sm_names = []
, sm_dflags = dflags
, sm_logger = logger
, sm_uf_opts = unfoldingOpts dflags
, sm_rules = rules_on
, sm_eta_expand = eta_expand_on
, sm_cast_swizzle = True
, sm_inline = True
, sm_case_case = True
, sm_pre_inline = pre_inline_on
}
simpl_phase phase name iter
= CoreDoPasses
$ [ maybe_strictness_before phase
, CoreDoSimplify iter
(base_mode { sm_phase = phase
, sm_names = [name] })
, maybe_rule_check phase ]
simplify name = simpl_phase FinalPhase name max_iter
simpl_gently = CoreDoSimplify max_iter
(base_mode { sm_phase = InitialPhase
, sm_names = ["Gentle"]
, sm_rules = rules_on
, sm_inline = True
, sm_case_case = False })
dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper]
else [CoreDoDemand,CoreDoCpr]
demand_analyser = (CoreDoPasses (
dmd_cpr_ww ++
[simplify "post-worker-wrapper"]
))
static_ptrs_float_outwards =
runWhen static_ptrs $ CoreDoPasses
[ simpl_gently
, CoreDoFloatOutwards FloatOutSwitches
{ floatOutLambdas = Just 0
, floatOutConstants = True
, floatOutOverSatApps = False
, floatToTopLevelOnly = True
}
]
add_caller_ccs =
runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs
add_late_ccs =
runWhen (profiling && gopt Opt_ProfLateInlineCcs dflags) $ CoreAddLateCcs
core_todo =
[
runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
runWhen do_presimplify simpl_gently,
runWhen do_specialise CoreDoSpecialising,
if full_laziness then
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas = Just 0,
floatOutConstants = True,
floatOutOverSatApps = False,
floatToTopLevelOnly = False }
else
static_ptrs_float_outwards,
runWhen do_simpl3
(CoreDoPasses $ [ simpl_phase (Phase phase) "main" max_iter
| phase <- [phases, phases1 .. 1] ] ++
[ simpl_phase (Phase 0) "main" (max max_iter 3) ]),
runWhen do_float_in CoreDoFloatInwards,
runWhen call_arity $ CoreDoPasses
[ CoreDoCallArity
, simplify "post-call-arity"
],
runWhen strictness demand_analyser,
runWhen exitification CoreDoExitify,
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas = floatLamArgs dflags,
floatOutConstants = True,
floatOutOverSatApps = True,
floatToTopLevelOnly = False },
runWhen cse CoreCSE,
runWhen do_float_in CoreDoFloatInwards,
simplify "final",
maybe_rule_check FinalPhase,
runWhen liberate_case $ CoreDoPasses
[ CoreLiberateCase, simplify "post-liberate-case" ],
runWhen spec_constr $ CoreDoPasses
[ CoreDoSpecConstr, simplify "post-spec-constr"],
maybe_rule_check FinalPhase,
runWhen late_specialise $ CoreDoPasses
[ CoreDoSpecialising, simplify "post-late-spec"],
runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses
[ CoreCSE, simplify "post-final-cse" ],
runWhen late_dmd_anal $ CoreDoPasses (
dmd_cpr_ww ++ [simplify "post-late-ww"]
),
runWhen (strictness || late_dmd_anal) CoreDoDemand,
maybe_rule_check FinalPhase,
add_caller_ccs,
add_late_ccs
]
flatten_todos [] = []
flatten_todos (CoreDoNothing : rest) = flatten_todos rest
flatten_todos (CoreDoPasses passes : rest) =
flatten_todos passes ++ flatten_todos rest
flatten_todos (todo : rest) = todo : flatten_todos rest
runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses passes guts
= foldM do_pass guts passes
where
do_pass guts CoreDoNothing = return guts
do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
do_pass guts pass = do
logger <- getLogger
withTiming logger (ppr pass <+> brackets (ppr mod))
(const ()) $ do
guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
endPass pass (mg_binds guts') (mg_rules guts')
return guts'
mod = mg_module guts
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass pass guts = do
logger <- getLogger
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' }
case pass of
CoreDoSimplify {} ->
simplifyPgm pass guts
CoreCSE ->
updateBinds cseProgram
CoreLiberateCase ->
updateBinds (liberateCase dflags)
CoreDoFloatInwards ->
updateBinds (floatInwards platform)
CoreDoFloatOutwards f ->
updateBindsM (liftIO . floatOutwards logger f us)
CoreDoStaticArgs ->
updateBinds (doStaticArgs us)
CoreDoCallArity ->
updateBinds callArityAnalProgram
CoreDoExitify ->
updateBinds exitifyProgram
CoreDoDemand ->
updateBindsM (liftIO . dmdAnal logger dflags fam_envs (mg_rules guts))
CoreDoCpr ->
updateBindsM (liftIO . cprAnalProgram logger fam_envs)
CoreDoWorkerWrapper ->
updateBinds (wwTopBinds (mg_module guts) dflags fam_envs us)
CoreDoSpecialising ->
specProgram guts
CoreDoSpecConstr ->
specConstrProgram guts
CoreAddCallerCcs ->
addCallerCostCentres guts
CoreAddLateCcs ->
addLateCostCentresMG guts
CoreDoPrintCore ->
liftIO $ printCore logger (mg_binds guts) >> return guts
CoreDoRuleCheck phase pat ->
ruleCheckPass phase pat guts
CoreDoNothing -> return guts
CoreDoPasses passes -> runCorePasses passes guts
CoreDoPluginPass _ p -> p guts
CoreDesugar -> pprPanic "doCorePass" (ppr pass)
CoreDesugarOpt -> pprPanic "doCorePass" (ppr pass)
CoreTidy -> pprPanic "doCorePass" (ppr pass)
CorePrep -> pprPanic "doCorePass" (ppr pass)
CoreOccurAnal -> pprPanic "doCorePass" (ppr pass)
printCore :: Logger -> CoreProgram -> IO ()
printCore logger binds
= Logger.logDumpMsg logger "Print Core" (pprCoreBindings binds)
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass current_phase pat guts = do
dflags <- getDynFlags
logger <- getLogger
withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
(const ()) $ do
rb <- getRuleBase
vis_orphs <- getVisibleOrphanMods
let rule_fn fn = getRules (RuleEnv [rb] vis_orphs) fn
++ (mg_rules guts)
let ropts = initRuleOpts dflags
liftIO $ logDumpMsg logger "Rule check"
(ruleCheckProgram ropts current_phase pat
rule_fn (mg_binds guts))
return guts
simplifyExpr :: HscEnv
-> CoreExpr
-> IO CoreExpr
simplifyExpr hsc_env expr
= withTiming logger (text "Simplify [expr]") (const ()) $
do { eps <- hscEPS hsc_env ;
; let fi_env = ( eps_fam_inst_env eps
, extendFamInstEnvList emptyFamInstEnv $
snd $ ic_instances $ hsc_IC hsc_env )
simpl_env = simplEnvForGHCi logger dflags
; let sz = exprSize expr
; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env sz $
simplExprGently simpl_env expr
; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats
"Simplifier statistics" FormatText (pprSimplCount counts)
; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression"
FormatCore
(pprCoreExpr expr')
; return expr'
}
where
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExprGently env expr = do
expr1 <- simplExpr env (occurAnalyseExpr expr)
simplExpr env (occurAnalyseExpr expr1)
simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm pass guts
= do { hsc_env <- getHscEnv
; rb <- getRuleBase
; liftIOWithCount $
simplifyPgmIO pass hsc_env rb guts }
simplifyPgmIO :: CoreToDo
-> HscEnv
-> RuleBase
-> ModGuts
-> IO (SimplCount, ModGuts)
simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
hsc_env hpt_rule_base
guts@(ModGuts { mg_module = this_mod
, mg_rdr_env = rdr_env
, mg_deps = deps
, mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
= do { (termination_msg, it_count, counts_out, guts')
<- do_iteration 1 [] binds rules
; when (logHasDumpFlag logger Opt_D_verbose_core2core
&& logHasDumpFlag logger Opt_D_dump_simpl_stats) $
logDumpMsg logger
"Simplifier statistics for following pass"
(vcat [text termination_msg <+> text "after" <+> ppr it_count
<+> text "iterations",
blankLine,
pprSimplCount counts_out])
; return (counts_out, guts')
}
where
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env
simpl_env = mkSimplEnv mode
active_rule = activeRule mode
active_unf = activeUnfolding mode
do_iteration :: Int --UniqSupply
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> IO (String, Int, SimplCount, ModGuts)
do_iteration iteration_no counts_so_far binds rules
| iteration_no > max_iterations
= warnPprTrace (debugIsOn && (max_iterations > 2))
"Simplifier bailing out"
( hang (ppr this_mod <> text ", after"
<+> int max_iterations <+> text "iterations"
<+> (brackets $ hsep $ punctuate comma $
map (int . simplCountN) (reverse counts_so_far)))
2 (text "Size =" <+> ppr (coreBindsStats binds))) $
return ( "Simplifier baled out", iteration_no 1
, totalise counts_so_far
, guts { mg_binds = binds, mg_rules = rules } )
| let sz = coreBindsSize binds
, () <- sz `seq` ()
= do {
let { tagged_binds =
occurAnalysePgm this_mod active_unf active_rule rules
binds
} ;
Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
FormatCore
(pprCoreBindings tagged_binds);
eps <- hscEPS hsc_env ;
let { read_eps_rules = eps_rule_base <$> hscEPS hsc_env
; rule_base = extendRuleBaseList hpt_rule_base rules
; fam_envs = (eps_fam_inst_env eps, fam_inst_env)
; vis_orphs = this_mod : dep_orphs deps } ;
((binds1, rules1), counts1) <-
initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs sz $
do { (floats, env1) <-
simplTopBinds simpl_env tagged_binds
; rules1 <- simplImpRules env1 rules
; return (getTopFloatBinds floats, rules1) } ;
if isZeroSimplCount counts1 then
return ( "Simplifier reached fixed point", iteration_no
, totalise (counts1 : counts_so_far)
, guts { mg_binds = binds1, mg_rules = rules1 } )
else do {
let { binds2 = shortOutIndirections binds1 } ;
let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ;
dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ;
lintPassResult hsc_env pass binds2 ;
do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
} }
#if __GLASGOW_HASKELL__ <= 810
| otherwise = panic "do_iteration"
#endif
where
totalise :: [SimplCount] -> SimplCount
totalise = foldr (\c acc -> acc `plusSimplCount` c)
(zeroSimplCount dflags)
simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO"
dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int
-> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules
= dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules
where
mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations
| otherwise = Nothing
hdr = "Simplifier iteration=" ++ show iteration_no
pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr
, pprSimplCount counts
, text "---- End of simplifier counts for" <+> text hdr ]
type IndEnv = IdEnv (Id, [CoreTickish])
shortOutIndirections :: CoreProgram -> CoreProgram
shortOutIndirections binds
| isEmptyVarEnv ind_env = binds
| no_need_to_flatten = binds'
| otherwise = [Rec (flattenBinds binds')]
where
ind_env = makeIndEnv binds
exp_ids = map fst $ nonDetEltsUFM ind_env
exp_id_set = mkVarSet exp_ids
no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids
binds' = concatMap zap binds
zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
zapPair (bndr, rhs)
| bndr `elemVarSet` exp_id_set
= []
| Just (exp_id, ticks) <- lookupVarEnv ind_env bndr
, (exp_id', lcl_id') <- transferIdInfo exp_id bndr
=
[ (exp_id', mkTicks ticks rhs),
(lcl_id', Var exp_id') ]
| otherwise
= [(bndr,rhs)]
makeIndEnv :: [CoreBind] -> IndEnv
makeIndEnv binds
= foldl' add_bind emptyVarEnv binds
where
add_bind :: IndEnv -> CoreBind -> IndEnv
add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)
add_bind env (Rec pairs) = foldl' add_pair env pairs
add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv
add_pair env (exported_id, exported)
| (ticks, Var local_id) <- stripTicksTop tickishFloatable exported
, shortMeOut env exported_id local_id
= extendVarEnv env local_id (exported_id, ticks)
add_pair env _ = env
shortMeOut :: IndEnv -> Id -> Id -> Bool
shortMeOut ind_env exported_id local_id
= if isExportedId exported_id &&
isLocalId local_id &&
not (isExportedId local_id) &&
not (local_id `elemVarEnv` ind_env)
then
if hasShortableIdInfo exported_id
then True
else warnPprTrace True "Not shorting out" (ppr exported_id) False
else
False
hasShortableIdInfo :: Id -> Bool
hasShortableIdInfo id
= isEmptyRuleInfo (ruleInfo info)
&& isDefaultInlinePragma (inlinePragInfo info)
&& not (isStableUnfolding (realUnfoldingInfo info))
where
info = idInfo id
transferIdInfo :: Id -> Id -> (Id, Id)
transferIdInfo exported_id local_id
= ( modifyIdInfo transfer exported_id
, modifyIdInfo zap_info local_id )
where
local_info = idInfo local_id
transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info
`setCprSigInfo` cprSigInfo local_info
`setUnfoldingInfo` realUnfoldingInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
`setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info
new_info = setRuleInfoHead (idName exported_id)
(ruleInfo local_info)
zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma
`setUnfoldingInfo` noUnfolding
dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
dmdAnal logger dflags fam_envs rules binds = do
let !opts = DmdAnalOpts
{ dmd_strict_dicts = gopt Opt_DictsStrict dflags
, dmd_unbox_width = dmdUnboxWidth dflags
, dmd_max_worker_args = maxWorkerArgs dflags
}
binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds
Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $
dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds
seqBinds binds_plus_dmds `seq` return binds_plus_dmds