    {-
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

    ************************************************************************
    *                                                                      *
    \section[FloatIn]{Floating Inwards pass}
    *                                                                      *
    ************************************************************************

    The main purpose of @floatInwards@ is floating into branches of a
    case, so that we don't allocate things, save them on the stack, and
    then discover that they aren't needed in the chosen branch.
    -}

    {-# OPTIONS_GHC -fprof-auto #-}
    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

    module GHC.Core.Opt.FloatIn ( floatInwards ) where

    import GHC.Prelude
    import GHC.Platform

    import GHC.Core
    import GHC.Core.Opt.Arity( isOneShotBndr )
    import GHC.Core.Make hiding ( wrapFloats )
    import GHC.Core.Utils
    import GHC.Core.FVs
    import GHC.Core.Type

    import GHC.Types.Basic      ( RecFlag(..), isRec )
    import GHC.Types.Id         ( idType, isJoinId, idJoinPointHood )
    import GHC.Types.Tickish
    import GHC.Types.Var
    import GHC.Types.Var.Set

    import GHC.Utils.Misc
    import GHC.Utils.Panic.Plain

    import GHC.Utils.Outputable

    import Data.List        ( mapAccumL )

    {-
    Top-level interface function, @floatInwards@.  Note that we do not
    actually float any bindings downwards from the top-level.
    -}

    floatInwards :: Platform -> CoreProgram -> CoreProgram
    floatInwards :: Platform -> CoreProgram -> CoreProgram
    floatInwards Platform
    platform CoreProgram
    binds = (Bind CoreBndr -> Bind CoreBndr) -> CoreProgram -> CoreProgram
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> Bind CoreBndr -> Bind CoreBndr
    fi_top_bind Platform
    platform) CoreProgram
    binds
      where
        fi_top_bind :: Platform -> Bind CoreBndr -> Bind CoreBndr
    fi_top_bind Platform
    platform (NonRec CoreBndr
    binder Expr CoreBndr
    rhs)
          = CoreBndr -> Expr CoreBndr -> Bind CoreBndr
    forall b. b -> Expr b -> Bind b
    NonRec CoreBndr
    binder (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform [] (Expr CoreBndr -> CoreExprWithFVs
    freeVars Expr CoreBndr
    rhs))
        fi_top_bind Platform
    platform (Rec [(CoreBndr, Expr CoreBndr)]
    pairs)
          = [(CoreBndr, Expr CoreBndr)] -> Bind CoreBndr
    forall b. [(b, Expr b)] -> Bind b
    Rec [ (CoreBndr
    b, Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform [] (Expr CoreBndr -> CoreExprWithFVs
    freeVars Expr CoreBndr
    rhs)) | (CoreBndr
    b, Expr CoreBndr
    rhs) <- [(CoreBndr, Expr CoreBndr)]
    pairs ]

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Mail from Andr\'e [edited]}
    *                                                                      *
    ************************************************************************

    {\em Will wrote: What??? I thought the idea was to float as far
    inwards as possible, no matter what.  This is dropping all bindings
    every time it sees a lambda of any kind.  Help! }

    You are assuming we DO DO full laziness AFTER floating inwards!  We
    have to [not float inside lambdas] if we don't.

    If we indeed do full laziness after the floating inwards (we could
    check the compilation flags for that) then I agree we could be more
    aggressive and do float inwards past lambdas.

    Actually we are not doing a proper full laziness (see below), which
    was another reason for not floating inwards past a lambda.

    This can easily be fixed.  The problem is that we float lets outwards,
    but there are a few expressions which are not let bound, like case
    scrutinees and case alternatives.  After floating inwards the
    simplifier could decide to inline the let and the laziness would be
    lost, e.g.

    \begin{verbatim}
    let a = expensive             ==> \b -> case expensive of ...
    in \ b -> case a of ...
    \end{verbatim}
    The fix is
    \begin{enumerate}
    \item
    to let bind the algebraic case scrutinees (done, I think) and
    the case alternatives (except the ones with an
    unboxed type)(not done, I think). This is best done in the
    GHC.Core.Opt.SetLevels module, which tags things with their level numbers.
    \item
    do the full laziness pass (floating lets outwards).
    \item
    simplify. The simplifier inlines the (trivial) lets that were
     created but were not floated outwards.
    \end{enumerate}

    With the fix I think Will's suggestion that we can gain even more from
    strictness by floating inwards past lambdas makes sense.

    We still gain even without going past lambdas, as things may be
    strict in the (new) context of a branch (where it was floated to) or
    of a let rhs, e.g.
    \begin{verbatim}
    let a = something            case x of
    in case x of                   alt1 -> case something of a -> a + a
         alt1 -> a + a      ==>    alt2 -> b
         alt2 -> b

    let a = something           let b = case something of a -> a + a
    in let b = a + a        ==> in (b,b)
    in (b,b)
    \end{verbatim}
    Also, even if a is not found to be strict in the new context and is
    still left as a let, if the branch is not taken (or b is not entered)
    the closure for a is not built.

    ************************************************************************
    *                                                                      *
    \subsection{Main floating-inwards code}
    *                                                                      *
    ************************************************************************
    -}

    type FreeVarSet  = DVarSet
    type BoundVarSet = DIdSet

    data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
            -- The FreeVarSet is the free variables of the binding.  In the case
            -- of recursive bindings, the set doesn't include the bound
            -- variables.

    type FloatInBinds    = [FloatInBind] -- In normal dependency order
                                         --    (outermost binder first)
    type RevFloatInBinds = [FloatInBind] -- In reverse dependency order
                                         --    (innermost binder first)

    instance Outputable FloatInBind where
      ppr :: FloatInBind -> SDoc
    ppr (FB BoundVarSet
    bvs BoundVarSet
    fvs FloatBind
    _) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "FB" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces ([SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    sep [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "bndrs =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> BoundVarSet -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr BoundVarSet
    bvs
                                                    , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "fvs =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> BoundVarSet -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr BoundVarSet
    fvs ])

    fiExpr :: Platform
           -> RevFloatInBinds   -- Binds we're trying to drop
                                -- as far "inwards" as possible
           -> CoreExprWithFVs   -- Input expr
           -> CoreExpr          -- Result

    fiExpr :: Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    _ RevFloatInBinds
    to_drop (BoundVarSet
    _, AnnLit Literal
    lit)     = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    to_drop (Literal -> Expr CoreBndr
    forall b. Literal -> Expr b
    Lit Literal
    lit)
                                           -- See Note [Dead bindings]
    fiExpr Platform
    _ RevFloatInBinds
    to_drop (BoundVarSet
    _, AnnType Type
    ty)     = Bool -> Expr CoreBndr -> Expr CoreBndr
    forall a. HasCallStack => Bool -> a -> a
    assert (RevFloatInBinds -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null RevFloatInBinds
    to_drop) (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
    forall a b. (a -> b) -> a -> b
    $ Type -> Expr CoreBndr
    forall b. Type -> Expr b
    Type Type
    ty
    fiExpr Platform
    _ RevFloatInBinds
    to_drop (BoundVarSet
    _, AnnVar CoreBndr
    v)       = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    to_drop (CoreBndr -> Expr CoreBndr
    forall b. CoreBndr -> Expr b
    Var CoreBndr
    v)
    fiExpr Platform
    _ RevFloatInBinds
    to_drop (BoundVarSet
    _, AnnCoercion Coercion
    co) = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    to_drop (Coercion -> Expr CoreBndr
    forall b. Coercion -> Expr b
    Coercion Coercion
    co)
    fiExpr Platform
    platform RevFloatInBinds
    to_drop (BoundVarSet
    _, AnnCast CoreExprWithFVs
    expr (BoundVarSet
    co_ann, Coercion
    co))
      = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    drop_here (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
    forall a b. (a -> b) -> a -> b
    $
        Expr CoreBndr -> Coercion -> Expr CoreBndr
    forall b. Expr b -> Coercion -> Expr b
    Cast (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    e_drop CoreExprWithFVs
    expr) Coercion
    co
      where
        (RevFloatInBinds
    drop_here, [RevFloatInBinds
    e_drop])
          = Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    False RevFloatInBinds
    to_drop
              (BoundVarSet -> BoundVarSet
    freeVarsOfAnn BoundVarSet
    co_ann) [CoreExprWithFVs -> BoundVarSet
    freeVarsOf CoreExprWithFVs
    expr]

    {-
    Applications: we do float inside applications, mainly because we
    need to get at all the arguments.  The next simplifier run will
    pull out any silly ones.
    -}

    fiExpr Platform
    platform RevFloatInBinds
    to_drop ann_expr :: CoreExprWithFVs
    ann_expr@(BoundVarSet
    _,AnnApp {})
      = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    drop_here (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
    forall a b. (a -> b) -> a -> b
    $
        [CoreTickish] -> Expr CoreBndr -> Expr CoreBndr
    mkTicks [CoreTickish]
    ticks (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
    forall a b. (a -> b) -> a -> b
    $
        Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    fun_drop CoreExprWithFVs
    ann_fun)
               (String
    -> (RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr)
    -> [RevFloatInBinds]
    -> [CoreExprWithFVs]
    -> [Expr CoreBndr]
    forall a b c.
    HasDebugCallStack =>
    String -> (a -> b -> c) -> [a] -> [b] -> [c]
    zipWithEqual String
    "fiExpr" (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform) [RevFloatInBinds]
    arg_drops [CoreExprWithFVs]
    ann_args)
               -- use zipWithEqual, we should have
               -- length ann_args = length arg_fvs = length arg_drops
      where
        (CoreExprWithFVs
    ann_fun, [CoreExprWithFVs]
    ann_args, [CoreTickish]
    ticks) = (CoreTickish -> Bool)
    -> CoreExprWithFVs
    -> (CoreExprWithFVs, [CoreExprWithFVs], [CoreTickish])
    forall b a.
    (CoreTickish -> Bool)
    -> AnnExpr b a -> (AnnExpr b a, [AnnExpr b a], [CoreTickish])
    collectAnnArgsTicks CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishFloatable CoreExprWithFVs
    ann_expr
        fun_fvs :: BoundVarSet
    fun_fvs = CoreExprWithFVs -> BoundVarSet
    freeVarsOf CoreExprWithFVs
    ann_fun

        (RevFloatInBinds
    drop_here, RevFloatInBinds
    fun_drop : [RevFloatInBinds]
    arg_drops)
           = Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    False RevFloatInBinds
    to_drop
                                 BoundVarSet
    here_fvs (BoundVarSet
    fun_fvs BoundVarSet -> [BoundVarSet] -> [BoundVarSet]
    forall a. a -> [a] -> [a]
    : [BoundVarSet]
    arg_fvs)

             -- Shortcut behaviour: if to_drop is empty,
             -- sepBindsByDropPoint returns a suitable bunch of empty
             -- lists without evaluating extra_fvs, and hence without
             -- peering into each argument

        (BoundVarSet
    here_fvs, [BoundVarSet]
    arg_fvs) = (BoundVarSet -> CoreExprWithFVs -> (BoundVarSet, BoundVarSet))
    -> BoundVarSet -> [CoreExprWithFVs] -> (BoundVarSet, [BoundVarSet])
    forall (t :: * -> *) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL BoundVarSet -> CoreExprWithFVs -> (BoundVarSet, BoundVarSet)
    add_arg BoundVarSet
    here_fvs0 [CoreExprWithFVs]
    ann_args
        here_fvs0 :: BoundVarSet
    here_fvs0 = case CoreExprWithFVs
    ann_fun of
                       (BoundVarSet
    _, AnnVar CoreBndr
    _) -> BoundVarSet
    fun_fvs
                       CoreExprWithFVs
    _             -> BoundVarSet
    emptyDVarSet
              -- Don't float the binding for f into f x y z; see Note [Join points]
              -- for why we *can't* do it when f is a join point. (If f isn't a
              -- join point, floating it in isn't especially harmful but it's
              -- useless since the simplifier will immediately float it back out.)

        add_arg :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet,FreeVarSet)
        -- We can't float into some arguments, so put them into the here_fvs
        add_arg :: BoundVarSet -> CoreExprWithFVs -> (BoundVarSet, BoundVarSet)
    add_arg BoundVarSet
    here_fvs (BoundVarSet
    arg_fvs, AnnExpr' CoreBndr BoundVarSet
    arg)
          | AnnExpr' CoreBndr BoundVarSet -> Bool
    noFloatIntoArg AnnExpr' CoreBndr BoundVarSet
    arg = (BoundVarSet
    here_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
    `unionDVarSet` BoundVarSet
    arg_fvs, BoundVarSet
    emptyDVarSet)
          | Bool
    otherwise          = (BoundVarSet
    here_fvs, BoundVarSet
    arg_fvs)

    {- Note [Dead bindings]
    ~~~~~~~~~~~~~~~~~~~~~~~
    At a literal we won't usually have any floated bindings; the
    only way that can happen is if the binding wrapped the literal
    /in the original input program/.  e.g.
       case x of { DEFAULT -> 1# }
    But, while this may be unusual it is not actually wrong, and it did
    once happen (#15696).

    Note [Join points]
    ~~~~~~~~~~~~~~~~~~
    Generally, we don't need to worry about join points - there are places we're
    not allowed to float them, but since they can't have occurrences in those
    places, we're not tempted.

    We do need to be careful about jumps, however:

      joinrec j x y z = ... in
      jump j a b c

    Previous versions often floated the definition of a recursive function into its
    only non-recursive occurrence. But for a join point, this is a disaster:

      (joinrec j x y z = ... in
      jump j) a b c -- wrong!

    Every jump must be exact, so the jump to j must have three arguments. Hence
    we're careful not to float into the target of a jump (though we can float into
    the arguments just fine).

    Floating in can /enhance/ join points.  Consider this (#3458)
        f2 x = let g :: Int -> Int
                   g y = if y==0 then y+x else g (y-1)
               in case g x of
                    0 -> True
                    _ -> False

    Here `g` is not a join point. But if we float inwards it becomes one!  We
    float in; the occurrence analyser identifies `g` as a join point; the Simplifier
    retains that property, so we get
        f2 x = case (joinrec
                        g y = if y==0 then y+x else g (y-1)
                     in jump g x) of
                  0 -> True
                  _ -> False

    Now that outer case gets pushed into the RHS of the joinrec, giving
        f2 x = joinrec g y = if y==0
                             then case y+x of { 0 -> True; _ -> False }
                             else jump g (y-1)
               in jump g x
    Nice!

    Note [Floating in past a lambda group]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    * We must be careful about floating inside a value lambda.
      That risks losing laziness.
      The float-out pass might rescue us, but then again it might not.

    * We must be careful about type lambdas too.  At one time we did, and
      there is no risk of duplicating work thereby, but we do need to be
      careful.  In particular, here is a bad case (it happened in the
      cichelli benchmark:
            let v = ...
            in let f = /\t -> \a -> ...
               ==>
            let f = /\t -> let v = ... in \a -> ...
      This is bad as now f is an updatable closure (update PAP)
      and has arity 0.

    * Hack alert!  We only float in through one-shot lambdas,
      not (as you might guess) through lone big lambdas.
      Reason: we float *out* past big lambdas (see the test in the Lam
      case of FloatOut.floatExpr) and we don't want to float straight
      back in again.

      It *is* important to float into one-shot lambdas, however;
      see the remarks with noFloatIntoRhs.

    So we treat lambda in groups, using the following rule:

     Float in if (a) there is at least one Id,
             and (b) there are no non-one-shot Ids

     Otherwise drop all the bindings outside the group.

    This is what the 'go' function in the AnnLam case is doing.

    (Join points are handled similarly: a join point is considered one-shot iff
    it's non-recursive, so we float only into non-recursive join points.)

    Urk! if all are tyvars, and we don't float in, we may miss an
          opportunity to float inside a nested case branch

    Note [Floating coercions]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    We could, in principle, have a coercion binding like
       case f x of co { DEFAULT -> e1 e2 }
    It's not common to have a function that returns a coercion, but nothing
    in Core prohibits it.  If so, 'co' might be mentioned in e1 or e2
    /only in a type/.  E.g. suppose e1 was
      let (x :: Int |> co) = blah in blah2

    But, with coercions appearing in types, there is a complication: we
    might be floating in a "strict let" -- that is, a case. Case expressions
    mention their return type. We absolutely can't float a coercion binding
    inward to the point that the type of the expression it's about to wrap
    mentions the coercion. So we include the union of the sets of free variables
    of the types of all the drop points involved. If any of the floaters
    bind a coercion variable mentioned in any of the types, that binder must
    be dropped right away.

    Note [Shadowing and name capture]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have
        let x = y+1 in
        case p of
           (y:ys) -> ...x...
           [] -> blah
    It is obviously bogus for FloatIn to transform to
        case p of
           (y:ys) -> ...(let x = y+1 in x)...
           [] -> blah
    because the y is captured.  This doesn't happen much, because shadowing is
    rare (see Note [Shadowing in Core]), but it did happen in #22662.

    One solution would be to clone as we go.  But a simpler one is this:

      at a binding site (like that for (y:ys) above), abandon float-in for
      any floating bindings that mention the binders (y, ys in this case)

    We achieve that by calling sepBindsByDropPoint with the binders in
    the "used-here" set:

    * In fiExpr (AnnLam ...).  For the body there is no need to delete
      the lambda-binders from the body_fvs, because any bindings that
      mention these binders will be dropped here anyway.

    * In fiExpr (AnnCase ...). Remember to include the case_bndr in the
      binders.  Again, no need to delete the alt binders from the rhs
      free vars, because any bindings mentioning them will be dropped
      here unconditionally.
    -}

    fiExpr Platform
    platform RevFloatInBinds
    to_drop lam :: CoreExprWithFVs
    lam@(BoundVarSet
    _, AnnLam CoreBndr
    _ CoreExprWithFVs
    _)
      | [CoreBndr] -> Bool
    noFloatIntoLam [CoreBndr]
    bndrs       -- Dump it all here
         -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088
      = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    to_drop ([CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
    forall b. [b] -> Expr b -> Expr b
    mkLams [CoreBndr]
    bndrs (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform [] CoreExprWithFVs
    body))

      | Bool
    otherwise           -- Float inside
      = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    drop_here (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
    forall a b. (a -> b) -> a -> b
    $
        [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
    forall b. [b] -> Expr b -> Expr b
    mkLams [CoreBndr]
    bndrs (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    body_drop CoreExprWithFVs
    body)

      where
        ([CoreBndr]
    bndrs, CoreExprWithFVs
    body) = CoreExprWithFVs -> ([CoreBndr], CoreExprWithFVs)
    forall bndr annot.
    AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
    collectAnnBndrs CoreExprWithFVs
    lam
        body_fvs :: BoundVarSet
    body_fvs      = CoreExprWithFVs -> BoundVarSet
    freeVarsOf CoreExprWithFVs
    body

        -- Why sepBindsByDropPoint? Because of potential capture
        -- See Note [Shadowing and name capture]
        (RevFloatInBinds
    drop_here, [RevFloatInBinds
    body_drop]) = Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    False RevFloatInBinds
    to_drop
                                      ([CoreBndr] -> BoundVarSet
    mkDVarSet [CoreBndr]
    bndrs) [BoundVarSet
    body_fvs]

    {-
    We don't float lets inwards past an SCC.
            ToDo: keep info on current cc, and when passing
            one, if it is not the same, annotate all lets in binds with current
            cc, change current cc to the new one and float binds into expr.
    -}

    fiExpr Platform
    platform RevFloatInBinds
    to_drop (BoundVarSet
    _, AnnTick CoreTickish
    tickish CoreExprWithFVs
    expr)
      | CoreTickish
    tickish CoreTickish -> TickishScoping -> Bool
    forall (pass :: TickishPass).
    GenTickish pass -> TickishScoping -> Bool
    `tickishScopesLike` TickishScoping
    SoftScope
      = CoreTickish -> Expr CoreBndr -> Expr CoreBndr
    forall b. CoreTickish -> Expr b -> Expr b
    Tick CoreTickish
    tickish (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    to_drop CoreExprWithFVs
    expr)

      | Bool
    otherwise -- Wimp out for now - we could push values in
      = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    to_drop (CoreTickish -> Expr CoreBndr -> Expr CoreBndr
    forall b. CoreTickish -> Expr b -> Expr b
    Tick CoreTickish
    tickish (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform [] CoreExprWithFVs
    expr))

    {-
    For @Lets@, the possible ``drop points'' for the \tr{to_drop}
    bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
    or~(b2), in each of the RHSs of the pairs of a @Rec@.

    Note that we do {\em weird things} with this let's binding.  Consider:
    \begin{verbatim}
    let
        w = ...
    in {
        let v = ... w ...
        in ... v .. w ...
    }
    \end{verbatim}
    Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
    body of the inner let, we could panic and leave \tr{w}'s binding where
    it is.  But \tr{v} is floatable further into the body of the inner let, and
    {\em then} \tr{w} will also be only in the body of that inner let.

    So: rather than drop \tr{w}'s binding here, we add it onto the list of
    things to drop in the outer let's body, and let nature take its
    course.

    Note [extra_fvs (1)]: avoid floating into RHS
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider let x=\y....t... in body.  We do not necessarily want to float
    a binding for t into the RHS, because it'll immediately be floated out
    again.  (It won't go inside the lambda else we risk losing work.)
    In letrec, we need to be more careful still. We don't want to transform
            let x# = y# +# 1#
            in
            letrec f = \z. ...x#...f...
            in ...
    into
            letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
    because now we can't float the let out again, because a letrec
    can't have unboxed bindings.

    So we make "extra_fvs" which is the rhs_fvs of such bindings, and
    arrange to dump bindings that bind extra_fvs before the entire let.

    Note [extra_fvs (2)]: free variables of rules
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
      let x{rule mentioning y} = rhs in body
    Here y is not free in rhs or body; but we still want to dump bindings
    that bind y outside the let.  So we augment extra_fvs with the
    idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
    idFreeVars.
    -}

    fiExpr Platform
    platform RevFloatInBinds
    to_drop (BoundVarSet
    _,AnnLet AnnBind CoreBndr BoundVarSet
    bind CoreExprWithFVs
    body)
      = Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform (RevFloatInBinds
    after RevFloatInBinds -> RevFloatInBinds -> RevFloatInBinds
    forall a. [a] -> [a] -> [a]
    ++ FloatInBind
    new_float FloatInBind -> RevFloatInBinds -> RevFloatInBinds
    forall a. a -> [a] -> [a]
    : RevFloatInBinds
    before) CoreExprWithFVs
    body
               -- to_drop is in reverse dependency order
      where
        (RevFloatInBinds
    before, FloatInBind
    new_float, RevFloatInBinds
    after) = Platform
    -> RevFloatInBinds
    -> AnnBind CoreBndr BoundVarSet
    -> BoundVarSet
    -> (RevFloatInBinds, FloatInBind, RevFloatInBinds)
    fiBind Platform
    platform RevFloatInBinds
    to_drop AnnBind CoreBndr BoundVarSet
    bind BoundVarSet
    body_fvs
        body_fvs :: BoundVarSet
    body_fvs    = CoreExprWithFVs -> BoundVarSet
    freeVarsOf CoreExprWithFVs
    body

    {- Note [Floating primops]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    We try to float-in a case expression over an unlifted type.  The
    motivating example was #5658: in particular, this change allows
    array indexing operations, which have a single DEFAULT alternative
    without any binders, to be floated inward.

    In particular, we want to be able to transform

      case indexIntArray# arr i of vi {
        __DEFAULT -> case <# j n of _ {
          __DEFAULT -> False
          1# -> case indexIntArray# arr j of vj {
            __DEFAULT -> ... vi ... vj ...
          }
        }
      }

    by floating in `indexIntArray# arr i` to produce

      case <# j n of _ {
        __DEFAULT -> False
        1# -> case indexIntArray# arr i of vi {
          __DEFAULT -> case indexIntArray# arr j of vj {
            __DEFAULT -> ... vi ... vj ...
          }
        }
      }

    ...which skips the `indexIntArray# arr i` call entirely in the out-of-bounds branch.

    SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
    scalars also need to be floated inward, but unpacks have a single non-DEFAULT
    alternative that binds the elements of the tuple. We now therefore also support
    floating in cases with a single alternative that may bind values.

    But there are wrinkles

    * Which unlifted cases do we float?
      See Note [Transformations affected by primop effects] in GHC.Builtin.PrimOps
      which explains:
       - We can float in or discard CanFail primops, but we can't float them out.
       - We don't want to discard a synchronous exception or side effect
         so we don't float those at all. Hence exprOkToDiscard.
       - Throwing precise exceptions is a special case of the previous point: We
         may /never/ float in a call to (something that ultimately calls)
         'raiseIO#'.
         See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.

    * Because we can float can-fail primops (array indexing, division) inwards
      but not outwards, we must be careful not to transform
         case a /# b of r -> f (F# r)
      ===>
        f (case a /# b of r -> F# r)
      because that creates a new thunk that wasn't there before.  And
      because it can't be floated out (CanFail), the thunk will stay
      there.  Disaster!  (This happened in nofib 'simple' and 'scs'.)

      Solution: only float cases into the branches of other cases, and
      not into the arguments of an application, or the RHS of a let. This
      is somewhat conservative, but it's simple.  And it still hits the
      cases like #5658.   This is implemented in sepBindsByJoinPoint;
      if is_case is False we dump all floating cases right here.

    * #14511 is another example of why we want to restrict float-in
      of case-expressions.  Consider
         case indexArray# a n of (# r #) -> writeArray# ma i (f r)
      Now, floating that indexing operation into the (f r) thunk will
      not create any new thunks, but it will keep the array 'a' alive
      for much longer than the programmer expected.

      So again, not floating a case into a let or argument seems like
      the Right Thing

    For @Case@, the possible drop points for the 'to_drop'
    bindings are:
      (a) inside the scrutinee
      (b) inside one of the alternatives/default (default FVs always /first/!).

    -}

    fiExpr Platform
    platform RevFloatInBinds
    to_drop (BoundVarSet
    _, AnnCase CoreExprWithFVs
    scrut CoreBndr
    case_bndr Type
    _ [AnnAlt AltCon
    con [CoreBndr]
    alt_bndrs CoreExprWithFVs
    rhs])
      | HasDebugCallStack => Type -> Bool
    Type -> Bool
    isUnliftedType (CoreBndr -> Type
    idType CoreBndr
    case_bndr)
         -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType
      , Expr CoreBndr -> Bool
    exprOkToDiscard (CoreExprWithFVs -> Expr CoreBndr
    forall bndr annot. AnnExpr bndr annot -> Expr bndr
    deAnnotate CoreExprWithFVs
    scrut)
          -- See Note [Floating primops]
      = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    shared_binds (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
    forall a b. (a -> b) -> a -> b
    $
        Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform (FloatInBind
    case_float FloatInBind -> RevFloatInBinds -> RevFloatInBinds
    forall a. a -> [a] -> [a]
    : RevFloatInBinds
    rhs_binds) CoreExprWithFVs
    rhs
      where
        case_float :: FloatInBind
    case_float = BoundVarSet -> BoundVarSet -> FloatBind -> FloatInBind
    FB BoundVarSet
    all_bndrs BoundVarSet
    scrut_fvs
                        (Expr CoreBndr -> CoreBndr -> AltCon -> [CoreBndr] -> FloatBind
    FloatCase Expr CoreBndr
    scrut' CoreBndr
    case_bndr AltCon
    con [CoreBndr]
    alt_bndrs)
        scrut' :: Expr CoreBndr
    scrut'     = Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    scrut_binds CoreExprWithFVs
    scrut
        rhs_fvs :: BoundVarSet
    rhs_fvs    = CoreExprWithFVs -> BoundVarSet
    freeVarsOf CoreExprWithFVs
    rhs    -- No need to delete alt_bndrs
        scrut_fvs :: BoundVarSet
    scrut_fvs  = CoreExprWithFVs -> BoundVarSet
    freeVarsOf CoreExprWithFVs
    scrut  -- See Note [Shadowing and name capture]
        all_bndrs :: BoundVarSet
    all_bndrs  = [CoreBndr] -> BoundVarSet
    mkDVarSet [CoreBndr]
    alt_bndrs BoundVarSet -> CoreBndr -> BoundVarSet
    `extendDVarSet` CoreBndr
    case_bndr

        (RevFloatInBinds
    shared_binds, [RevFloatInBinds
    scrut_binds, RevFloatInBinds
    rhs_binds])
           = Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    False RevFloatInBinds
    to_drop
                         BoundVarSet
    all_bndrs [BoundVarSet
    scrut_fvs, BoundVarSet
    rhs_fvs]

    fiExpr Platform
    platform RevFloatInBinds
    to_drop (BoundVarSet
    _, AnnCase CoreExprWithFVs
    scrut CoreBndr
    case_bndr Type
    ty [AnnAlt CoreBndr BoundVarSet]
    alts)
      = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    drop_here1 (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
    forall a b. (a -> b) -> a -> b
    $
        RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    drop_here2 (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
    forall a b. (a -> b) -> a -> b
    $
        Expr CoreBndr
    -> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    scrut_drops CoreExprWithFVs
    scrut) CoreBndr
    case_bndr Type
    ty
             (String
    -> (RevFloatInBinds -> AnnAlt CoreBndr BoundVarSet -> Alt CoreBndr)
    -> [RevFloatInBinds]
    -> [AnnAlt CoreBndr BoundVarSet]
    -> [Alt CoreBndr]
    forall a b c.
    HasDebugCallStack =>
    String -> (a -> b -> c) -> [a] -> [b] -> [c]
    zipWithEqual String
    "fiExpr" RevFloatInBinds -> AnnAlt CoreBndr BoundVarSet -> Alt CoreBndr
    fi_alt [RevFloatInBinds]
    alts_drops_s [AnnAlt CoreBndr BoundVarSet]
    alts)
             -- use zipWithEqual, we should have length alts_drops_s = length alts
      where
            -- Float into the scrut and alts-considered-together just like App
        (RevFloatInBinds
    drop_here1, [RevFloatInBinds
    scrut_drops, RevFloatInBinds
    alts_drops])
           = Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    False RevFloatInBinds
    to_drop
                 BoundVarSet
    all_alt_bndrs [BoundVarSet
    scrut_fvs, BoundVarSet
    all_alt_fvs]
                 -- all_alt_bndrs: see Note [Shadowing and name capture]

            -- Float into the alts with the is_case flag set
        (RevFloatInBinds
    drop_here2, [RevFloatInBinds]
    alts_drops_s)
           = Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    True RevFloatInBinds
    alts_drops BoundVarSet
    emptyDVarSet [BoundVarSet]
    alts_fvs

        scrut_fvs :: BoundVarSet
    scrut_fvs = CoreExprWithFVs -> BoundVarSet
    freeVarsOf CoreExprWithFVs
    scrut

        all_alt_bndrs :: BoundVarSet
    all_alt_bndrs = (AnnAlt CoreBndr BoundVarSet -> BoundVarSet -> BoundVarSet)
    -> BoundVarSet -> [AnnAlt CoreBndr BoundVarSet] -> BoundVarSet
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (BoundVarSet -> BoundVarSet -> BoundVarSet
    unionDVarSet (BoundVarSet -> BoundVarSet -> BoundVarSet)
    -> (AnnAlt CoreBndr BoundVarSet -> BoundVarSet)
    -> AnnAlt CoreBndr BoundVarSet
    -> BoundVarSet
    -> BoundVarSet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . AnnAlt CoreBndr BoundVarSet -> BoundVarSet
    forall {annot}. AnnAlt CoreBndr annot -> BoundVarSet
    ann_alt_bndrs) (CoreBndr -> BoundVarSet
    unitDVarSet CoreBndr
    case_bndr) [AnnAlt CoreBndr BoundVarSet]
    alts
        ann_alt_bndrs :: AnnAlt CoreBndr annot -> BoundVarSet
    ann_alt_bndrs (AnnAlt AltCon
    _ [CoreBndr]
    bndrs AnnExpr CoreBndr annot
    _) = [CoreBndr] -> BoundVarSet
    mkDVarSet [CoreBndr]
    bndrs

        alts_fvs :: [DVarSet]
        alts_fvs :: [BoundVarSet]
    alts_fvs = [CoreExprWithFVs -> BoundVarSet
    freeVarsOf CoreExprWithFVs
    rhs | AnnAlt AltCon
    _ [CoreBndr]
    _ CoreExprWithFVs
    rhs <- [AnnAlt CoreBndr BoundVarSet]
    alts]
                   -- No need to delete binders
                   -- See Note [Shadowing and name capture]

        all_alt_fvs :: DVarSet
        all_alt_fvs :: BoundVarSet
    all_alt_fvs = (BoundVarSet -> BoundVarSet -> BoundVarSet)
    -> BoundVarSet -> [BoundVarSet] -> BoundVarSet
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr BoundVarSet -> BoundVarSet -> BoundVarSet
    unionDVarSet (CoreBndr -> BoundVarSet
    unitDVarSet CoreBndr
    case_bndr) [BoundVarSet]
    alts_fvs

        fi_alt :: RevFloatInBinds -> AnnAlt CoreBndr BoundVarSet -> Alt CoreBndr
    fi_alt RevFloatInBinds
    to_drop (AnnAlt AltCon
    con [CoreBndr]
    args CoreExprWithFVs
    rhs) = AltCon -> [CoreBndr] -> Expr CoreBndr -> Alt CoreBndr
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    con [CoreBndr]
    args (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    to_drop CoreExprWithFVs
    rhs)

    ------------------
    fiBind :: Platform
           -> RevFloatInBinds    -- Binds we're trying to drop
                                 -- as far "inwards" as possible
           -> CoreBindWithFVs    -- Input binding
           -> DVarSet            -- Free in scope of binding
           -> ( RevFloatInBinds  -- Land these before
              , FloatInBind      -- The binding itself
              , RevFloatInBinds) -- Land these after

    fiBind :: Platform
    -> RevFloatInBinds
    -> AnnBind CoreBndr BoundVarSet
    -> BoundVarSet
    -> (RevFloatInBinds, FloatInBind, RevFloatInBinds)
    fiBind Platform
    platform RevFloatInBinds
    to_drop (AnnNonRec CoreBndr
    id ann_rhs :: CoreExprWithFVs
    ann_rhs@(BoundVarSet
    rhs_fvs, AnnExpr' CoreBndr BoundVarSet
    rhs)) BoundVarSet
    body_fvs
      = ( RevFloatInBinds
    shared_binds          -- Land these before
                                -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]
        , BoundVarSet -> BoundVarSet -> FloatBind -> FloatInBind
    FB (CoreBndr -> BoundVarSet
    unitDVarSet CoreBndr
    id) BoundVarSet
    rhs_fvs'         -- The new binding itself
              (Bind CoreBndr -> FloatBind
    FloatLet (CoreBndr -> Expr CoreBndr -> Bind CoreBndr
    forall b. b -> Expr b -> Bind b
    NonRec CoreBndr
    id Expr CoreBndr
    rhs'))
        , RevFloatInBinds
    body_binds )                         -- Land these after

      where
        body_fvs2 :: BoundVarSet
    body_fvs2 = BoundVarSet
    body_fvs BoundVarSet -> CoreBndr -> BoundVarSet
    `delDVarSet` CoreBndr
    id

        rule_fvs :: BoundVarSet
    rule_fvs = CoreBndr -> BoundVarSet
    bndrRuleAndUnfoldingVarsDSet CoreBndr
    id        -- See Note [extra_fvs (2)]
        extra_fvs :: BoundVarSet
    extra_fvs | RecFlag -> CoreBndr -> AnnExpr' CoreBndr BoundVarSet -> Bool
    noFloatIntoRhs RecFlag
    NonRecursive CoreBndr
    id AnnExpr' CoreBndr BoundVarSet
    rhs
                  = BoundVarSet
    rule_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
    `unionDVarSet` BoundVarSet
    rhs_fvs
                  | Bool
    otherwise
                  = BoundVarSet
    rule_fvs
            -- See Note [extra_fvs (1)]
            -- No point in floating in only to float straight out again
            -- We *can't* float into ok-for-speculation unlifted RHSs
            -- But do float into join points

        (RevFloatInBinds
    shared_binds, [RevFloatInBinds
    rhs_binds, RevFloatInBinds
    body_binds])
            = Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    False RevFloatInBinds
    to_drop
                          BoundVarSet
    extra_fvs [BoundVarSet
    rhs_fvs, BoundVarSet
    body_fvs2]

            -- Push rhs_binds into the right hand side of the binding
        rhs' :: Expr CoreBndr
    rhs'     = Platform
    -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
    fiRhs Platform
    platform RevFloatInBinds
    rhs_binds CoreBndr
    id CoreExprWithFVs
    ann_rhs
        rhs_fvs' :: BoundVarSet
    rhs_fvs' = BoundVarSet
    rhs_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
    `unionDVarSet` RevFloatInBinds -> BoundVarSet
    floatedBindsFVs RevFloatInBinds
    rhs_binds BoundVarSet -> BoundVarSet -> BoundVarSet
    `unionDVarSet` BoundVarSet
    rule_fvs
                            -- Don't forget the rule_fvs; the binding mentions them!

    fiBind Platform
    platform RevFloatInBinds
    to_drop (AnnRec [(CoreBndr, CoreExprWithFVs)]
    bindings) BoundVarSet
    body_fvs
      = ( RevFloatInBinds
    shared_binds
        , BoundVarSet -> BoundVarSet -> FloatBind -> FloatInBind
    FB ([CoreBndr] -> BoundVarSet
    mkDVarSet [CoreBndr]
    ids) BoundVarSet
    rhs_fvs'
             (Bind CoreBndr -> FloatBind
    FloatLet ([(CoreBndr, Expr CoreBndr)] -> Bind CoreBndr
    forall b. [(b, Expr b)] -> Bind b
    Rec ([RevFloatInBinds]
    -> [(CoreBndr, CoreExprWithFVs)] -> [(CoreBndr, Expr CoreBndr)]
    fi_bind [RevFloatInBinds]
    rhss_binds [(CoreBndr, CoreExprWithFVs)]
    bindings)))
        , RevFloatInBinds
    body_binds )
      where
        ([CoreBndr]
    ids, [CoreExprWithFVs]
    rhss) = [(CoreBndr, CoreExprWithFVs)] -> ([CoreBndr], [CoreExprWithFVs])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(CoreBndr, CoreExprWithFVs)]
    bindings
        rhss_fvs :: [BoundVarSet]
    rhss_fvs = (CoreExprWithFVs -> BoundVarSet)
    -> [CoreExprWithFVs] -> [BoundVarSet]
    forall a b. (a -> b) -> [a] -> [b]
    map CoreExprWithFVs -> BoundVarSet
    freeVarsOf [CoreExprWithFVs]
    rhss

            -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]
        rule_fvs :: BoundVarSet
    rule_fvs = (CoreBndr -> BoundVarSet) -> [CoreBndr] -> BoundVarSet
    forall a. (a -> BoundVarSet) -> [a] -> BoundVarSet
    mapUnionDVarSet CoreBndr -> BoundVarSet
    bndrRuleAndUnfoldingVarsDSet [CoreBndr]
    ids
        extra_fvs :: BoundVarSet
    extra_fvs = BoundVarSet
    rule_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
    `unionDVarSet`
                    [BoundVarSet] -> BoundVarSet
    unionDVarSets [ BoundVarSet
    rhs_fvs | (CoreBndr
    bndr, (BoundVarSet
    rhs_fvs, AnnExpr' CoreBndr BoundVarSet
    rhs)) <- [(CoreBndr, CoreExprWithFVs)]
    bindings
                                  , RecFlag -> CoreBndr -> AnnExpr' CoreBndr BoundVarSet -> Bool
    noFloatIntoRhs RecFlag
    Recursive CoreBndr
    bndr AnnExpr' CoreBndr BoundVarSet
    rhs ]

        (RevFloatInBinds
    shared_binds, RevFloatInBinds
    body_binds:[RevFloatInBinds]
    rhss_binds)
            = Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    False RevFloatInBinds
    to_drop
                           BoundVarSet
    extra_fvs (BoundVarSet
    body_fvsBoundVarSet -> [BoundVarSet] -> [BoundVarSet]
    forall a. a -> [a] -> [a]
    :[BoundVarSet]
    rhss_fvs)

        rhs_fvs' :: BoundVarSet
    rhs_fvs' = [BoundVarSet] -> BoundVarSet
    unionDVarSets [BoundVarSet]
    rhss_fvs BoundVarSet -> BoundVarSet -> BoundVarSet
    `unionDVarSet`
                   [BoundVarSet] -> BoundVarSet
    unionDVarSets ((RevFloatInBinds -> BoundVarSet)
    -> [RevFloatInBinds] -> [BoundVarSet]
    forall a b. (a -> b) -> [a] -> [b]
    map RevFloatInBinds -> BoundVarSet
    floatedBindsFVs [RevFloatInBinds]
    rhss_binds) BoundVarSet -> BoundVarSet -> BoundVarSet
    `unionDVarSet`
                   BoundVarSet
    rule_fvs         -- Don't forget the rule variables!

        -- Push rhs_binds into the right hand side of the binding
        fi_bind :: [RevFloatInBinds]   -- One per "drop pt" conjured w/ fvs_of_rhss
                -> [(Id, CoreExprWithFVs)]
                -> [(Id, CoreExpr)]

        fi_bind :: [RevFloatInBinds]
    -> [(CoreBndr, CoreExprWithFVs)] -> [(CoreBndr, Expr CoreBndr)]
    fi_bind [RevFloatInBinds]
    to_drops [(CoreBndr, CoreExprWithFVs)]
    pairs
          = [ (CoreBndr
    binder, Platform
    -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
    fiRhs Platform
    platform RevFloatInBinds
    to_drop CoreBndr
    binder CoreExprWithFVs
    rhs)
            | ((CoreBndr
    binder, CoreExprWithFVs
    rhs), RevFloatInBinds
    to_drop) <- String
    -> [(CoreBndr, CoreExprWithFVs)]
    -> [RevFloatInBinds]
    -> [((CoreBndr, CoreExprWithFVs), RevFloatInBinds)]
    forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
    zipEqual String
    "fi_bind" [(CoreBndr, CoreExprWithFVs)]
    pairs [RevFloatInBinds]
    to_drops ]

    ------------------
    fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
    fiRhs :: Platform
    -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> Expr CoreBndr
    fiRhs Platform
    platform RevFloatInBinds
    to_drop CoreBndr
    bndr CoreExprWithFVs
    rhs
      | JoinPoint Int
    join_arity <- CoreBndr -> JoinPointHood
    idJoinPointHood CoreBndr
    bndr
      , let ([CoreBndr]
    bndrs, CoreExprWithFVs
    body) = Int -> CoreExprWithFVs -> ([CoreBndr], CoreExprWithFVs)
    forall bndr annot.
    Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
    collectNAnnBndrs Int
    join_arity CoreExprWithFVs
    rhs
      = [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
    forall b. [b] -> Expr b -> Expr b
    mkLams [CoreBndr]
    bndrs (Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    to_drop CoreExprWithFVs
    body)
      | Bool
    otherwise
      = Platform -> RevFloatInBinds -> CoreExprWithFVs -> Expr CoreBndr
    fiExpr Platform
    platform RevFloatInBinds
    to_drop CoreExprWithFVs
    rhs

    ------------------
    noFloatIntoLam :: [Var] -> Bool
    noFloatIntoLam :: [CoreBndr] -> Bool
    noFloatIntoLam [CoreBndr]
    bndrs = (CoreBndr -> Bool) -> [CoreBndr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any CoreBndr -> Bool
    bad [CoreBndr]
    bndrs
      where
        bad :: CoreBndr -> Bool
    bad CoreBndr
    b = CoreBndr -> Bool
    isId CoreBndr
    b Bool -> Bool -> Bool
    && Bool -> Bool
    not (CoreBndr -> Bool
    isOneShotBndr CoreBndr
    b)
        -- Don't float inside a non-one-shot lambda

    noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
    -- ^ True if it's a bad idea to float bindings into this RHS
    noFloatIntoRhs :: RecFlag -> CoreBndr -> AnnExpr' CoreBndr BoundVarSet -> Bool
    noFloatIntoRhs RecFlag
    is_rec CoreBndr
    bndr AnnExpr' CoreBndr BoundVarSet
    rhs
      | CoreBndr -> Bool
    isJoinId CoreBndr
    bndr
      = RecFlag -> Bool
    isRec RecFlag
    is_rec -- Joins are one-shot iff non-recursive

      | Type -> Bool
    definitelyUnliftedType (CoreBndr -> Type
    idType CoreBndr
    bndr)
      = Bool
    True  -- Preserve let-can-float invariant, see Note [noFloatInto considerations]

      | Bool
    otherwise
      = AnnExpr' CoreBndr BoundVarSet -> Bool
    noFloatIntoArg AnnExpr' CoreBndr BoundVarSet
    rhs

    noFloatIntoArg :: CoreExprWithFVs' -> Bool
    noFloatIntoArg :: AnnExpr' CoreBndr BoundVarSet -> Bool
    noFloatIntoArg AnnExpr' CoreBndr BoundVarSet
    expr
       | AnnLam CoreBndr
    bndr CoreExprWithFVs
    e <- AnnExpr' CoreBndr BoundVarSet
    expr
       , ([CoreBndr]
    bndrs, CoreExprWithFVs
    _) <- CoreExprWithFVs -> ([CoreBndr], CoreExprWithFVs)
    forall bndr annot.
    AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
    collectAnnBndrs CoreExprWithFVs
    e
       =  [CoreBndr] -> Bool
    noFloatIntoLam (CoreBndr
    bndrCoreBndr -> [CoreBndr] -> [CoreBndr]
    forall a. a -> [a] -> [a]
    :[CoreBndr]
    bndrs)  -- Wrinkle 1 (a)
       Bool -> Bool -> Bool
    || (CoreBndr -> Bool) -> [CoreBndr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all CoreBndr -> Bool
    isTyVar (CoreBndr
    bndrCoreBndr -> [CoreBndr] -> [CoreBndr]
    forall a. a -> [a] -> [a]
    :[CoreBndr]
    bndrs)     -- Wrinkle 1 (b)
          -- See Note [noFloatInto considerations] wrinkle 2

      | Bool
    otherwise  -- See Note [noFloatInto considerations] wrinkle 2
      = Expr CoreBndr -> Bool
    exprIsTrivial Expr CoreBndr
    deann_expr Bool -> Bool -> Bool
    || Expr CoreBndr -> Bool
    exprIsHNF Expr CoreBndr
    deann_expr
      where
        deann_expr :: Expr CoreBndr
    deann_expr = AnnExpr' CoreBndr BoundVarSet -> Expr CoreBndr
    forall bndr annot. AnnExpr' bndr annot -> Expr bndr
    deAnnotate' AnnExpr' CoreBndr BoundVarSet
    expr

    {- Note [noFloatInto considerations]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When do we want to float bindings into
       - noFloatIntoRhs: the RHS of a let-binding
       - noFloatIntoArg: the argument of a function application

    Definitely don't float into RHS if it has unlifted type;
    that would destroy the let-can-float invariant.

    * Wrinkle 1: do not float in if
         (a) any non-one-shot value lambdas
      or (b) all type lambdas
      In both cases we'll float straight back out again
      NB: Must line up with fiExpr (AnnLam...); see #7088

      (a) is important: we /must/ float into a one-shot lambda group
      (which includes join points). This makes a big difference
      for things like
         f x# = let x = I# x#
                in let j = \() -> ...x...
                   in if <condition> then normal-path else j ()
      If x is used only in the error case join point, j, we must float the
      boxing constructor into it, else we box it every time which is very
      bad news indeed.

    * Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right
      back out again... not tragic, but a waste of time.

      For function arguments we will still end up with this
      in-then-out stuff; consider
        letrec x = e in f x
      Here x is not a HNF, so we'll produce
        f (letrec x = e in x)
      which is OK... it's not that common, and we'll end up
      floating out again, in CorePrep if not earlier.
      Still, we use exprIsTrivial to catch this case (sigh)

    ************************************************************************
    *                                                                      *
    \subsection{@sepBindsByDropPoint@}
    *                                                                      *
    ************************************************************************

    This is the crucial function.  The idea is: We have a wad of bindings
    that we'd like to distribute inside a collection of {\em drop points};
    insides the alternatives of a \tr{case} would be one example of some
    drop points; the RHS and body of a non-recursive \tr{let} binding
    would be another (2-element) collection.

    So: We're given a list of sets-of-free-variables, one per drop point,
    and a list of floating-inwards bindings.  If a binding can go into
    only one drop point (without suddenly making something out-of-scope),
    in it goes.  If a binding is used inside {\em multiple} drop points,
    then it has to go in a you-must-drop-it-above-all-these-drop-points
    point.

    We have to maintain the order on these drop-point-related lists.
    -}

    -- pprFIB :: RevFloatInBinds -> SDoc
    -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]

    sepBindsByDropPoint
        :: Platform
        -> Bool                  -- True <=> is case expression
        -> RevFloatInBinds       -- Candidate floaters
        -> FreeVarSet            -- here_fvs: if these vars are free in a binding,
                                 --   don't float that binding inside any drop point
        -> [FreeVarSet]          -- fork_fvs: one set of FVs per drop point
        -> ( RevFloatInBinds     -- Bindings which must not be floated inside
           , [RevFloatInBinds] ) -- Corresponds 1-1 with the input list of FV sets

    -- Every input floater is returned somewhere in the result;
    -- none are dropped, not even ones which don't seem to be
    -- free in *any* of the drop-point fvs.  Why?  Because, for example,
    -- a binding (let x = E in B) might have a specialised version of
    -- x (say x') stored inside x, but x' isn't free in E or B.
    --
    -- The here_fvs argument is used for two things:
    -- * Avoid shadowing bugs: see Note [Shadowing and name capture]
    -- * Drop some of the bindings at the top, e.g. of an application

    type DropBox = (FreeVarSet, FloatInBinds)

    dropBoxFloats :: DropBox -> RevFloatInBinds
    dropBoxFloats :: DropBox -> RevFloatInBinds
    dropBoxFloats (BoundVarSet
    _, RevFloatInBinds
    floats) = RevFloatInBinds -> RevFloatInBinds
    forall a. [a] -> [a]
    reverse RevFloatInBinds
    floats

    usedInDropBox :: DIdSet -> DropBox -> Bool
    usedInDropBox :: BoundVarSet -> DropBox -> Bool
    usedInDropBox BoundVarSet
    bndrs (BoundVarSet
    db_fvs, RevFloatInBinds
    _) = BoundVarSet
    db_fvs BoundVarSet -> BoundVarSet -> Bool
    `intersectsDVarSet` BoundVarSet
    bndrs

    initDropBox :: DVarSet -> DropBox
    initDropBox :: BoundVarSet -> DropBox
    initDropBox BoundVarSet
    fvs = (BoundVarSet
    fvs, [])

    sepBindsByDropPoint :: Platform
    -> Bool
    -> RevFloatInBinds
    -> BoundVarSet
    -> [BoundVarSet]
    -> (RevFloatInBinds, [RevFloatInBinds])
    sepBindsByDropPoint Platform
    platform Bool
    is_case RevFloatInBinds
    floaters BoundVarSet
    here_fvs [BoundVarSet]
    fork_fvs
      | RevFloatInBinds -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null RevFloatInBinds
    floaters  -- Shortcut common case
      = ([], [[] | BoundVarSet
    _ <- [BoundVarSet]
    fork_fvs])

      | Bool
    otherwise
      = RevFloatInBinds
    -> DropBox -> [DropBox] -> (RevFloatInBinds, [RevFloatInBinds])
    go RevFloatInBinds
    floaters (BoundVarSet -> DropBox
    initDropBox BoundVarSet
    here_fvs) ((BoundVarSet -> DropBox) -> [BoundVarSet] -> [DropBox]
    forall a b. (a -> b) -> [a] -> [b]
    map BoundVarSet -> DropBox
    initDropBox [BoundVarSet]
    fork_fvs)
      where
        n_alts :: Int
    n_alts = [BoundVarSet] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [BoundVarSet]
    fork_fvs

        go :: RevFloatInBinds -> DropBox -> [DropBox]
           -> (RevFloatInBinds, [RevFloatInBinds])
            -- The *first* one in the pair is the drop_here set

        go :: RevFloatInBinds
    -> DropBox -> [DropBox] -> (RevFloatInBinds, [RevFloatInBinds])
    go [] DropBox
    here_box [DropBox]
    fork_boxes
            = (DropBox -> RevFloatInBinds
    dropBoxFloats DropBox
    here_box, (DropBox -> RevFloatInBinds) -> [DropBox] -> [RevFloatInBinds]
    forall a b. (a -> b) -> [a] -> [b]
    map DropBox -> RevFloatInBinds
    dropBoxFloats [DropBox]
    fork_boxes)

        go (bind_w_fvs :: FloatInBind
    bind_w_fvs@(FB BoundVarSet
    bndrs BoundVarSet
    bind_fvs FloatBind
    bind) : RevFloatInBinds
    binds) DropBox
    here_box [DropBox]
    fork_boxes
            | Bool
    drop_here = RevFloatInBinds
    -> DropBox -> [DropBox] -> (RevFloatInBinds, [RevFloatInBinds])
    go RevFloatInBinds
    binds (DropBox -> DropBox
    insert DropBox
    here_box) [DropBox]
    fork_boxes
            | Bool
    otherwise = RevFloatInBinds
    -> DropBox -> [DropBox] -> (RevFloatInBinds, [RevFloatInBinds])
    go RevFloatInBinds
    binds DropBox
    here_box          [DropBox]
    new_fork_boxes
            where
              -- "here" means the group of bindings dropped at the top of the fork

              used_here :: Bool
    used_here     = BoundVarSet
    bndrs BoundVarSet -> DropBox -> Bool
    `usedInDropBox` DropBox
    here_box
              used_in_flags :: [Bool]
    used_in_flags = case [DropBox]
    fork_boxes of
                                []  -> []
                                [DropBox
    _] -> [Bool
    True]  -- Push all bindings into a single branch
                                               -- No need to look at its free vars
                                [DropBox]
    _   -> (DropBox -> Bool) -> [DropBox] -> [Bool]
    forall a b. (a -> b) -> [a] -> [b]
    map (BoundVarSet
    bndrs BoundVarSet -> DropBox -> Bool
    `usedInDropBox`) [DropBox]
    fork_boxes
                   -- Short-cut for the singleton case;
                   -- used for lambdas and singleton cases

              drop_here :: Bool
    drop_here = Bool
    used_here Bool -> Bool -> Bool
    || Bool
    cant_push

              n_used_alts :: Int
    n_used_alts = (Bool -> Bool) -> [Bool] -> Int
    forall a. (a -> Bool) -> [a] -> Int
    count Bool -> Bool
    forall a. a -> a
    id [Bool]
    used_in_flags -- returns number of Trues in list.

              cant_push :: Bool
    cant_push
                | Bool
    is_case   = (Int
    n_alts Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    1 Bool -> Bool -> Bool
    && Int
    n_used_alts Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    n_alts)
                                 -- Used in all, muliple branches, don't push
                              Bool -> Bool -> Bool
    || (Int
    n_used_alts Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    1 Bool -> Bool -> Bool
    && Bool -> Bool
    not (Platform -> FloatBind -> Bool
    floatIsDupable Platform
    platform FloatBind
    bind))
                                 -- floatIsDupable: see Note [Duplicating floats]

                | Bool
    otherwise = FloatBind -> Bool
    floatIsCase FloatBind
    bind Bool -> Bool -> Bool
    || Int
    n_used_alts Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    1
                                 -- floatIsCase: see Note [Floating primops]

              new_fork_boxes :: [DropBox]
    new_fork_boxes = String
    -> (DropBox -> Bool -> DropBox) -> [DropBox] -> [Bool] -> [DropBox]
    forall a b c.
    HasDebugCallStack =>
    String -> (a -> b -> c) -> [a] -> [b] -> [c]
    zipWithEqual String
    "FloatIn.sepBinds" DropBox -> Bool -> DropBox
    insert_maybe
                                            [DropBox]
    fork_boxes [Bool]
    used_in_flags

              insert :: DropBox -> DropBox
              insert :: DropBox -> DropBox
    insert (BoundVarSet
    fvs,RevFloatInBinds
    drops) = (BoundVarSet
    fvs BoundVarSet -> BoundVarSet -> BoundVarSet
    `unionDVarSet` BoundVarSet
    bind_fvs, FloatInBind
    bind_w_fvsFloatInBind -> RevFloatInBinds -> RevFloatInBinds
    forall a. a -> [a] -> [a]
    :RevFloatInBinds
    drops)

              insert_maybe :: DropBox -> Bool -> DropBox
    insert_maybe DropBox
    box Bool
    True  = DropBox -> DropBox
    insert DropBox
    box
              insert_maybe DropBox
    box Bool
    False = DropBox
    box

    {- Note [Duplicating floats]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For case expressions we duplicate the binding if it is reasonably
    small, and if it is not used in all the RHSs This is good for
    situations like
         let x = I# y in
         case e of
           C -> error x
           D -> error x
           E -> ...not mentioning x...

    If the thing is used in all RHSs there is nothing gained,
    so we don't duplicate then.
    -}

    floatedBindsFVs :: RevFloatInBinds -> FreeVarSet
    floatedBindsFVs :: RevFloatInBinds -> BoundVarSet
    floatedBindsFVs RevFloatInBinds
    binds = (FloatInBind -> BoundVarSet) -> RevFloatInBinds -> BoundVarSet
    forall a. (a -> BoundVarSet) -> [a] -> BoundVarSet
    mapUnionDVarSet FloatInBind -> BoundVarSet
    fbFVs RevFloatInBinds
    binds

    fbFVs :: FloatInBind -> DVarSet
    fbFVs :: FloatInBind -> BoundVarSet
    fbFVs (FB BoundVarSet
    _ BoundVarSet
    fvs FloatBind
    _) = BoundVarSet
    fvs

    wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr
    -- Remember RevFloatInBinds is in *reverse* dependency order
    wrapFloats :: RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats []               Expr CoreBndr
    e = Expr CoreBndr
    e
    wrapFloats (FB BoundVarSet
    _ BoundVarSet
    _ FloatBind
    fl : RevFloatInBinds
    bs) Expr CoreBndr
    e = RevFloatInBinds -> Expr CoreBndr -> Expr CoreBndr
    wrapFloats RevFloatInBinds
    bs (FloatBind -> Expr CoreBndr -> Expr CoreBndr
    wrapFloat FloatBind
    fl Expr CoreBndr
    e)

    floatIsDupable :: Platform -> FloatBind -> Bool
    floatIsDupable :: Platform -> FloatBind -> Bool
    floatIsDupable Platform
    platform (FloatCase Expr CoreBndr
    scrut CoreBndr
    _ AltCon
    _ [CoreBndr]
    _) = Platform -> Expr CoreBndr -> Bool
    exprIsDupable Platform
    platform Expr CoreBndr
    scrut
    floatIsDupable Platform
    platform (FloatLet (Rec [(CoreBndr, Expr CoreBndr)]
    prs))    = ((CoreBndr, Expr CoreBndr) -> Bool)
    -> [(CoreBndr, Expr CoreBndr)] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Platform -> Expr CoreBndr -> Bool
    exprIsDupable Platform
    platform (Expr CoreBndr -> Bool)
    -> ((CoreBndr, Expr CoreBndr) -> Expr CoreBndr)
    -> (CoreBndr, Expr CoreBndr)
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (CoreBndr, Expr CoreBndr) -> Expr CoreBndr
    forall a b. (a, b) -> b
    snd) [(CoreBndr, Expr CoreBndr)]
    prs
    floatIsDupable Platform
    platform (FloatLet (NonRec CoreBndr
    _ Expr CoreBndr
    r)) = Platform -> Expr CoreBndr -> Bool
    exprIsDupable Platform
    platform Expr CoreBndr
    r

    floatIsCase :: FloatBind -> Bool
    floatIsCase :: FloatBind -> Bool
    floatIsCase (FloatCase {}) = Bool
    True
    floatIsCase (FloatLet {})  = Bool
    False