module GHC.Driver.Config.Core.Opt.Simplify
( initSimplifyExprOpts
, initSimplifyOpts
, initSimplMode
, initGentleSimplMode
) where
import GHC.Prelude
import GHC.Core.Rules ( RuleBase )
import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) )
import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) )
import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) )
import GHC.Driver.Config ( initOptCoercionOpts )
import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig )
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts )
import GHC.Driver.Session ( DynFlags(..), GeneralFlag(..), gopt )
import GHC.Runtime.Context ( InteractiveContext(..) )
import GHC.Types.Basic ( CompilerPhase(..) )
import GHC.Types.Var ( Var )
initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts
initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts
initSimplifyExprOpts DynFlags
dflags InteractiveContext
ic = SimplifyExprOpts
{ se_fam_inst :: [FamInst]
se_fam_inst = (InstEnv, [FamInst]) -> [FamInst]
forall a b. (a, b) -> b
snd ((InstEnv, [FamInst]) -> [FamInst])
-> (InstEnv, [FamInst]) -> [FamInst]
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> (InstEnv, [FamInst])
ic_instances InteractiveContext
ic
, se_mode :: SimplMode
se_mode = (DynFlags -> CompilerPhase -> String -> SimplMode
initSimplMode DynFlags
dflags CompilerPhase
InitialPhase String
"GHCi")
{ sm_inline = False
}
, se_top_env_cfg :: TopEnvConfig
se_top_env_cfg = TopEnvConfig
{ te_history_size :: Int
te_history_size = DynFlags -> Int
historySize DynFlags
dflags
, te_tick_factor :: Int
te_tick_factor = DynFlags -> Int
simplTickFactor DynFlags
dflags
}
}
initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts
initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts
initSimplifyOpts DynFlags
dflags [Var]
extra_vars Int
iterations SimplMode
mode RuleBase
hpt_rule_base = let
opts :: SimplifyOpts
opts = SimplifyOpts
{ so_dump_core_sizes :: Bool
so_dump_core_sizes = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressCoreSizes DynFlags
dflags
, so_iterations :: Int
so_iterations = Int
iterations
, so_mode :: SimplMode
so_mode = SimplMode
mode
, so_pass_result_cfg :: Maybe LintPassResultConfig
so_pass_result_cfg = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCoreLinting DynFlags
dflags
then LintPassResultConfig -> Maybe LintPassResultConfig
forall a. a -> Maybe a
Just (LintPassResultConfig -> Maybe LintPassResultConfig)
-> LintPassResultConfig -> Maybe LintPassResultConfig
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig
initLintPassResultConfig DynFlags
dflags [Var]
extra_vars
(SimplifyOpts -> CoreToDo
CoreDoSimplify SimplifyOpts
opts)
else Maybe LintPassResultConfig
forall a. Maybe a
Nothing
, so_hpt_rules :: RuleBase
so_hpt_rules = RuleBase
hpt_rule_base
, so_top_env_cfg :: TopEnvConfig
so_top_env_cfg = TopEnvConfig { te_history_size :: Int
te_history_size = DynFlags -> Int
historySize DynFlags
dflags
, te_tick_factor :: Int
te_tick_factor = DynFlags -> Int
simplTickFactor DynFlags
dflags }
}
in SimplifyOpts
opts
initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode
initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode
initSimplMode DynFlags
dflags CompilerPhase
phase String
name = SimplMode
{ sm_names :: [String]
sm_names = [String
name]
, sm_phase :: CompilerPhase
sm_phase = CompilerPhase
phase
, sm_rules :: Bool
sm_rules = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags
, sm_eta_expand :: Bool
sm_eta_expand = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion DynFlags
dflags
, sm_cast_swizzle :: Bool
sm_cast_swizzle = Bool
True
, sm_inline :: Bool
sm_inline = Bool
True
, sm_uf_opts :: UnfoldingOpts
sm_uf_opts = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
, sm_case_case :: Bool
sm_case_case = Bool
True
, sm_pre_inline :: Bool
sm_pre_inline = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining DynFlags
dflags
, sm_float_enable :: FloatEnable
sm_float_enable = DynFlags -> FloatEnable
floatEnable DynFlags
dflags
, sm_do_eta_reduction :: Bool
sm_do_eta_reduction = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoEtaReduction DynFlags
dflags
, sm_arity_opts :: ArityOpts
sm_arity_opts = DynFlags -> ArityOpts
initArityOpts DynFlags
dflags
, sm_rule_opts :: RuleOpts
sm_rule_opts = DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags
, sm_case_folding :: Bool
sm_case_folding = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CaseFolding DynFlags
dflags
, sm_case_merge :: Bool
sm_case_merge = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CaseMerge DynFlags
dflags
, sm_co_opt_opts :: OptCoercionOpts
sm_co_opt_opts = DynFlags -> OptCoercionOpts
initOptCoercionOpts DynFlags
dflags
}
initGentleSimplMode :: DynFlags -> SimplMode
initGentleSimplMode :: DynFlags -> SimplMode
initGentleSimplMode DynFlags
dflags = (DynFlags -> CompilerPhase -> String -> SimplMode
initSimplMode DynFlags
dflags CompilerPhase
InitialPhase String
"Gentle")
{
sm_case_case = False
}
floatEnable :: DynFlags -> FloatEnable
floatEnable :: DynFlags -> FloatEnable
floatEnable DynFlags
dflags =
case (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LocalFloatOut DynFlags
dflags, GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LocalFloatOutTopLevel DynFlags
dflags) of
(Bool
True, Bool
True) -> FloatEnable
FloatEnabled
(Bool
True, Bool
False)-> FloatEnable
FloatNestedOnly
(Bool
False, Bool
_) -> FloatEnable
FloatDisabled