{-# LANGUAGE CPP #-}
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.Driver.Config.Core.Lint ( endPass )
import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode )
import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts )
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
import GHC.Platform.Ways ( hasWay, Way(WayProf) )
import GHC.Core
import GHC.Core.Opt.CSE ( cseProgram )
import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules )
import GHC.Core.Ppr ( pprCoreBindings )
import GHC.Core.Utils ( dumpIdInfoOfProgram )
import GHC.Core.Lint ( lintAnnots )
import GHC.Core.Lint.Interactive ( interactiveInScope )
import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm )
import GHC.Core.Opt.Simplify.Env( SimplMode(..) )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.Monad
import GHC.Core.Opt.Pipeline.Types
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.Unit.Module.ModGuts
import GHC.Types.Id.Info
import GHC.Types.Basic
import GHC.Types.Demand ( zapDmdEnvSig )
import GHC.Types.Name.Ppr
import GHC.Types.Var ( Var )
import Control.Monad
import qualified GHC.LanguageExtensions as LangExt
import GHC.Unit.Module
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_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env })
= do { let builtin_passes :: [CoreToDo]
builtin_passes = DynFlags -> RuleBase -> [CoreBndr] -> [CoreToDo]
getCoreToDo DynFlags
dflags RuleBase
hpt_rule_base [CoreBndr]
extra_vars
uniq_mask :: Char
uniq_mask = Char
's'
; (ModGuts
guts2, SimplCount
stats) <- HscEnv
-> RuleBase
-> Char
-> Module
-> NamePprCtx
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount)
forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> NamePprCtx
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM HscEnv
hsc_env RuleBase
hpt_rule_base Char
uniq_mask Module
mod
NamePprCtx
name_ppr_ctx 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
; [CoreToDo]
all_passes <- Plugins
-> PluginOperation CoreM [CoreToDo]
-> [CoreToDo]
-> CoreM [CoreToDo]
forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env')
PluginOperation CoreM [CoreToDo]
installCoreToDos
[CoreToDo]
builtin_passes
; [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
all_passes ModGuts
guts }
; Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_simpl_stats
String
"Grand total simplifier statistics"
DumpFormat
FormatText
(SimplCount -> SDoc
pprSimplCount SimplCount
stats)
; ModGuts -> IO ModGuts
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts2 }
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
extra_vars :: [CoreBndr]
extra_vars = InteractiveContext -> [CoreBndr]
interactiveInScope (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
home_pkg_rules :: [CoreRule]
home_pkg_rules = HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
hptRules HscEnv
hsc_env (Module -> UnitId
moduleUnitId Module
mod) (GWIB { gwib_mod :: ModuleName
gwib_mod = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod
, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot })
hpt_rule_base :: RuleBase
hpt_rule_base = [CoreRule] -> RuleBase
mkRuleBase [CoreRule]
home_pkg_rules
name_ppr_ctx :: NamePprCtx
name_ppr_ctx = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env
ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext DynFlags
dflags
getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo]
getCoreToDo :: DynFlags -> RuleBase -> [CoreBndr] -> [CoreToDo]
getCoreToDo DynFlags
dflags RuleBase
hpt_rule_base [CoreBndr]
extra_vars
= [CoreToDo] -> [CoreToDo]
flatten_todos [CoreToDo]
core_todo
where
phases :: PhaseNum
phases = DynFlags -> PhaseNum
simplPhases DynFlags
dflags
max_iter :: PhaseNum
max_iter = DynFlags -> PhaseNum
maxSimplIterations DynFlags
dflags
rule_check :: Maybe String
rule_check = DynFlags -> Maybe String
ruleCheck DynFlags
dflags
const_fold :: Bool
const_fold = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CoreConstantFolding 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
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
do_presimplify :: Bool
do_presimplify = Bool
do_specialise
do_simpl3 :: Bool
do_simpl3 = Bool
const_fold Bool -> Bool -> Bool
|| Bool
rules_on
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 :: CompilerPhase -> CoreToDo
maybe_strictness_before (Phase PhaseNum
phase)
| PhaseNum
phase PhaseNum -> [PhaseNum] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [PhaseNum]
strictnessBefore DynFlags
dflags = Bool -> CoreToDo
CoreDoDemand Bool
False
maybe_strictness_before CompilerPhase
_
= CoreToDo
CoreDoNothing
base_simpl_mode :: SimplMode
base_simpl_mode :: SimplMode
base_simpl_mode = DynFlags -> SimplMode
initSimplMode DynFlags
dflags
gentle_mode :: SimplMode
gentle_mode = SimplMode
base_simpl_mode { sm_names = ["Gentle"]
, sm_phase = InitialPhase
, sm_case_case = False }
simpl_mode :: CompilerPhase -> String -> SimplMode
simpl_mode CompilerPhase
phase String
name
= SimplMode
base_simpl_mode { sm_names = [name], sm_phase = phase }
keep_exits :: SimplMode -> SimplMode
keep_exits :: SimplMode -> SimplMode
keep_exits SimplMode
mode = SimplMode
mode { sm_keep_exits = True }
run_simplifier :: SimplMode -> PhaseNum -> CoreToDo
run_simplifier SimplMode
mode PhaseNum
iter
= SimplifyOpts -> CoreToDo
CoreDoSimplify (SimplifyOpts -> CoreToDo) -> SimplifyOpts -> CoreToDo
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [CoreBndr] -> PhaseNum -> SimplMode -> RuleBase -> SimplifyOpts
initSimplifyOpts DynFlags
dflags [CoreBndr]
extra_vars PhaseNum
iter SimplMode
mode RuleBase
hpt_rule_base
simpl_phase :: CompilerPhase -> String -> PhaseNum -> CoreToDo
simpl_phase CompilerPhase
phase String
name PhaseNum
iter = [CoreToDo] -> CoreToDo
CoreDoPasses ([CoreToDo] -> CoreToDo) -> [CoreToDo] -> CoreToDo
forall a b. (a -> b) -> a -> b
$
[ CompilerPhase -> CoreToDo
maybe_strictness_before CompilerPhase
phase
, SimplMode -> PhaseNum -> CoreToDo
run_simplifier (CompilerPhase -> String -> SimplMode
simpl_mode CompilerPhase
phase String
name) PhaseNum
iter
, CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
phase ]
simpl_gently :: CoreToDo
simpl_gently = SimplMode -> PhaseNum -> CoreToDo
run_simplifier SimplMode
gentle_mode PhaseNum
max_iter
simplify_final :: String -> CoreToDo
simplify_final String
name = SimplMode -> PhaseNum -> CoreToDo
run_simplifier ( CompilerPhase -> String -> SimplMode
simpl_mode CompilerPhase
FinalPhase String
name) PhaseNum
max_iter
simpl_keep_exits :: String -> CoreToDo
simpl_keep_exits String
name = SimplMode -> PhaseNum -> CoreToDo
run_simplifier (SimplMode -> SimplMode
keep_exits (SimplMode -> SimplMode) -> SimplMode -> SimplMode
forall a b. (a -> b) -> a -> b
$ CompilerPhase -> String -> SimplMode
simpl_mode CompilerPhase
FinalPhase String
name) PhaseNum
max_iter
dmd_cpr_ww :: [CoreToDo]
dmd_cpr_ww = if Bool
ww_on then [Bool -> CoreToDo
CoreDoDemand Bool
True,CoreToDo
CoreDoCpr,CoreToDo
CoreDoWorkerWrapper]
else [Bool -> CoreToDo
CoreDoDemand Bool
False]
static_ptrs_float_outwards :: CoreToDo
static_ptrs_float_outwards =
Bool -> CoreToDo -> CoreToDo
runWhen Bool
static_ptrs (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
[ CoreToDo
simpl_gently
, FloatOutSwitches -> CoreToDo
CoreDoFloatOutwards FloatOutSwitches
{ floatOutLambdas :: Maybe PhaseNum
floatOutLambdas = PhaseNum -> Maybe PhaseNum
forall a. a -> Maybe a
Just PhaseNum
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 ([CallerCcFilter] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CallerCcFilter] -> Bool) -> [CallerCcFilter] -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> [CallerCcFilter]
callerCcFilters DynFlags
dflags)) CoreToDo
CoreAddCallerCcs
add_late_ccs :: CoreToDo
add_late_ccs =
Bool -> CoreToDo -> CoreToDo
runWhen (Bool
profiling Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateInlineCcs DynFlags
dflags) (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ CoreToDo
CoreAddLateCcs
core_todo :: [CoreToDo]
core_todo =
[
Bool -> CoreToDo -> CoreToDo
runWhen Bool
static_args ([CoreToDo] -> CoreToDo
CoreDoPasses [ CoreToDo
simpl_gently, CoreToDo
CoreDoStaticArgs ]),
Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_presimplify CoreToDo
simpl_gently,
Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_specialise CoreToDo
CoreDoSpecialising,
if Bool
full_laziness then
FloatOutSwitches -> CoreToDo
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas :: Maybe PhaseNum
floatOutLambdas = PhaseNum -> Maybe PhaseNum
forall a. a -> Maybe a
Just PhaseNum
0,
floatOutConstants :: Bool
floatOutConstants = Bool
True,
floatOutOverSatApps :: Bool
floatOutOverSatApps = Bool
False,
floatToTopLevelOnly :: Bool
floatToTopLevelOnly = Bool
False }
else
CoreToDo
static_ptrs_float_outwards,
Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_simpl3
([CoreToDo] -> CoreToDo
CoreDoPasses ([CoreToDo] -> CoreToDo) -> [CoreToDo] -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [ CompilerPhase -> String -> PhaseNum -> CoreToDo
simpl_phase (PhaseNum -> CompilerPhase
Phase PhaseNum
phase) String
"main" PhaseNum
max_iter
| PhaseNum
phase <- [PhaseNum
phases, PhaseNum
phasesPhaseNum -> PhaseNum -> PhaseNum
forall a. Num a => a -> a -> a
-PhaseNum
1 .. PhaseNum
1] ] [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++
[ CompilerPhase -> String -> PhaseNum -> CoreToDo
simpl_phase (PhaseNum -> CompilerPhase
Phase PhaseNum
0) String
"main" (PhaseNum -> PhaseNum -> PhaseNum
forall a. Ord a => a -> a -> a
max PhaseNum
max_iter PhaseNum
3) ]),
Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_float_in CoreToDo
CoreDoFloatInwards,
Bool -> CoreToDo -> CoreToDo
runWhen Bool
call_arity (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
[ CoreToDo
CoreDoCallArity
, String -> CoreToDo
simplify_final String
"post-call-arity"
],
Bool -> CoreToDo -> CoreToDo
runWhen Bool
strictness (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
([CoreToDo]
dmd_cpr_ww [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [String -> CoreToDo
simplify_final String
"post-worker-wrapper"]),
Bool -> CoreToDo -> CoreToDo
runWhen Bool
exitification CoreToDo
CoreDoExitify,
Bool -> CoreToDo -> CoreToDo
runWhen Bool
full_laziness (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$
FloatOutSwitches -> CoreToDo
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas :: Maybe PhaseNum
floatOutLambdas = DynFlags -> Maybe PhaseNum
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
simpl_keep_exits String
"final tidy up",
CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,
Bool -> CoreToDo -> CoreToDo
runWhen Bool
liberate_case (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
[ CoreToDo
CoreLiberateCase, String -> CoreToDo
simplify_final String
"post-liberate-case" ],
Bool -> CoreToDo -> CoreToDo
runWhen Bool
spec_constr (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
[ CoreToDo
CoreDoSpecConstr, String -> CoreToDo
simplify_final String
"post-spec-constr"],
CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,
Bool -> CoreToDo -> CoreToDo
runWhen Bool
late_specialise (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
[ CoreToDo
CoreDoSpecialising, String -> CoreToDo
simplify_final String
"post-late-spec"],
Bool -> CoreToDo -> CoreToDo
runWhen ((Bool
liberate_case Bool -> Bool -> Bool
|| Bool
spec_constr) Bool -> Bool -> Bool
&& Bool
cse) (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
[ CoreToDo
CoreCSE, String -> CoreToDo
simplify_final String
"post-final-cse" ],
Bool -> CoreToDo -> CoreToDo
runWhen Bool
late_dmd_anal (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses (
[CoreToDo]
dmd_cpr_ww [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [String -> CoreToDo
simplify_final String
"post-late-ww"]
),
Bool -> CoreToDo -> CoreToDo
runWhen (Bool
strictness Bool -> Bool -> Bool
|| Bool
late_dmd_anal) (Bool -> CoreToDo
CoreDoDemand Bool
False),
CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,
CoreToDo
add_caller_ccs,
CoreToDo
add_late_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 [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
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen Bool
True CoreToDo
do_this = CoreToDo
do_this
runWhen Bool
False CoreToDo
_ = CoreToDo
CoreDoNothing
runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe :: forall a. Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe (Just a
x) a -> CoreToDo
f = a -> CoreToDo
f a
x
runMaybe Maybe a
Nothing a -> CoreToDo
_ = CoreToDo
CoreDoNothing
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 a. a -> CoreM a
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
Logger
logger <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
Logger -> SDoc -> (ModGuts -> ()) -> CoreM ModGuts -> CoreM ModGuts
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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 a. a -> CoreM a
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 <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
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 platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
let fam_envs :: (PackageFamInstEnv, PackageFamInstEnv)
fam_envs = (PackageFamInstEnv
p_fam_env, ModGuts -> PackageFamInstEnv
mg_fam_inst_env ModGuts
guts)
let updateBinds :: (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds CoreProgram -> CoreProgram
f = ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
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 = f (mg_binds guts) }
let updateBindsM :: (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM CoreProgram -> CoreM CoreProgram
f = CoreProgram -> CoreM CoreProgram
f (ModGuts -> CoreProgram
mg_binds ModGuts
guts) CoreM CoreProgram
-> (CoreProgram -> CoreM ModGuts) -> CoreM ModGuts
forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CoreProgram
b' -> ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
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 = b' }
let name_ppr_ctx :: NamePprCtx
name_ppr_ctx =
PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
mkNamePprCtx
(DynFlags -> PromotionTickContext
initPromotionTickContext DynFlags
dflags)
(HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
(ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts)
case CoreToDo
pass of
CoreDoSimplify SimplifyOpts
opts -> {-# SCC "Simplify" #-}
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
$ Logger
-> UnitEnv
-> NamePprCtx
-> SimplifyOpts
-> ModGuts
-> IO (SimplCount, ModGuts)
simplifyPgm Logger
logger (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) NamePprCtx
name_ppr_ctx SimplifyOpts
opts ModGuts
guts
CoreToDo
CoreCSE -> {-# SCC "CommonSubExpr" #-}
(CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds CoreProgram -> CoreProgram
cseProgram
CoreToDo
CoreLiberateCase -> {-# SCC "LiberateCase" #-}
(CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (LibCaseOpts -> CoreProgram -> CoreProgram
liberateCase (DynFlags -> LibCaseOpts
initLiberateCaseOpts DynFlags
dflags))
CoreToDo
CoreDoFloatInwards -> {-# SCC "FloatInwards" #-}
(CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (Platform -> CoreProgram -> CoreProgram
floatInwards Platform
platform)
CoreDoFloatOutwards FloatOutSwitches
f -> {-# SCC "FloatOutwards" #-}
(CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM (IO CoreProgram -> CoreM CoreProgram
forall a. IO a -> CoreM a
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
. Logger
-> FloatOutSwitches -> UniqSupply -> CoreProgram -> IO CoreProgram
floatOutwards Logger
logger FloatOutSwitches
f UniqSupply
us)
CoreToDo
CoreDoStaticArgs -> {-# SCC "StaticArgs" #-}
(CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (UniqSupply -> CoreProgram -> CoreProgram
doStaticArgs UniqSupply
us)
CoreToDo
CoreDoCallArity -> {-# SCC "CallArity" #-}
(CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds CoreProgram -> CoreProgram
callArityAnalProgram
CoreToDo
CoreDoExitify -> {-# SCC "Exitify" #-}
(CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds CoreProgram -> CoreProgram
exitifyProgram
CoreDoDemand Bool
before_ww -> {-# SCC "DmdAnal" #-}
(CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM (IO CoreProgram -> CoreM CoreProgram
forall a. IO a -> CoreM a
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
. Logger
-> Bool
-> DynFlags
-> (PackageFamInstEnv, PackageFamInstEnv)
-> [CoreRule]
-> CoreProgram
-> IO CoreProgram
dmdAnal Logger
logger Bool
before_ww DynFlags
dflags (PackageFamInstEnv, PackageFamInstEnv)
fam_envs (ModGuts -> [CoreRule]
mg_rules ModGuts
guts))
CoreToDo
CoreDoCpr -> {-# SCC "CprAnal" #-}
(CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM (IO CoreProgram -> CoreM CoreProgram
forall a. IO a -> CoreM a
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
. Logger
-> (PackageFamInstEnv, PackageFamInstEnv)
-> CoreProgram
-> IO CoreProgram
cprAnalProgram Logger
logger (PackageFamInstEnv, PackageFamInstEnv)
fam_envs)
CoreToDo
CoreDoWorkerWrapper -> {-# SCC "WorkWrap" #-}
(CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (WwOpts -> UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds
(Module
-> DynFlags -> (PackageFamInstEnv, PackageFamInstEnv) -> WwOpts
initWorkWrapOpts (ModGuts -> Module
mg_module ModGuts
guts) DynFlags
dflags (PackageFamInstEnv, PackageFamInstEnv)
fam_envs)
UniqSupply
us)
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
CoreAddLateCcs -> {-# SCC "AddLateCcs" #-}
ModGuts -> CoreM ModGuts
addLateCostCentresMG ModGuts
guts
CoreToDo
CoreDoPrintCore -> {-# SCC "PrintCore" #-}
IO ModGuts -> CoreM ModGuts
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> CoreM ModGuts) -> IO ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ Logger -> CoreProgram -> IO ()
printCore Logger
logger (ModGuts -> CoreProgram
mg_binds ModGuts
guts) IO () -> IO ModGuts -> IO ModGuts
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ModGuts -> IO ModGuts
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
CoreDoRuleCheck CompilerPhase
phase String
pat -> {-# SCC "RuleCheck" #-}
CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass CompilerPhase
phase String
pat ModGuts
guts
CoreToDo
CoreDoNothing -> ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
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 -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
CoreToDo
CoreDesugarOpt -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
CoreToDo
CoreTidy -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
CoreToDo
CorePrep -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
printCore :: Logger -> CoreProgram -> IO ()
printCore :: Logger -> CoreProgram -> IO ()
printCore Logger
logger CoreProgram
binds
= Logger -> String -> SDoc -> IO ()
Logger.logDumpMsg Logger
logger 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 = do
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
Logger -> SDoc -> (ModGuts -> ()) -> CoreM ModGuts -> CoreM ModGuts
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RuleCheck"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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
RuleEnv
rule_env <- ModGuts -> CoreM RuleEnv
initRuleEnv ModGuts
guts
let rule_fn :: CoreBndr -> [CoreRule]
rule_fn CoreBndr
fn = RuleEnv -> CoreBndr -> [CoreRule]
getRules RuleEnv
rule_env CoreBndr
fn
ropts :: RuleOpts
ropts = DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags
IO () -> CoreM ()
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Logger -> String -> SDoc -> IO ()
logDumpMsg Logger
logger String
"Rule check"
(RuleOpts
-> CompilerPhase
-> String
-> (CoreBndr -> [CoreRule])
-> CoreProgram
-> SDoc
ruleCheckProgram RuleOpts
ropts CompilerPhase
current_phase String
pat
CoreBndr -> [CoreRule]
rule_fn (ModGuts -> CoreProgram
mg_binds ModGuts
guts))
ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
dmdAnal :: Logger -> Bool -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
dmdAnal :: Logger
-> Bool
-> DynFlags
-> (PackageFamInstEnv, PackageFamInstEnv)
-> [CoreRule]
-> CoreProgram
-> IO CoreProgram
dmdAnal Logger
logger Bool
before_ww DynFlags
dflags (PackageFamInstEnv, PackageFamInstEnv)
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
, dmd_do_boxity :: Bool
dmd_do_boxity = Bool
before_ww
, dmd_unbox_width :: PhaseNum
dmd_unbox_width = DynFlags -> PhaseNum
dmdUnboxWidth DynFlags
dflags
, dmd_max_worker_args :: PhaseNum
dmd_max_worker_args = DynFlags -> PhaseNum
maxWorkerArgs DynFlags
dflags
}
binds_plus_dmds :: CoreProgram
binds_plus_dmds = DmdAnalOpts
-> (PackageFamInstEnv, PackageFamInstEnv)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
dmdAnalProgram DmdAnalOpts
opts (PackageFamInstEnv, PackageFamInstEnv)
fam_envs [CoreRule]
rules CoreProgram
binds
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_str_signatures String
"Strictness signatures" DumpFormat
FormatText (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram (DynFlags -> Bool
hasPprDebug DynFlags
dflags) (DmdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DmdSig -> SDoc) -> (IdInfo -> DmdSig) -> IdInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DmdSig -> DmdSig
zapDmdEnvSig (DmdSig -> DmdSig) -> (IdInfo -> DmdSig) -> IdInfo -> DmdSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> DmdSig
dmdSigInfo) CoreProgram
binds_plus_dmds
CoreProgram -> ()
seqBinds CoreProgram
binds_plus_dmds () -> IO CoreProgram -> IO CoreProgram
forall a b. a -> b -> b
`seq` CoreProgram -> IO CoreProgram
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_plus_dmds