module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
import DynFlags
import CoreSyn
import HscTypes
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo
import CoreUtils ( coreBindsSize, coreBindsStats, exprSize,
mkTicks, stripTicksTop )
import CoreLint ( showPass, endPass, lintPassResult, dumpPassResult,
lintAnnots )
import Simplify ( simplTopBinds, simplExpr, simplRule )
import SimplUtils ( simplEnvForGHCi, activeRule )
import SimplEnv
import SimplMonad
import CoreMonad
import qualified ErrUtils as Err
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FamInstEnv
import Id
import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma )
import VarSet
import VarEnv
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
import SpecConstr ( specConstrProgram)
import DmdAnal ( dmdAnalProgram )
import CallArity ( callArityAnalProgram )
import WorkWrap ( wwTopBinds )
import Vectorise ( vectorise )
import FastString
import SrcLoc
import Util
import Maybes
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import Outputable
import Control.Monad
#ifdef GHCI
import DynamicLoading ( loadPlugins )
import Plugins ( installCoreToDos )
#endif
core2core :: HscEnv -> ModGuts -> IO ModGuts
core2core hsc_env guts
= do { us <- mkSplitUniqSupply 's'
; let builtin_passes = getCoreToDo dflags
;
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $
do { all_passes <- addPluginPasses builtin_passes
; runCorePasses all_passes guts }
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
(pprSimplCount stats)
; return guts2 }
where
dflags = hsc_dflags hsc_env
home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
hpt_rule_base = mkRuleBase home_pkg_rules
mod = mg_module guts
print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo dflags
= core_todo
where
opt_level = optLevel dflags
phases = simplPhases dflags
max_iter = maxSimplIterations dflags
rule_check = ruleCheck dflags
call_arity = gopt Opt_CallArity 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
static_args = gopt Opt_StaticArgumentTransformation dflags
rules_on = gopt Opt_EnableRewriteRules dflags
eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
maybe_strictness_before phase
= runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
base_mode = SimplMode { sm_phase = panic "base_mode"
, sm_names = []
, sm_rules = rules_on
, sm_eta_expand = eta_expand_on
, sm_inline = True
, sm_case_case = True }
simpl_phase phase names iter
= CoreDoPasses
$ [ maybe_strictness_before phase
, CoreDoSimplify iter
(base_mode { sm_phase = Phase phase
, sm_names = names })
, maybe_rule_check (Phase phase) ]
++ (if gopt Opt_Vectorise dflags && phase == 3
then [CoreCSE, simpl_gently]
else [])
vectorisation
= runWhen (gopt Opt_Vectorise dflags) $
CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
| phase <- [phases, phases1 .. 1] ]
simpl_gently = CoreDoSimplify max_iter
(base_mode { sm_phase = InitialPhase
, sm_names = ["Gentle"]
, sm_rules = rules_on
, sm_inline = False
, sm_case_case = False })
demand_analyser = (CoreDoPasses ([
CoreDoStrictness,
CoreDoWorkerWrapper,
simpl_phase 0 ["post-worker-wrapper"] max_iter
]))
core_todo =
if opt_level == 0 then
[ vectorisation
, CoreDoSimplify max_iter
(base_mode { sm_phase = Phase 0
, sm_names = ["Non-opt simplification"] })
]
else [
runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
vectorisation,
simpl_gently,
runWhen do_specialise CoreDoSpecialising,
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas = Just 0,
floatOutConstants = True,
floatOutOverSatApps = False },
simpl_phases,
simpl_phase 0 ["main"] (max max_iter 3),
runWhen do_float_in CoreDoFloatInwards,
runWhen call_arity $ CoreDoPasses
[ CoreDoCallArity
, simpl_phase 0 ["post-call-arity"] max_iter
],
runWhen strictness demand_analyser,
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas = floatLamArgs dflags,
floatOutConstants = True,
floatOutOverSatApps = True },
runWhen cse CoreCSE,
runWhen do_float_in CoreDoFloatInwards,
maybe_rule_check (Phase 0),
runWhen liberate_case (CoreDoPasses [
CoreLiberateCase,
simpl_phase 0 ["post-liberate-case"] max_iter
]),
runWhen spec_constr CoreDoSpecConstr,
maybe_rule_check (Phase 0),
simpl_phase 0 ["final"] max_iter,
runWhen late_dmd_anal $ CoreDoPasses [
CoreDoStrictness,
CoreDoWorkerWrapper,
simpl_phase 0 ["post-late-ww"] max_iter
],
maybe_rule_check (Phase 0)
]
addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo]
#ifndef GHCI
addPluginPasses builtin_passes = return builtin_passes
#else
addPluginPasses builtin_passes
= do { hsc_env <- getHscEnv
; named_plugins <- liftIO (loadPlugins hsc_env)
; foldM query_plug builtin_passes named_plugins }
where
query_plug todos (_, plug, options) = installCoreToDos plug options todos
#endif
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 { showPass pass
; guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
; endPass pass (mg_binds guts') (mg_rules guts')
; return guts' }
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass pass@(CoreDoSimplify {}) =
simplifyPgm pass
doCorePass CoreCSE =
doPass cseProgram
doCorePass CoreLiberateCase =
doPassD liberateCase
doCorePass CoreDoFloatInwards =
doPassD floatInwards
doCorePass (CoreDoFloatOutwards f) =
doPassDUM (floatOutwards f)
doCorePass CoreDoStaticArgs =
doPassU doStaticArgs
doCorePass CoreDoCallArity =
doPassD callArityAnalProgram
doCorePass CoreDoStrictness =
doPassDFM dmdAnalProgram
doCorePass CoreDoWorkerWrapper =
doPassDFU wwTopBinds
doCorePass CoreDoSpecialising =
specProgram
doCorePass CoreDoSpecConstr =
specConstrProgram
doCorePass CoreDoVectorisation =
vectorise
doCorePass CoreDoPrintCore = observe printCore
doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat
doCorePass CoreDoNothing = return
doCorePass (CoreDoPasses passes) = runCorePasses passes
#ifdef GHCI
doCorePass (CoreDoPluginPass _ pass) = pass
#endif
doCorePass pass = pprPanic "doCorePass" (ppr pass)
printCore :: DynFlags -> CoreProgram -> IO ()
printCore dflags binds
= Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass current_phase pat guts = do
rb <- getRuleBase
dflags <- getDynFlags
liftIO $ Err.showPass dflags "RuleCheck"
liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
(ruleCheckProgram current_phase pat rb (mg_binds guts))
return guts
doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDUM do_pass = doPassM $ \binds -> do
dflags <- getDynFlags
us <- getUniqueSupplyM
liftIO $ do_pass dflags us binds
doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassU do_pass = doPassDU (const do_pass)
doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDFM do_pass guts = do
dflags <- getDynFlags
p_fam_env <- getPackageFamInstEnv
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
doPassM (liftIO . do_pass dflags fam_envs) guts
doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDFU do_pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
doPass (do_pass dflags fam_envs us) guts
doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
doPassM bind_f guts = do
binds' <- bind_f (mg_binds guts)
return (guts { mg_binds = binds' })
doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
observe do_pass = doPassM $ \binds -> do
dflags <- getDynFlags
_ <- liftIO $ do_pass dflags binds
return binds
simplifyExpr :: DynFlags
-> CoreExpr
-> IO CoreExpr
simplifyExpr dflags expr
= do {
; Err.showPass dflags "Simplify"
; us <- mkSplitUniqSupply 's'
; let sz = exprSize expr
; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
simplExprGently (simplEnvForGHCi dflags) expr
; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics" (pprSimplCount counts)
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
; return expr'
}
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
; us <- getUniqueSupplyM
; rb <- getRuleBase
; liftIOWithCount $
simplifyPgmIO pass hsc_env us rb guts }
simplifyPgmIO :: CoreToDo
-> HscEnv
-> UniqSupply
-> RuleBase
-> ModGuts
-> IO (SimplCount, ModGuts)
simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
hsc_env us hpt_rule_base
guts@(ModGuts { mg_module = this_mod
, mg_rdr_env = rdr_env
, mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
= do { (termination_msg, it_count, counts_out, guts')
<- do_iteration us 1 [] binds rules
; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&
dopt Opt_D_dump_simpl_stats dflags)
"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
print_unqual = mkPrintUnqualified dflags rdr_env
simpl_env = mkSimplEnv mode
active_rule = activeRule simpl_env
do_iteration :: UniqSupply
-> Int
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> IO (String, Int, SimplCount, ModGuts)
do_iteration us iteration_no counts_so_far binds rules
| iteration_no > max_iterations
= WARN( debugIsOn && (max_iterations > 2)
, hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations
<+> ptext (sLit "iterations")
<+> (brackets $ hsep $ punctuate comma $
map (int . simplCountN) (reverse counts_so_far)))
2 (ptext (sLit "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 == sz
= do {
let {
vectVars = mkVarSet $
catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr
| Vect bndr _ <- mg_vect_decls guts]
++
catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr
| bndr <- bindersOfBinds binds]
; (maybeVects, maybeVectVars)
= case sm_phase mode of
InitialPhase -> (mg_vect_decls guts, vectVars)
_ -> ([], vectVars)
; tagged_binds =
occurAnalysePgm this_mod active_rule rules maybeVects maybeVectVars binds
} ;
Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
eps <- hscEPS hsc_env ;
let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
; rule_base2 = extendRuleBaseList rule_base1 rules
; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
((binds1, rules1), counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz $
do { env1 <-
simplTopBinds simpl_env tagged_binds
; rules1 <- mapM (simplRule env1 Nothing) rules
; return (getFloatBinds env1, 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 } ;
dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
lintPassResult hsc_env pass binds2 ;
do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
} }
| otherwise = panic "do_iteration"
where
(us1, us2) = splitUniqSupply us
totalise :: [SimplCount] -> SimplCount
totalise = foldr (\c acc -> acc `plusSimplCount` c)
(zeroSimplCount dflags)
simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
dump_end_iteration :: DynFlags -> PrintUnqualified -> Int
-> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
dump_end_iteration dflags print_unqual iteration_no counts binds rules
= dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules
where
mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations
| otherwise = Nothing
hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no
pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr
, pprSimplCount counts
, ptext (sLit "---- End of simplifier counts for") <+> hdr ]
type IndEnv = IdEnv (Id, [Tickish Var])
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 $ varEnvElts ind_env
exp_id_set = mkVarSet exp_ids
no_need_to_flatten = all (null . specInfoRules . 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
= [(transferIdInfo exp_id bndr,
mkTicks ticks rhs),
(bndr, Var exp_id)]
| otherwise = [(bndr,rhs)]
makeIndEnv :: [CoreBind] -> IndEnv
makeIndEnv binds
= foldr add_bind emptyVarEnv binds
where
add_bind :: CoreBind -> IndEnv -> IndEnv
add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
add_bind (Rec pairs) env = foldr add_pair env pairs
add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
add_pair (exported_id, exported) env
| (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 WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
False
else
False
hasShortableIdInfo :: Id -> Bool
hasShortableIdInfo id
= isEmptySpecInfo (specInfo info)
&& isDefaultInlinePragma (inlinePragInfo info)
&& not (isStableUnfolding (unfoldingInfo info))
where
info = idInfo id
transferIdInfo :: Id -> Id -> Id
transferIdInfo exported_id local_id
= modifyIdInfo transfer exported_id
where
local_info = idInfo local_id
transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
`setUnfoldingInfo` unfoldingInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
`setSpecInfo` addSpecInfo (specInfo exp_info) new_info
new_info = setSpecInfoHead (idName exported_id)
(specInfo local_info)