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.DynFlags ( 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
      -- 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 -> 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")
  { -- 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 :: 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


{- 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.
-}