SimplMode(..), updMode, smPlatform,

         -- * Environments

         SimplPhase(..), isActive,

         seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,

         seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,

         SimplEnvIS,  checkSimplEnvIS, pprBadSimplEnvIS,

         -- * Substitution results

         -- * Simplifying 'Id' binders

         simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,

         simplBinder, simplBinders,

         substTy, substTyVar, getFullSubst, getTCvSubst,

         -- * Floats

         SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,

 import GHC.Core.Opt.Simplify.Monad

 import GHC.Core.Rules.Config ( RuleOpts(..) )

 import GHC.Core

 import GHC.Core.Utils

 import GHC.Core.Unfold

 import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst)

 import GHC.Core.Multiplicity( Scaled(..), mkMultMul )

      -- Invariant: the substitution is empty

      -- We want this SimplEnv for its InScopeSet and flags

 checkSimplEnvIS :: SimplEnvIS -> Bool

 -- Check the invariant for SimplEnvIS

 checkSimplEnvIS (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })

    ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)

              | otherwise = ppr v

         -- See Note [Extending the IdSubstEnv] in GHC.Core.Subst

   = DoneEx OutExpr JoinPointHood

        -- If  x :-> DoneEx e ja   is in the SimplIdSubst

        -- then replace occurrences of x by e

        -- and  ja = Just a <=> x is a join-point of arity a

        -- See Note [Join arity in SimplIdSubst]

   | DoneId OutId

        -- If  x :-> DoneId v   is in the SimplIdSubst

        -- then replace occurrences of x by v

        -- and  v is a join-point of arity a

        --      <=> x is a join-point of arity a

            InExpr

   ppr (DoneId v)    = text "DoneId" <+> ppr v

     where

       pp_mj = case mj of

                 NotJoinPoint -> empty

                 JoinPoint n  -> parens (int n)

         -- where

         -- fvs = exprFreeVars e

         -- filter_env env = filterVarEnv_Directly keep env

 reSimplifying (SimplEnv { seInlineDepth = n }) = n>0

 ---------------------

 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res

   = assertPpr (isId var && not (isCoVar var)) (ppr var) $

     env { seIdSubst = extendVarEnv subst var res }

 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv

 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }

 {-

 ************************************************************************

 find that it has been substituted by b.  (Or conceivably cloned.)

 -}

 -- Returns DoneEx only on a non-Var expression

 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v

   = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]

 getFullSubst :: InScopeSet -> SimplEnv -> Subst

 getFullSubst in_scope (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })

 substTy :: HasDebugCallStack => SimplEnv -> Type -> Type

 substTy env ty = Type.substTy (getTCvSubst env) ty

                   -> SimplM (SimplFloats, SimplEnv)

 simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs

   = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}

     simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $

     do { tick (PreInlineUnconditionally old_bndr)

           -- observed the quadratic behavior, so this extra entanglement

           -- seems not worthwhile.

         simplExprF env fun $

                    , sc_hole_ty = substTy env (exprType fun)

                    , sc_dup = NoDup, sc_cont = cont }

     do { ty' <- simplType env ty

        ; simplExprF (extendTvSubst env bndr ty') body cont }

     -- Because of the let-can-float invariant, it's ok to

     -- inline freely, or to drop the binding if it is dead.

   = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $

   | otherwise

   = {-#SCC "simplNonRecE" #-}

 {- Note [Avoiding space leaks in OutType]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

       ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}

         -> rebuild_go env (App expr (Type ty)) cont

         -- See Note [Avoid redundant simplification]

               ; rebuild_go env (App expr arg') cont }

 completeBindX :: SimplEnv

         -- where   co :: (s1->s2) ~ (t1->t2)

         --         co1 :: t1 ~ s1

         --         co2 :: s2 ~ t2

                                                 , sc_dup = dup, sc_cont = tail

                                                 , sc_hole_ty = fun_ty })

           | not co_is_opt  -- pushCoValArg duplicates the coercion, so optimise first

                       -- See Note [Avoiding simplifying repeatedly]

                    MCo co1 ->

                                     , sc_cont = tail'

                                     , sc_hole_ty = coercionLKind co }) } } }

                                        -- See Note [Optimising reflexivity]

           | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont })

 {-

 ************************************************************************

        ; simplLam (extendTvSubst env bndr arg_ty) body cont }

 -- Coercion beta-reduction

   = assertPpr (isCoVar bndr) (ppr bndr) $

     do { tick (BetaReduction bndr)

 -- Value beta-reduction

 -- This works for /coercion/ lambdas too

                                     , sc_cont = cont, sc_dup = dup

                                     , sc_hole_ty = fun_ty})

   = do { tick (BetaReduction bndr)

              --      It's wrong to err in either direction

              --      But fun_ty is an OutType, so is fully substituted

             -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $

                     tick (PreInlineUnconditionally bndr)

                   ; simplLam env' body cont }

             | otherwise

 -- Discard a non-counting tick on a lambda.  This may change the

 -- cost attribution slightly (moving the allocation of the

              -> FromWhat

              -> InId               -- The binder, always an Id

                                    -- Never a join point

              -> InExpr             -- Body of the let/lambda

              -> SimplCont

              -> SimplM (SimplFloats, OutExpr)

 -- from_what=FromLet => the RHS satisfies the let-can-float invariant

 -- Otherwise it may or may not satisfy it.

   | assert (isId bndr && not (isJoinId bndr) ) $

     is_strict_bind

   = -- Evaluate RHS strictly

   | isCoVar var = return $! Coercion $! (substCoVar env var)

   | otherwise

   = case substId env var of

 simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)

 simplInId env var cont

   = rebuild zapped_env (Var var) cont

   | otherwise

   = case substId env var of

         -- so the cont is not embodied in e

   where

     zapped_env =  zapSubstEnv env  -- See Note [zapSubstEnv]

   | fun `hasKey` runRWKey

   , ApplyToTy  { sc_cont = cont1 } <- cont

   , ApplyToTy  { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1

   -- Do this even if (contIsStop cont), or if seCaseCase is off.

   -- See Note [No eta-expansion in runRW#]

   = do { let arg_env = arg_se `setInScopeFromE` env

            _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy

                    ; let (m,_,_) = splitFunTy fun_ty

                          env'  = arg_env `addNewInScopeIds` [s']

                                             , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }

                                 -- cont' applies to s', then K

                    ; body' <- simplExprC env' arg cont'

 ---------- Simplify value arguments --------------------

 rebuildCall env fun_info

                         , sc_dup = dup_flag, sc_hole_ty = fun_ty

                         , sc_cont = cont })

                 -- Note [Shadowing in the Simplifier]

         -- DO NOT float anything outside, hence simplExprC

         -- There is no benefit (unlike in a let-binding), and we'd

         -- have to be very careful about bogus strictness through

         -- floating a demanded let.

 ---------- No further useful info, revert to generic rebuild ------------

 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont

   = return Nothing

   where

     interesting_cont = interestingCallContext env call_cont

     log_inlining doc

         --, text "Rule activation:" <+> ppr (ruleActivation rule)

           , text "Full arity:" <+>  ppr (ruleArity rule)

           , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))

       | logHasDumpFlag logger Opt_D_dump_rule_firings

       = log_rule Opt_D_dump_rule_firings "Rule fired:" $

                      , ValArg { as_arg = no_cast_scrut

                               , as_dmd = seqDmd

                               , as_hole_ty = res3_ty } ]

                            , sc_hole_ty = res4_ty }

     -- Lazily evaluated, so we don't do most of this

                                     , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }

 mkDupableContWithDmds env dmds

                 , sc_cont = cont, sc_hole_ty = hole_ty })

   =     -- e.g.         [...hole...] (...arg...)

         --      ==>

     do  { let dmd:|cont_dmds = expectNonEmpty dmds

         ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont

         ; let env' = env `setInScopeFromF` floats1

         ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'

         ; let all_floats = floats1 `addLetFloats` let_floats2

         ; return ( all_floats

                               , sc_dup = OkToDup, sc_cont = cont'

                               , sc_hole_ty = hole_ty }) }

         tryEtaExpandRhs, wantEtaExpansion,

         -- Inlining,

         activeRule,

         getUnfoldingInRuleMatch,

         updModeForStableUnfoldings, updModeForRuleLHS, updModeForRuleRHS,

       { sc_dup     :: DupFlag   -- See Note [DupFlag invariants]

       , sc_hole_ty :: OutType   -- Type of the function, presumably (forall a. blah)

                                 -- See Note [The hole type in ApplyToTy]

       , sc_cont :: SimplCont }

   | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]

         CoreTickish     -- Tick tickish <hole>

         SimplCont

 data FromWhat = FromLet | FromBeta Levity

 -- See Note [DupFlag invariants]

 data DupFlag = NoDup       -- Unsimplified, might be big

              | OkToDup     -- Simplified and small

 isSimplified :: DupFlag -> Bool

 isSimplified NoDup = False

 isSimplified _     = True       -- Invariant: the subst-env is empty

 {- Note [StaticEnv invariant]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 isn't big enough.

 Note [DupFlag invariants]

 In both ApplyToVal { se_dup = dup, se_env = env, se_cont = k}

    and  Select { se_dup = dup, se_env = env, se_cont = k}

 -}

 instance Outputable DupFlag where

   ppr OkToDup    = text "ok"

   ppr NoDup      = text "nodup"

 instance Outputable SimplCont where

   ppr (Stop ty interesting eval_sd)

     = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont

   ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })

     = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty)

       $$ ppr cont

   ppr (StrictBind { sc_bndr = b, sc_cont = cont })

     = (text "StrictBind" <+> ppr b) $$ ppr cont

 pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont

 pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont

   = ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }

                , sc_hole_ty = hole_ty, sc_cont = cont }

 argSpecArg :: ArgSpec -> OutExpr

 contHoleType (Stop ty _ _)                    = ty

 contHoleType (TickIt _ k)                     = contHoleType k

 contHoleType (CastIt { sc_co = co })          = coercionLKind co

 contHoleType (StrictArg  { sc_fun_ty = ty })  = funArgTy ty

 contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]

 contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]

 -- Computes the multiplicity scaling factor at the hole. That is, in (case [] of

 -- x ::(p) _ { … }) (respectively for arguments of functions), the scaling

 countValArgs _                               = 0

 -------------------

 -- Summarises value args, discards type args and coercions

 -- The returned continuation of the call is only used to

 -- answer questions like "are you interesting?"

   | lone cont = (True, [], cont)

   | otherwise = go [] cont

   where

     lone (CastIt {})     = False  --     stops it being "lone"

     lone _               = True