never executed always true always false
    1 {-
    2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    3 
    4 ************************************************************************
    5 *                                                                      *
    6 \section[FloatIn]{Floating Inwards pass}
    7 *                                                                      *
    8 ************************************************************************
    9 
   10 The main purpose of @floatInwards@ is floating into branches of a
   11 case, so that we don't allocate things, save them on the stack, and
   12 then discover that they aren't needed in the chosen branch.
   13 -}
   14 
   15 
   16 {-# OPTIONS_GHC -fprof-auto #-}
   17 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
   18 
   19 module GHC.Core.Opt.FloatIn ( floatInwards ) where
   20 
   21 import GHC.Prelude
   22 import GHC.Platform
   23 
   24 import GHC.Core
   25 import GHC.Core.Make hiding ( wrapFloats )
   26 import GHC.Core.Utils
   27 import GHC.Core.FVs
   28 import GHC.Core.Type
   29 
   30 import GHC.Types.Basic      ( RecFlag(..), isRec )
   31 import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )
   32 import GHC.Types.Tickish
   33 import GHC.Types.Var
   34 import GHC.Types.Var.Set
   35 
   36 import GHC.Utils.Misc
   37 import GHC.Utils.Panic
   38 import GHC.Utils.Panic.Plain
   39 
   40 {-
   41 Top-level interface function, @floatInwards@.  Note that we do not
   42 actually float any bindings downwards from the top-level.
   43 -}
   44 
   45 floatInwards :: Platform -> CoreProgram -> CoreProgram
   46 floatInwards platform binds = map (fi_top_bind platform) binds
   47   where
   48     fi_top_bind platform (NonRec binder rhs)
   49       = NonRec binder (fiExpr platform [] (freeVars rhs))
   50     fi_top_bind platform (Rec pairs)
   51       = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ]
   52 
   53 
   54 {-
   55 ************************************************************************
   56 *                                                                      *
   57 \subsection{Mail from Andr\'e [edited]}
   58 *                                                                      *
   59 ************************************************************************
   60 
   61 {\em Will wrote: What??? I thought the idea was to float as far
   62 inwards as possible, no matter what.  This is dropping all bindings
   63 every time it sees a lambda of any kind.  Help! }
   64 
   65 You are assuming we DO DO full laziness AFTER floating inwards!  We
   66 have to [not float inside lambdas] if we don't.
   67 
   68 If we indeed do full laziness after the floating inwards (we could
   69 check the compilation flags for that) then I agree we could be more
   70 aggressive and do float inwards past lambdas.
   71 
   72 Actually we are not doing a proper full laziness (see below), which
   73 was another reason for not floating inwards past a lambda.
   74 
   75 This can easily be fixed.  The problem is that we float lets outwards,
   76 but there are a few expressions which are not let bound, like case
   77 scrutinees and case alternatives.  After floating inwards the
   78 simplifier could decide to inline the let and the laziness would be
   79 lost, e.g.
   80 
   81 \begin{verbatim}
   82 let a = expensive             ==> \b -> case expensive of ...
   83 in \ b -> case a of ...
   84 \end{verbatim}
   85 The fix is
   86 \begin{enumerate}
   87 \item
   88 to let bind the algebraic case scrutinees (done, I think) and
   89 the case alternatives (except the ones with an
   90 unboxed type)(not done, I think). This is best done in the
   91 GHC.Core.Opt.SetLevels module, which tags things with their level numbers.
   92 \item
   93 do the full laziness pass (floating lets outwards).
   94 \item
   95 simplify. The simplifier inlines the (trivial) lets that were
   96  created but were not floated outwards.
   97 \end{enumerate}
   98 
   99 With the fix I think Will's suggestion that we can gain even more from
  100 strictness by floating inwards past lambdas makes sense.
  101 
  102 We still gain even without going past lambdas, as things may be
  103 strict in the (new) context of a branch (where it was floated to) or
  104 of a let rhs, e.g.
  105 \begin{verbatim}
  106 let a = something            case x of
  107 in case x of                   alt1 -> case something of a -> a + a
  108      alt1 -> a + a      ==>    alt2 -> b
  109      alt2 -> b
  110 
  111 let a = something           let b = case something of a -> a + a
  112 in let b = a + a        ==> in (b,b)
  113 in (b,b)
  114 \end{verbatim}
  115 Also, even if a is not found to be strict in the new context and is
  116 still left as a let, if the branch is not taken (or b is not entered)
  117 the closure for a is not built.
  118 
  119 ************************************************************************
  120 *                                                                      *
  121 \subsection{Main floating-inwards code}
  122 *                                                                      *
  123 ************************************************************************
  124 -}
  125 
  126 type FreeVarSet  = DIdSet
  127 type BoundVarSet = DIdSet
  128 
  129 data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
  130         -- The FreeVarSet is the free variables of the binding.  In the case
  131         -- of recursive bindings, the set doesn't include the bound
  132         -- variables.
  133 
  134 type FloatInBinds = [FloatInBind]
  135         -- In reverse dependency order (innermost binder first)
  136 
  137 fiExpr :: Platform
  138        -> FloatInBinds      -- Binds we're trying to drop
  139                             -- as far "inwards" as possible
  140        -> CoreExprWithFVs   -- Input expr
  141        -> CoreExpr          -- Result
  142 
  143 fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)
  144                                        -- See Note [Dead bindings]
  145 fiExpr _ to_drop (_, AnnType ty)     = assert (null to_drop) $ Type ty
  146 fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)
  147 fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
  148 fiExpr platform to_drop (_, AnnCast expr (co_ann, co))
  149   = wrapFloats (drop_here ++ co_drop) $
  150     Cast (fiExpr platform e_drop expr) co
  151   where
  152     [drop_here, e_drop, co_drop]
  153       = sepBindsByDropPoint platform False
  154           [freeVarsOf expr, freeVarsOfAnn co_ann]
  155           to_drop
  156 
  157 {-
  158 Applications: we do float inside applications, mainly because we
  159 need to get at all the arguments.  The next simplifier run will
  160 pull out any silly ones.
  161 -}
  162 
  163 fiExpr platform to_drop ann_expr@(_,AnnApp {})
  164   = wrapFloats drop_here $ wrapFloats extra_drop $
  165     mkTicks ticks $
  166     mkApps (fiExpr platform fun_drop ann_fun)
  167            (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)
  168            -- use zipWithEqual, we should have
  169            -- length ann_args = length arg_fvs = length arg_drops
  170   where
  171     (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
  172     fun_ty  = exprType (deAnnotate ann_fun)
  173     fun_fvs = freeVarsOf ann_fun
  174     arg_fvs = map freeVarsOf ann_args
  175 
  176     (drop_here : extra_drop : fun_drop : arg_drops)
  177        = sepBindsByDropPoint platform False
  178                              (extra_fvs : fun_fvs : arg_fvs)
  179                              to_drop
  180          -- Shortcut behaviour: if to_drop is empty,
  181          -- sepBindsByDropPoint returns a suitable bunch of empty
  182          -- lists without evaluating extra_fvs, and hence without
  183          -- peering into each argument
  184 
  185     (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args
  186     extra_fvs0 = case ann_fun of
  187                    (_, AnnVar _) -> fun_fvs
  188                    _             -> emptyDVarSet
  189           -- Don't float the binding for f into f x y z; see Note [Join points]
  190           -- for why we *can't* do it when f is a join point. (If f isn't a
  191           -- join point, floating it in isn't especially harmful but it's
  192           -- useless since the simplifier will immediately float it back out.)
  193 
  194     add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)
  195     add_arg (fun_ty, extra_fvs) (_, AnnType ty)
  196       = (piResultTy fun_ty ty, extra_fvs)
  197 
  198     add_arg (fun_ty, extra_fvs) (arg_fvs, arg)
  199       | noFloatIntoArg arg arg_ty
  200       = (res_ty, extra_fvs `unionDVarSet` arg_fvs)
  201       | otherwise
  202       = (res_ty, extra_fvs)
  203       where
  204        (_, arg_ty, res_ty) = splitFunTy fun_ty
  205 
  206 {- Note [Dead bindings]
  207 ~~~~~~~~~~~~~~~~~~~~~~~
  208 At a literal we won't usually have any floated bindings; the
  209 only way that can happen is if the binding wrapped the literal
  210 /in the original input program/.  e.g.
  211    case x of { DEFAULT -> 1# }
  212 But, while this may be unusual it is not actually wrong, and it did
  213 once happen (#15696).
  214 
  215 Note [Do not destroy the let/app invariant]
  216 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  217 Watch out for
  218    f (x +# y)
  219 We don't want to float bindings into here
  220    f (case ... of { x -> x +# y })
  221 because that might destroy the let/app invariant, which requires
  222 unlifted function arguments to be ok-for-speculation.
  223 
  224 Note [Join points]
  225 ~~~~~~~~~~~~~~~~~~
  226 Generally, we don't need to worry about join points - there are places we're
  227 not allowed to float them, but since they can't have occurrences in those
  228 places, we're not tempted.
  229 
  230 We do need to be careful about jumps, however:
  231 
  232   joinrec j x y z = ... in
  233   jump j a b c
  234 
  235 Previous versions often floated the definition of a recursive function into its
  236 only non-recursive occurrence. But for a join point, this is a disaster:
  237 
  238   (joinrec j x y z = ... in
  239   jump j) a b c -- wrong!
  240 
  241 Every jump must be exact, so the jump to j must have three arguments. Hence
  242 we're careful not to float into the target of a jump (though we can float into
  243 the arguments just fine).
  244 
  245 Note [Floating in past a lambda group]
  246 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  247 * We must be careful about floating inside a value lambda.
  248   That risks losing laziness.
  249   The float-out pass might rescue us, but then again it might not.
  250 
  251 * We must be careful about type lambdas too.  At one time we did, and
  252   there is no risk of duplicating work thereby, but we do need to be
  253   careful.  In particular, here is a bad case (it happened in the
  254   cichelli benchmark:
  255         let v = ...
  256         in let f = /\t -> \a -> ...
  257            ==>
  258         let f = /\t -> let v = ... in \a -> ...
  259   This is bad as now f is an updatable closure (update PAP)
  260   and has arity 0.
  261 
  262 * Hack alert!  We only float in through one-shot lambdas,
  263   not (as you might guess) through lone big lambdas.
  264   Reason: we float *out* past big lambdas (see the test in the Lam
  265   case of FloatOut.floatExpr) and we don't want to float straight
  266   back in again.
  267 
  268   It *is* important to float into one-shot lambdas, however;
  269   see the remarks with noFloatIntoRhs.
  270 
  271 So we treat lambda in groups, using the following rule:
  272 
  273  Float in if (a) there is at least one Id,
  274          and (b) there are no non-one-shot Ids
  275 
  276  Otherwise drop all the bindings outside the group.
  277 
  278 This is what the 'go' function in the AnnLam case is doing.
  279 
  280 (Join points are handled similarly: a join point is considered one-shot iff
  281 it's non-recursive, so we float only into non-recursive join points.)
  282 
  283 Urk! if all are tyvars, and we don't float in, we may miss an
  284       opportunity to float inside a nested case branch
  285 
  286 
  287 Note [Floating coercions]
  288 ~~~~~~~~~~~~~~~~~~~~~~~~~
  289 We could, in principle, have a coercion binding like
  290    case f x of co { DEFAULT -> e1 e2 }
  291 It's not common to have a function that returns a coercion, but nothing
  292 in Core prohibits it.  If so, 'co' might be mentioned in e1 or e2
  293 /only in a type/.  E.g. suppose e1 was
  294   let (x :: Int |> co) = blah in blah2
  295 
  296 
  297 But, with coercions appearing in types, there is a complication: we
  298 might be floating in a "strict let" -- that is, a case. Case expressions
  299 mention their return type. We absolutely can't float a coercion binding
  300 inward to the point that the type of the expression it's about to wrap
  301 mentions the coercion. So we include the union of the sets of free variables
  302 of the types of all the drop points involved. If any of the floaters
  303 bind a coercion variable mentioned in any of the types, that binder must
  304 be dropped right away.
  305 
  306 -}
  307 
  308 fiExpr platform to_drop lam@(_, AnnLam _ _)
  309   | noFloatIntoLam bndrs       -- Dump it all here
  310      -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088
  311   = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))
  312 
  313   | otherwise           -- Float inside
  314   = mkLams bndrs (fiExpr platform to_drop body)
  315 
  316   where
  317     (bndrs, body) = collectAnnBndrs lam
  318 
  319 {-
  320 We don't float lets inwards past an SCC.
  321         ToDo: keep info on current cc, and when passing
  322         one, if it is not the same, annotate all lets in binds with current
  323         cc, change current cc to the new one and float binds into expr.
  324 -}
  325 
  326 fiExpr platform to_drop (_, AnnTick tickish expr)
  327   | tickish `tickishScopesLike` SoftScope
  328   = Tick tickish (fiExpr platform to_drop expr)
  329 
  330   | otherwise -- Wimp out for now - we could push values in
  331   = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr))
  332 
  333 {-
  334 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
  335 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
  336 or~(b2), in each of the RHSs of the pairs of a @Rec@.
  337 
  338 Note that we do {\em weird things} with this let's binding.  Consider:
  339 \begin{verbatim}
  340 let
  341     w = ...
  342 in {
  343     let v = ... w ...
  344     in ... v .. w ...
  345 }
  346 \end{verbatim}
  347 Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
  348 body of the inner let, we could panic and leave \tr{w}'s binding where
  349 it is.  But \tr{v} is floatable further into the body of the inner let, and
  350 {\em then} \tr{w} will also be only in the body of that inner let.
  351 
  352 So: rather than drop \tr{w}'s binding here, we add it onto the list of
  353 things to drop in the outer let's body, and let nature take its
  354 course.
  355 
  356 Note [extra_fvs (1): avoid floating into RHS]
  357 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  358 Consider let x=\y....t... in body.  We do not necessarily want to float
  359 a binding for t into the RHS, because it'll immediately be floated out
  360 again.  (It won't go inside the lambda else we risk losing work.)
  361 In letrec, we need to be more careful still. We don't want to transform
  362         let x# = y# +# 1#
  363         in
  364         letrec f = \z. ...x#...f...
  365         in ...
  366 into
  367         letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
  368 because now we can't float the let out again, because a letrec
  369 can't have unboxed bindings.
  370 
  371 So we make "extra_fvs" which is the rhs_fvs of such bindings, and
  372 arrange to dump bindings that bind extra_fvs before the entire let.
  373 
  374 Note [extra_fvs (2): free variables of rules]
  375 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  376 Consider
  377   let x{rule mentioning y} = rhs in body
  378 Here y is not free in rhs or body; but we still want to dump bindings
  379 that bind y outside the let.  So we augment extra_fvs with the
  380 idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
  381 idFreeVars.
  382 -}
  383 
  384 fiExpr platform to_drop (_,AnnLet bind body)
  385   = fiExpr platform (after ++ new_float : before) body
  386            -- to_drop is in reverse dependency order
  387   where
  388     (before, new_float, after) = fiBind platform to_drop bind body_fvs
  389     body_fvs    = freeVarsOf body
  390 
  391 {- Note [Floating primops]
  392 ~~~~~~~~~~~~~~~~~~~~~~~~~~
  393 We try to float-in a case expression over an unlifted type.  The
  394 motivating example was #5658: in particular, this change allows
  395 array indexing operations, which have a single DEFAULT alternative
  396 without any binders, to be floated inward.
  397 
  398 SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
  399 scalars also need to be floated inward, but unpacks have a single non-DEFAULT
  400 alternative that binds the elements of the tuple. We now therefore also support
  401 floating in cases with a single alternative that may bind values.
  402 
  403 But there are wrinkles
  404 
  405 * Which unlifted cases do we float?
  406   See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which
  407   explains:
  408    - We can float in can_fail primops (which concerns imprecise exceptions),
  409      but we can't float them out.
  410    - But we can float a has_side_effects primop, but NOT inside a lambda,
  411      so for now we don't float them at all. Hence exprOkForSideEffects.
  412    - Throwing precise exceptions is a special case of the previous point: We
  413      may /never/ float in a call to (something that ultimately calls)
  414      'raiseIO#'.
  415      See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.
  416 
  417 * Because we can float can-fail primops (array indexing, division) inwards
  418   but not outwards, we must be careful not to transform
  419      case a /# b of r -> f (F# r)
  420   ===>
  421     f (case a /# b of r -> F# r)
  422   because that creates a new thunk that wasn't there before.  And
  423   because it can't be floated out (can_fail), the thunk will stay
  424   there.  Disaster!  (This happened in nofib 'simple' and 'scs'.)
  425 
  426   Solution: only float cases into the branches of other cases, and
  427   not into the arguments of an application, or the RHS of a let. This
  428   is somewhat conservative, but it's simple.  And it still hits the
  429   cases like #5658.   This is implemented in sepBindsByJoinPoint;
  430   if is_case is False we dump all floating cases right here.
  431 
  432 * #14511 is another example of why we want to restrict float-in
  433   of case-expressions.  Consider
  434      case indexArray# a n of (# r #) -> writeArray# ma i (f r)
  435   Now, floating that indexing operation into the (f r) thunk will
  436   not create any new thunks, but it will keep the array 'a' alive
  437   for much longer than the programmer expected.
  438 
  439   So again, not floating a case into a let or argument seems like
  440   the Right Thing
  441 
  442 For @Case@, the possible drop points for the 'to_drop'
  443 bindings are:
  444   (a) inside the scrutinee
  445   (b) inside one of the alternatives/default (default FVs always /first/!).
  446 
  447 -}
  448 
  449 fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])
  450   | isUnliftedType (idType case_bndr)
  451   , exprOkForSideEffects (deAnnotate scrut)
  452       -- See Note [Floating primops]
  453   = wrapFloats shared_binds $
  454     fiExpr platform (case_float : rhs_binds) rhs
  455   where
  456     case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs
  457                     (FloatCase scrut' case_bndr con alt_bndrs)
  458     scrut'     = fiExpr platform scrut_binds scrut
  459     rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)
  460     scrut_fvs  = freeVarsOf scrut
  461 
  462     [shared_binds, scrut_binds, rhs_binds]
  463        = sepBindsByDropPoint platform False
  464            [scrut_fvs, rhs_fvs]
  465            to_drop
  466 
  467 fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
  468   = wrapFloats drop_here1 $
  469     wrapFloats drop_here2 $
  470     Case (fiExpr platform scrut_drops scrut) case_bndr ty
  471          (zipWithEqual "fiExpr" fi_alt alts_drops_s alts)
  472          -- use zipWithEqual, we should have length alts_drops_s = length alts
  473   where
  474         -- Float into the scrut and alts-considered-together just like App
  475     [drop_here1, scrut_drops, alts_drops]
  476        = sepBindsByDropPoint platform False
  477            [scrut_fvs, all_alts_fvs]
  478            to_drop
  479 
  480         -- Float into the alts with the is_case flag set
  481     (drop_here2 : alts_drops_s)
  482       | [ _ ] <- alts = [] : [alts_drops]
  483       | otherwise     = sepBindsByDropPoint platform True alts_fvs alts_drops
  484 
  485     scrut_fvs    = freeVarsOf scrut
  486     alts_fvs     = map alt_fvs alts
  487     all_alts_fvs = unionDVarSets alts_fvs
  488     alt_fvs (AnnAlt _con args rhs)
  489       = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)
  490            -- Delete case_bndr and args from free vars of rhs
  491            -- to get free vars of alt
  492 
  493     fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)
  494 
  495 ------------------
  496 fiBind :: Platform
  497        -> FloatInBinds      -- Binds we're trying to drop
  498                             -- as far "inwards" as possible
  499        -> CoreBindWithFVs   -- Input binding
  500        -> DVarSet           -- Free in scope of binding
  501        -> ( FloatInBinds    -- Land these before
  502           , FloatInBind     -- The binding itself
  503           , FloatInBinds)   -- Land these after
  504 
  505 fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
  506   = ( extra_binds ++ shared_binds          -- Land these before
  507                                            -- See Note [extra_fvs (1,2)]
  508     , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself
  509           (FloatLet (NonRec id rhs'))
  510     , body_binds )                         -- Land these after
  511 
  512   where
  513     body_fvs2 = body_fvs `delDVarSet` id
  514 
  515     rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]
  516     extra_fvs | noFloatIntoRhs NonRecursive id rhs
  517               = rule_fvs `unionDVarSet` rhs_fvs
  518               | otherwise
  519               = rule_fvs
  520         -- See Note [extra_fvs (1): avoid floating into RHS]
  521         -- No point in floating in only to float straight out again
  522         -- We *can't* float into ok-for-speculation unlifted RHSs
  523         -- But do float into join points
  524 
  525     [shared_binds, extra_binds, rhs_binds, body_binds]
  526         = sepBindsByDropPoint platform False
  527             [extra_fvs, rhs_fvs, body_fvs2]
  528             to_drop
  529 
  530         -- Push rhs_binds into the right hand side of the binding
  531     rhs'     = fiRhs platform rhs_binds id ann_rhs
  532     rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs
  533                         -- Don't forget the rule_fvs; the binding mentions them!
  534 
  535 fiBind platform to_drop (AnnRec bindings) body_fvs
  536   = ( extra_binds ++ shared_binds
  537     , FB (mkDVarSet ids) rhs_fvs'
  538          (FloatLet (Rec (fi_bind rhss_binds bindings)))
  539     , body_binds )
  540   where
  541     (ids, rhss) = unzip bindings
  542     rhss_fvs = map freeVarsOf rhss
  543 
  544         -- See Note [extra_fvs (1,2)]
  545     rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids
  546     extra_fvs = rule_fvs `unionDVarSet`
  547                 unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
  548                               , noFloatIntoRhs Recursive bndr rhs ]
  549 
  550     (shared_binds:extra_binds:body_binds:rhss_binds)
  551         = sepBindsByDropPoint platform False
  552             (extra_fvs:body_fvs:rhss_fvs)
  553             to_drop
  554 
  555     rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`
  556                unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`
  557                rule_fvs         -- Don't forget the rule variables!
  558 
  559     -- Push rhs_binds into the right hand side of the binding
  560     fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss
  561             -> [(Id, CoreExprWithFVs)]
  562             -> [(Id, CoreExpr)]
  563 
  564     fi_bind to_drops pairs
  565       = [ (binder, fiRhs platform to_drop binder rhs)
  566         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
  567 
  568 ------------------
  569 fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
  570 fiRhs platform to_drop bndr rhs
  571   | Just join_arity <- isJoinId_maybe bndr
  572   , let (bndrs, body) = collectNAnnBndrs join_arity rhs
  573   = mkLams bndrs (fiExpr platform to_drop body)
  574   | otherwise
  575   = fiExpr platform to_drop rhs
  576 
  577 ------------------
  578 noFloatIntoLam :: [Var] -> Bool
  579 noFloatIntoLam bndrs = any bad bndrs
  580   where
  581     bad b = isId b && not (isOneShotBndr b)
  582     -- Don't float inside a non-one-shot lambda
  583 
  584 noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
  585 -- ^ True if it's a bad idea to float bindings into this RHS
  586 noFloatIntoRhs is_rec bndr rhs
  587   | isJoinId bndr
  588   = isRec is_rec -- Joins are one-shot iff non-recursive
  589 
  590   | otherwise
  591   = noFloatIntoArg rhs (idType bndr)
  592 
  593 noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool
  594 noFloatIntoArg expr expr_ty
  595   | isUnliftedType expr_ty
  596   = True  -- See Note [Do not destroy the let/app invariant]
  597 
  598    | AnnLam bndr e <- expr
  599    , (bndrs, _) <- collectAnnBndrs e
  600    =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)
  601    || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)
  602       -- See Note [noFloatInto considerations] wrinkle 2
  603 
  604   | otherwise  -- Note [noFloatInto considerations] wrinkle 2
  605   = exprIsTrivial deann_expr || exprIsHNF deann_expr
  606   where
  607     deann_expr = deAnnotate' expr
  608 
  609 {- Note [noFloatInto considerations]
  610 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  611 When do we want to float bindings into
  612    - noFloatIntoRHs: the RHS of a let-binding
  613    - noFloatIntoArg: the argument of a function application
  614 
  615 Definitely don't float in if it has unlifted type; that
  616 would destroy the let/app invariant.
  617 
  618 * Wrinkle 1: do not float in if
  619      (a) any non-one-shot value lambdas
  620   or (b) all type lambdas
  621   In both cases we'll float straight back out again
  622   NB: Must line up with fiExpr (AnnLam...); see #7088
  623 
  624   (a) is important: we /must/ float into a one-shot lambda group
  625   (which includes join points). This makes a big difference
  626   for things like
  627      f x# = let x = I# x#
  628             in let j = \() -> ...x...
  629                in if <condition> then normal-path else j ()
  630   If x is used only in the error case join point, j, we must float the
  631   boxing constructor into it, else we box it every time which is very
  632   bad news indeed.
  633 
  634 * Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right
  635   back out again... not tragic, but a waste of time.
  636 
  637   For function arguments we will still end up with this
  638   in-then-out stuff; consider
  639     letrec x = e in f x
  640   Here x is not a HNF, so we'll produce
  641     f (letrec x = e in x)
  642   which is OK... it's not that common, and we'll end up
  643   floating out again, in CorePrep if not earlier.
  644   Still, we use exprIsTrivial to catch this case (sigh)
  645 
  646 
  647 ************************************************************************
  648 *                                                                      *
  649 \subsection{@sepBindsByDropPoint@}
  650 *                                                                      *
  651 ************************************************************************
  652 
  653 This is the crucial function.  The idea is: We have a wad of bindings
  654 that we'd like to distribute inside a collection of {\em drop points};
  655 insides the alternatives of a \tr{case} would be one example of some
  656 drop points; the RHS and body of a non-recursive \tr{let} binding
  657 would be another (2-element) collection.
  658 
  659 So: We're given a list of sets-of-free-variables, one per drop point,
  660 and a list of floating-inwards bindings.  If a binding can go into
  661 only one drop point (without suddenly making something out-of-scope),
  662 in it goes.  If a binding is used inside {\em multiple} drop points,
  663 then it has to go in a you-must-drop-it-above-all-these-drop-points
  664 point.
  665 
  666 We have to maintain the order on these drop-point-related lists.
  667 -}
  668 
  669 -- pprFIB :: FloatInBinds -> SDoc
  670 -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]
  671 
  672 sepBindsByDropPoint
  673     :: Platform
  674     -> Bool                -- True <=> is case expression
  675     -> [FreeVarSet]        -- One set of FVs per drop point
  676                            -- Always at least two long!
  677     -> FloatInBinds        -- Candidate floaters
  678     -> [FloatInBinds]      -- FIRST one is bindings which must not be floated
  679                            -- inside any drop point; the rest correspond
  680                            -- one-to-one with the input list of FV sets
  681 
  682 -- Every input floater is returned somewhere in the result;
  683 -- none are dropped, not even ones which don't seem to be
  684 -- free in *any* of the drop-point fvs.  Why?  Because, for example,
  685 -- a binding (let x = E in B) might have a specialised version of
  686 -- x (say x') stored inside x, but x' isn't free in E or B.
  687 
  688 type DropBox = (FreeVarSet, FloatInBinds)
  689 
  690 sepBindsByDropPoint platform is_case drop_pts floaters
  691   | null floaters  -- Shortcut common case
  692   = [] : [[] | _ <- drop_pts]
  693 
  694   | otherwise
  695   = assert (drop_pts `lengthAtLeast` 2) $
  696     go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
  697   where
  698     n_alts = length drop_pts
  699 
  700     go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
  701         -- The *first* one in the argument list is the drop_here set
  702         -- The FloatInBinds in the lists are in the reverse of
  703         -- the normal FloatInBinds order; that is, they are the right way round!
  704 
  705     go [] drop_boxes = map (reverse . snd) drop_boxes
  706 
  707     go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
  708         = go binds new_boxes
  709         where
  710           -- "here" means the group of bindings dropped at the top of the fork
  711 
  712           (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs
  713                                         | (fvs, _) <- drop_boxes]
  714 
  715           drop_here = used_here || cant_push
  716 
  717           n_used_alts = count id used_in_flags -- returns number of Trues in list.
  718 
  719           cant_push
  720             | is_case   = n_used_alts == n_alts   -- Used in all, don't push
  721                                                   -- Remember n_alts > 1
  722                           || (n_used_alts > 1 && not (floatIsDupable platform bind))
  723                              -- floatIsDupable: see Note [Duplicating floats]
  724 
  725             | otherwise = floatIsCase bind || n_used_alts > 1
  726                              -- floatIsCase: see Note [Floating primops]
  727 
  728           new_boxes | drop_here = (insert here_box : fork_boxes)
  729                     | otherwise = (here_box : new_fork_boxes)
  730 
  731           new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe
  732                                         fork_boxes used_in_flags
  733 
  734           insert :: DropBox -> DropBox
  735           insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)
  736 
  737           insert_maybe box True  = insert box
  738           insert_maybe box False = box
  739 
  740     go _ _ = panic "sepBindsByDropPoint/go"
  741 
  742 
  743 {- Note [Duplicating floats]
  744 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  745 
  746 For case expressions we duplicate the binding if it is reasonably
  747 small, and if it is not used in all the RHSs This is good for
  748 situations like
  749      let x = I# y in
  750      case e of
  751        C -> error x
  752        D -> error x
  753        E -> ...not mentioning x...
  754 
  755 If the thing is used in all RHSs there is nothing gained,
  756 so we don't duplicate then.
  757 -}
  758 
  759 floatedBindsFVs :: FloatInBinds -> FreeVarSet
  760 floatedBindsFVs binds = mapUnionDVarSet fbFVs binds
  761 
  762 fbFVs :: FloatInBind -> DVarSet
  763 fbFVs (FB _ fvs _) = fvs
  764 
  765 wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
  766 -- Remember FloatInBinds is in *reverse* dependency order
  767 wrapFloats []               e = e
  768 wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
  769 
  770 floatIsDupable :: Platform -> FloatBind -> Bool
  771 floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut
  772 floatIsDupable platform (FloatLet (Rec prs))    = all (exprIsDupable platform . snd) prs
  773 floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r
  774 
  775 floatIsCase :: FloatBind -> Bool
  776 floatIsCase (FloatCase {}) = True
  777 floatIsCase (FloatLet {})  = False