content: 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(..), SimplPhase(..) )
  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.DynFlags ( DynFlags(..), GeneralFlag(..), gopt )
  
  import GHC.Runtime.Context ( InteractiveContext(..) )
  
  import GHC.Types.Basic ( CompilerPhase(..) )
  import GHC.Types.Var ( Var )
  
  initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts
  initSimplifyExprOpts dflags ic = SimplifyExprOpts
    { se_fam_inst = snd $ ic_instances ic
    , se_mode = (initSimplMode dflags InitialPhase "GHCi")
      { sm_inline = False
        -- Do not do any inlining, in case we expose some
        -- unboxed tuple stuff that confuses the bytecode
        -- interpreter
      }
    , se_top_env_cfg = TopEnvConfig
      { te_history_size = historySize dflags
      , te_tick_factor = simplTickFactor dflags
      }
    }
  
  initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts
  initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let
    -- This is a particularly ugly construction, but we will get rid of it in !8341.
    opts = SimplifyOpts
      { so_dump_core_sizes = not $ gopt Opt_SuppressCoreSizes dflags
      , so_iterations      = iterations
      , so_mode            = mode
      , so_pass_result_cfg = if gopt Opt_DoCoreLinting dflags
                             then Just $ initLintPassResultConfig dflags extra_vars
                                                              (CoreDoSimplify opts)
                             else Nothing
      , so_hpt_rules       = hpt_rule_base
      , so_top_env_cfg     = TopEnvConfig { te_history_size = historySize dflags
                                          , te_tick_factor = simplTickFactor dflags }
      }
    in opts
  
  initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode
  initSimplMode dflags phase name = SimplMode
    { sm_names = [name]
    , sm_phase = SimplPhase phase
    , sm_rules = gopt Opt_EnableRewriteRules dflags
    , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
    , sm_cast_swizzle = True
    , sm_inline = True
    , sm_uf_opts = unfoldingOpts dflags
    , sm_case_case = True
    , sm_pre_inline = gopt Opt_SimplPreInlining dflags
    , sm_float_enable = floatEnable dflags
    , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags
    , sm_arity_opts = initArityOpts dflags
    , sm_rule_opts = initRuleOpts dflags
    , sm_case_folding = gopt Opt_CaseFolding dflags
    , sm_case_merge = gopt Opt_CaseMerge dflags
    , sm_co_opt_opts = initOptCoercionOpts dflags
    }
  
  initGentleSimplMode :: DynFlags -> SimplMode
  initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")
    { -- Don't do case-of-case transformations.
      -- This makes full laziness work better
      -- See Note [Case-of-case and full laziness]
      sm_case_case = False
    }
  
  floatEnable :: DynFlags -> FloatEnable
  floatEnable dflags =
    case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of
      (True, True) -> FloatEnabled
      (True, False)-> FloatNestedOnly
      (False, _)   -> FloatDisabled
  
  
  {- Note [Case-of-case and full laziness]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Case-of-case can hide opportunities for let-floating (full laziness).
  For example
     rec { f = \y. case (expensive x) of (a,b) -> blah }
  We might hope to float the (expensive x) out of the \y-loop.
  But if we inline `expensive` we might get
     \y. case (case x of I# x' -> body) of (a,b) -> blah
  Now if we do case-of-case we get
     \y. case x if I# x2 ->
         case body of (a,b) -> blah
  
  Sadly, at this point `body` mentions `x2`, so we can't float it out of the
  \y-loop.
  
  Solution: don't do case-of-case in the "gentle" simplification phase that
  precedes the first float-out transformation.  Implementation:
  
    * `sm_case_case` field in SimplMode
  
    * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case
      in GHC.Core.Opt.Simplify.Iteration.rebuildCall.
  
  Wrinkles
  
  * This applies equally to the case-of-runRW# transformation:
      case (runRW# (\s. body)) of (a,b) -> blah
      --->
      runRW# (\s. case body of (a,b) -> blah)
    Again, don't do this when `sm_case_case` is off.  See #25055 for
    a motivating example.
  -}
  