import GHC.Core.Coercion.Opt ( OptCoercionOpts )

 import GHC.Core.FamInstEnv ( FamInstEnv )

 import GHC.Core.Opt.Arity ( ArityOpts(..) )

 import GHC.Core.Opt.Simplify.Monad

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

 unitLetFloat :: OutBind -> LetFloats

 -- This key function constructs a singleton float with the right form

                     LetFloats (unitOL bind) (flag bind)

   where

     flag (Rec {})                = FltLifted

       | otherwise                = FltCareful

 unitJoinFloat :: OutBind -> JoinFloats

                      unitOL bind

 mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)

 -- Recursive let binders

 simplRecBndrs env@(SimplEnv {}) ids

   -- See Note [Bangs in the Simplifier]

     do  { let (!env1, ids1) = mapAccumL substIdBndr env ids

         ; seqIds ids1 `seq` return env1 }

 -- context being pushed inward may change types

 -- See Note [Return type for join points]

 simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty

     do  { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids

         ; seqIds ids1 `seq` return env1 }

 -- INVARIANT: If any of the first n binders are foralls, those tyvars

 -- cannot appear in the original result type. See isValidJoinPointType.

 adjustJoinPointType mult new_res_ty join_id

     setIdType join_id new_join_ty

   where

     join_arity = idJoinArity join_id

 import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe

                           , pushCoTyArg, pushCoValArg, exprIsDeadEnd

                           , typeArity, arityTypeArity, etaExpandAT )

 import GHC.Core.FVs     ( mkRuleInfo {- exprsFreeIds -} )

 import GHC.Core.Rules   ( lookupRule, getRules )

 import GHC.Core.Multiplicity

 -- Precondition: Ids only, no TyVars; not a JoinId

 -- Precondition: rhs obeys the let-can-float invariant

 simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)

     -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $

     do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]

                 (tvs, body) = case collectTyAndValBinders rhs of

 -- Precondition: rhs satisfies the let-can-float invariant

 simplAuxBind _str env bndr new_rhs

     isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }

   = return (emptyFloats env, env)    --  Here c is dead, and we avoid

                                      --  creating the binding c = (a,b)

 -- Otherwise it may or may not satisfy it.

 simplNonRecE env from_what bndr (rhs, rhs_se) body cont

     is_strict_bind

   = -- Evaluate RHS strictly

     simplExprF (rhs_se `setInScopeFromE` env) rhs

 -- Precondition: not a join-point binding

 simplRecE env pairs body cont

   = do  { let bndrs = map fst pairs

         ; env1 <- simplRecBndrs env bndrs

                 -- NB: bndrs' don't have unfoldings or rules

                 -- We add them as we go down

                      -> InExpr -> SimplCont

                      -> SimplM (SimplFloats, OutExpr)

 simplNonRecJoinPoint env bndr rhs body cont

      wrapJoinCont env cont $ \ env cont ->

      do { -- We push join_cont into the join RHS and the body;

           -- and wrap wrap_cont around the whole thing

   | isStableUnfolding unf

   = simplStableUnfolding env bind_cxt id rhs_ty arity unf

   | isExitJoinId id

   = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify

     return noUnfolding

   where

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

 mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource

         -- ** Join points

         joinPointBinding_maybe, joinPointBindings_maybe,

         -- ** Predicates on expressions

         exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,

 -}

 joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)

 joinPointBinding_maybe bndr rhs

   | not (isId bndr)

   = Nothing

   | isJoinId bndr

   | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)

   , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs

   , let str_sig   = idDmdSig bndr

         str_arity = count isId bndrs  -- Strictness demands are for Ids only

                          `setIdDmdSig` etaConvertDmdSig str_arity str_sig

   = Just (join_bndr, mkLams bndrs body)

   | otherwise

   = Nothing

 joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]

 joinPointBindings_maybe bndrs

   = mapM (uncurry joinPointBinding_maybe) bndrs

          in go subst' (float:floats) body (CC args mco)

     go subst floats (Let (NonRec bndr rhs) expr) cont

          -- Crucial guard! See Note [Don't float join points]

        = let rhs'            = subst_expr subst rhs

              (subst', bndr') = subst_bndr subst bndr