{-
(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, isJoinId_maybe )
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).

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, 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, beause 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.

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 [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which
  explains:
   - We can float in can_fail primops (which concerns imprecise exceptions),
     but we can't float them out.
   - But we can float a has_side_effects primop, but NOT inside a lambda,
     so for now we don't float them at all. Hence exprOkForSideEffects.
   - 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 (can_fail), 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
exprOkForSideEffects (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
  | Just Int
join_arity <- CoreBndr -> Maybe Int
isJoinId_maybe 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