-- * Main data types

         Expr(..), Alt(..), Bind(..), AltCon(..), Arg,

         CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,

         -- * In/Out type synonyms

         InId, InBind, InExpr, InAlt, InArg, InType, InKind,

 instance Outputable b => Outputable (TaggedBndr b) where

   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'

 deTagExpr :: TaggedExpr t -> CoreExpr

 deTagExpr (Var v)                   = Var v

 deTagExpr (Lit l)                   = Lit l

 import GHC.Types.Cpr          ( CprSig, prependArgsCprSig )

 import GHC.Types.Name         ( getOccName, mkSystemVarName )

 import GHC.Types.Name.Occurrence ( occNameFS )

 import GHC.Types.Tickish      ( tickishIsCode )

 import GHC.Types.Unique.Supply

 import GHC.Types.Unique.DFM

 import GHC.Types.Basic  ( Arity, RecFlag(..), isRec )

 import GHC.Builtin.Types

 import GHC.Builtin.Names      ( runRWKey )

   = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr)

                                    NotJoinPoint

                                    (freeVars rhs)

 {-

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

        ; return (mkLams new_bndrs new_body) }

   where

     (bndrs, body)        = collectAnnBndrs expr

         -- At one time we called a special version of collectBinders,

         -- which ignored coercions, because we don't want to split

         -- a lambda like this (\x -> coerce t (\s -> ...))

     do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)

        ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'

        ; body' <- lvlMFE rhs_env True body

   | otherwise     -- Stays put

              alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'

        ; alts' <- mapM (lvl_alt alts_env) alts

        ; return (Case scrut' case_bndr' ty' alts') }

       = do { rhs' <- lvlMFE new_env True rhs

            ; return (Alt con bs' rhs') }

       where

 {- Note [Floating single-alternative cases]

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

   |  float_is_new_lam || exprIsTopLevelBindable expr expr_ty

          -- No wrapping needed if the type is lifted, or is a literal string

          -- or if we are wrapping it in one or more value lambdas

                   -- Treat the expr just like a right-hand side

   -- OK, so the float has an unlifted type (not top-level bindable)

   --     and no new value lambdas (float_is_new_lam is False)

   , BI_Box { bi_data_con = box_dc, bi_inst_con = boxing_expr

            , bi_boxed_type = box_ty } <- boxingDataCon expr_ty

   , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty]

                          Case expr1 (stayPut l1r ubx_bndr) box_ty

                              [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))]

        ; var <- newLvlVar float_rhs NotJoinPoint is_mk_static

              use_expr = Case (mkVarApps (Var var) abs_vars)

                              (stayPut l1u bx_bndr) expr_ty

                              [Alt (DataAlt box_dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]

     float_is_new_lam = float_n_lams > 0

     float_n_lams     = count isId abs_vars

     is_mk_static = isJust (collectMakeStaticArgs expr)

         -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable

     saves_work = escapes_value_lam        -- (a)

                  && not is_hnf            -- (b)

                  && not float_is_new_lam  -- (c)

     -- See Note [Saving allocation] and Note [Floating to the top]

     saves_alloc =  isTopLvl dest_lvl

 -- (In the latter case it won't be a join point any more.)

 -- Not treating top-level ones specially had a massive effect

 -- on nofib/minimax/Prog.prog

 {- Note [Saving work]

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

 answer.

 -}

 -- See Note [Bottoming floats] for why we want to add

 -- bottoming information right now

 --

 -- n_extra are the number of extra value arguments added during floating

 notWorthFloating :: CoreExpr -> [Var] -> Bool

 --  See Note [notWorthFloating]

   || not (wantToFloat env NonRecursive dest_lvl is_join is_top_bindable)

   = -- No float

     do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs

        ; return (NonRec bndr' rhs', env') }

   -- Otherwise we are going to float

   | null abs_vars

   = do {  -- No type abstraction; clone existing binder

                              is_bot_lam NotJoinPoint rhs

   | otherwise

   = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc

                              is_bot_lam NotJoinPoint rhs

   where

     bndr_ty    = idType bndr

 lvlBind env (AnnRec pairs)

   |  not (wantToFloat env Recursive dest_lvl is_join is_top_bindable)

   = -- No float

              lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (idJoinPointHood b) r

        ; rhss' <- mapM lvl_rhs pairs

        ; return (Rec (bndrs' `zip` rhss'), env') }

 --       I think we want to stop doing this

   | [(bndr,rhs)] <- pairs

   , count isId abs_vars > 1

         -- several variables carried around: build a local loop:

         --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars

         -- This just makes the closures a bit smaller.  If we don't do

         -- mutually recursive functions, but it's quite a bit more complicated

         --

         -- This all seems a bit ad hoc -- sigh

   | otherwise  -- Non-null abs_vars

        ; new_rhss <- mapM (do_rhs new_env) pairs

        ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)

                 , new_env) }

                       -- function in a Rec, and we don't much care what

                       -- happens to it.  False is simple!

                                      is_bot NotJoinPoint

                                      rhs

 profitableFloat :: LevelEnv -> Level -> Bool

 profitableFloat env dest_lvl

   || (isTopLvl dest_lvl && floatConsts env) -- Going all the way to top level

        -> CoreExprWithFVs

        -> LvlM LevelledExpr

 lvlRhs env rec_flag is_bot mb_join_arity expr

                 rec_flag is_bot mb_join_arity expr

             -> Bool   -- Binding is for a bottoming function

             -> JoinPointHood

             -> CoreExprWithFVs

             -> LvlM (Expr LevelledBndr)

 -- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline

   = do { body' <- if not is_bot  -- See Note [Floating from a RHS]

                      && any isId bndrs

                   then lvlMFE  body_env True body

                   else lvlExpr body_env      body

   where

         -- all these binders at once (abs_vars and bndrs), so they

         -- all get the same major level.  Otherwise we create stupid

         -- let-bindings inside, joyfully thinking they can float; but

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

 -}

   where

   where

     is_major bndr = not (isOneShotBndr bndr)

        -- Only non-one-shot lambdas bump a major level, which in

        -- turn triggers floating.  NB: isOneShotBndr is always

        -- out of a big lambda.

        -- See Note [Computing one-shot info] in GHC.Types.Demand

 lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])

 -- The binders returned are exactly the same as the ones passed,

 lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs

   = ( env { le_ctxt_lvl = new_lvl

           , le_lvl_env  = addLvls new_lvl lvl_env bndrs }

   -- Destination level is the max Id level of the expression

   -- (We'll abstract the type variables, if any.)

 data LevelEnv

   = LE { le_switches :: FloatOutSwitches

        , le_ctxt_lvl :: Level           -- The current level

        -- See Note [le_subst and le_env]

     }

 {- Note [le_subst and le_env]

       -- to a later one.  So here we put all the top-level binders in scope before

       -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294)

 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl

 addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs

 floatLams :: LevelEnv -> Maybe Int

 floatTopLvlOnly :: LevelEnv -> Bool

 floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)

 -- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can

 -- See Note [Binder-swap during float-out]

 extendCaseBndrEnv :: LevelEnv

        , le_env     = add_id id_env (case_bndr, scrut_var) }

 extendCaseBndrEnv env _ _ = env

     -- It's OK to use a non-deterministic fold here because maxIn commutes.

 -- Same but for TyCoVarSet

     -- It's OK to use a non-deterministic fold here because maxIn commutes.

 lookupVar :: LevelEnv -> Id -> LevelledExpr

 lookupVar le v = case lookupVarEnv (le_env le) v of

 initLvl :: UniqSupply -> UniqSM a -> a

 initLvl = initUs_

 -- The envt is extended to bind the new bndrs to dest_lvl, but

 -- the le_ctxt_lvl is unaffected

  = assert (all (not . isCoVar) bndrs) $   -- What would we add to the CoSubst in this case. No easy answer.

    do { uniqs <- getUniquesM

       ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs

             bndr_prs  = bndrs `zip` new_bndrs

                        , le_subst   = foldl' add_subst subst   bndr_prs

                        , le_env     = foldl' add_id    id_env  bndr_prs }

       ; return (env', new_bndrs) }

     add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)

     add_id    env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)

     -- If we are floating a join point to top level, it stops being

     -- a join point.  Otherwise it continues to be a join point,

       = mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty

 -- | Clone the binders bound by a single-alternative case.

 cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })

   = do { (subst', vs') <- cloneBndrsM subst vs

              -- N.B. We are not moving the body of the case, merely its case

              -- binders.  Consequently we should *not* set le_ctxt_lvl.

              -- See Note [Setting levels when floating single-alternative cases].

                         , le_subst     = subst'

 cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]

 -- See Note [Need for cloning during float-out]

 -- Works for Ids bound by let(rec)

 -- The dest_lvl is attributed to the binders in the new env,

                             NonRecursive -> cloneBndrsM      subst vs1

                             Recursive    -> cloneRecIdBndrsM subst vs1

                         , le_subst   = subst'

                         , le_env     = foldl' add_id id_env prs }

   where

     zap :: Var -> Var

     -- See Note [Floatifying demand info when floating]

     zap_join | isTopLvl dest_lvl = zapJoinId

              | otherwise         = id

   | isTyVar v = delVarEnv    id_env v

 {- Note [Zapping JoinId when floating]

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