module GHC.Driver.Config.Core.Opt.Simplify
  ( initSimplifyExprOpts
  , initSimplifyOpts
  , initSimplMode
  ) 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 -> SimplMode
initSimplMode DynFlags
dflags) { sm_names = ["GHCi"]
                                     , sm_inline = False }
      -- sm_inline: do not do any inlining, in case we expose
      -- some unboxed tuple stuff that confuses the bytecode
      -- interpreter

  , 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
  -- This is a particularly ugly construction, but we will get rid of it in !8341.
  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 -> SimplMode
initSimplMode :: DynFlags -> SimplMode
initSimplMode DynFlags
dflags = SimplMode
  { sm_names :: [String]
sm_names = [String
"Unknown simplifier run"]  -- Always overriden
  , sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
  , 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_pre_inline :: Bool
sm_pre_inline       = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining DynFlags
dflags
  , sm_do_eta_reduction :: Bool
sm_do_eta_reduction = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoEtaReduction DynFlags
dflags
  , sm_uf_opts :: UnfoldingOpts
sm_uf_opts          = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
  , sm_float_enable :: FloatEnable
sm_float_enable     = DynFlags -> FloatEnable
floatEnable 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
  , 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_keep_exits :: Bool
sm_keep_exits   = Bool
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