+import GHC.Types.Demand ( argOneShots, argsOneShots {- , isDeadEndSig -} )

+        -- Distressing delicacy ... has to line up with preInlineUnconditionally

+            -> active && not (isTopLevel lvl) && not stable_unf

+--    encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut

+--         | otherwise                               = OccVanilla

+    encl = OccVanilla

+      B -> ...(error x)...

+      C -> ..blah...

+ToDo!!!  Fix comment.   Now postinlineUnconditionally ignores intersting-ness for

+non-top-level things.

+

+                , floatOutConstants   = False  -- Initially

+               , floatOutConstants   = True  -- For SpecConstr and CSE

+        ; lapp'  <- lvlNonTailMFE env True lapp

+             in f vs }

+           case y of { I# w ->

+             in f vs }}

+  |  notWorthFloating expr abs_vars

+  || not float_me

+                           -- esp Bottoming floats (BF2)

+               -- NB: is_bot_lam not is_bot; see (BF2) in Note [Bottoming floats]

+        -- Never float trivial expressions;

+        --   notably, save_work might be true of a lone evaluated variable.

+    is_hnf = exprIsHNF expr

+    saves_work = escapes_value_lam        -- (SW-a)

+                 && not is_hnf            -- (SW-b)

+                 && not float_is_new_lam  -- (SW-c)

+    -- See Note [Floating to the top]

+--    is_con_app = isSaturatedConApp expr  -- True of literal strings too

+    saves_alloc = isTopLvl dest_lvl

+               && (escapes_value_lam || floatConsts env)

+                  -- Always float allocation out of a value lambda

+                  --    if it gets to top level

+               && (not strict_ctxt || is_hnf || is_bot_lam)

+        -- is_con_app: don't float PAPs to the top; they may well end

+        -- up getting eta-expanded and re-inlined

+        -- E.g.   f = \x -> (++) ys

+        -- If we float, then eta-expand we get

+        --      lvl = (++) ys

+        --      f = \x \zs -> lvl zs

+        -- and now we'll inline lvl.  Silly.

+

+But see also Note [Floating to the top].

+(SW-a) It will escape a value lambda (escapes_value_lam)

+(SW-b) The expression is not a head-normal form (exprIsHNF); see (SW1, SW2).

+(SW-c) Floating does not require wrapping it in value lambdas (float_is_new_lam).

+(SW1) Concerning (SW-b) I experimented with using `exprIsCheap` rather than

+(SW2) What about omitting (SW-b), and hence floating HNFs as well?  The danger of

+      Overall, a small win.

+Note [Floating to the top]

+~~~~~~~~~~~~~~~~~~~~~~~~~~

+expressions out of value lambdas. Data suggests, however, that it is better

+/only/ to do so, /if/ they can go to top level. If the expression goes to top

+level we don't pay the cost of allocating cold-path thunks described in (SW2).

+* In principle this would be true even if the (\y.e) didn't go to top level; but

+  in practice we only float a HNF if it goes all way to the top.  We don't pay

+  /any/ allocation cost for a top-level floated expression; it just becomes

+  static data.

+

+* Floating string literals is valuable -- no point in duplicating the

+  (FT1) the context is lazy (so we get allocation), or

+  (FT2) the expression is a HNF (so we get allocation), or

+  (FT3) the expression is bottoming and floating would escape a

+         value lambda (NB: if the expression itself is a lambda, (b)

+         will apply; so this case only catches bottoming thunks)

+* (FT1) Strict.  Case scrutinee

+* (FT1) Strict.  Case alternative

+* (FT2) HNF

+* (FT3) Bottoming expressions; see also Note [Bottoming floats]

+* (FT4) Arguments

+(BF1) We want to float a bottoming

+    To achieve this we pass `is_bot` to destLevel

+

+(BF2) We do the same for /lambdas/ that return bottom.

+    Suppose the original lambda had /no/ free vars:

+        f = \x. ....(\y z. error (y++z))...

+    then we'd like to float that whole lambda

+        lvl = \y z. error (y++z)

+        f = \x. ....lvl....

+    If we just floated its bottom-valued body, we might abstract the arguments in

+    the "wrong" order and end up with this bad result

+        lvl = \z y. error (y++z)

+        f = \x. ....(\y z. lvl z y)....

+

+    If the lambda does have free vars, this will happen:

+    We float the whole lambda thus

+    And we may well end up eta-expanding that PAP to

+        lvl = \x. \y z. if b then error y else error z

+    so we get a (small) closure.  So be it.

+(BF3) If we have a /binding/ that returns bottom, we want to float it to top

+--  See Note [notWorthFloating]

+  = go e 0

+    n_abs_vars = count isId abs_vars  -- See (NWF5)

+

+    go :: CoreExpr -> Int -> Bool

+    -- (go e n) return True if (e x1 .. xn) is not worth floating

+    -- where `e` has n trivial value arguments x1..xn

+    -- See (NWF4)

+    go (Lit lit) n         = assert (n==0) $

+                             litIsTrivial lit   -- See (NWF1)

+    go (Type {}) _         = True

+    go (Tick t e) n        = not (tickishIsCode t) && go e n

+    go (Cast e _) n        = n==0 || go e n     -- See (NWF3)

+    go (Coercion {}) _     = True

+       | Type {} <- arg    = go e n    -- Just types, not coercions (NWF2)

+       | exprIsTrivial arg = go e (n+1)

+       | otherwise         = False  -- (f non-triv) is worth floating

+

+    go (Case e b _ as) _

+      -- Do not float the `case` part of trivial cases (NWF3)

+      -- We'll have a look at the RHS when we get there

+      = True   -- See Note [Empty case is trivial]

+      | Just {} <- isUnsafeEqualityCase e b as

+      = True   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce

+      | otherwise

+      = False

+    go (Var _) n

+      | n==0             = True   -- Naked variable

+      | n <= n_abs_vars  = True   -- (f a b c) is not worth floating if

+      | otherwise        = False  -- a,b,c are all abstracted; see (NWF5)

+    go _ _ = False  -- Let etc is worth floating

+{- Note [notWorthFloating]

+~~~~~~~~~~~~~~~~~~~~~~~~~~

+`notWorthFloating` returns True if the expression would be replaced by something

+bigger than it is now.  One big goal is that floating should be idempotent.  Eg

+if we replace e with (lvl79 x y) and then run FloatOut again, don't want to

+replace (lvl79 x y) with (lvl83 x y)!

+For example:

+  abs_vars = tvars only:  return True if e is trivial,

+                          but False for anything bigger

+  abs_vars = [x] (an Id): return True for trivial, or an application (f x)

+                          but False for (f x x)

+

+(NWF1) It's important to float Integer literals, so that they get shared, rather

+  than being allocated every time round the loop.  Hence the litIsTrivial.

+

+  Ditto literal strings (LitString), which we'd like to float to top

+  level, which is now possible.

+

+(NWF2) We don’t float out variables applied only to type arguments, since the

+  extra binding would be pointless: type arguments are completely erased.

+  But *coercion* arguments aren’t (see Note [Coercion tokens] in

+  "GHC.CoreToStg" and Note [inlineBoringOk] in"GHC.Core.Unfold"),

+  so we still want to float out variables applied only to

+  coercion arguments.

+

+(NWF3) Some expressions have trivial wrappers:

+     - Casts (e |> co)

+     - Unary-class applications:

+          - Dictionary applications (MkC meth)

+          - Class-op applictions    (op dict)

+     - Case of empty alts

+     - Unsafe-equality case

+  In all these cases we say "not worth floating", and we do so /regardless/

+  of the wrapped expression.  The SetLevels stuff may subsequently float the

+  components of the expression.

+

+  Example:  is it worth floating (f x |> co)?  No!  If we did we'd get

+     lvl = f x |> co

+     ...lvl....

+  Then we'd do cast worker/wrapper and end up with.

+     lvl' = f x

+     ...(lvl' |> co)...

+  Silly!  Better not to float it in the first place.  If we say "no" here,

+  we'll subsequently say "yes" for (f x) and get

+     lvl = f x

+     ....(lvl |> co)...

+  which is what we want.  In short: don't float trivial wrappers.

+

+(NWF4) The only non-trivial expression that we say "not worth floating" for

+  is an application

+             f x y z

+  where the number of value arguments is <= the number of abstracted Ids.

+  This is what makes floating idempotent.  Hence counting the number of

+  value arguments in `go`

+

+(NWF5) In #24471 we had something like

+     x1 = I# 1

+     ...

+     x1000 = I# 1000

+     foo = f x1 (f x2 (f x3 ....))

+  So every sub-expression in `foo` has lots and lots of free variables.  But

+  none of these sub-expressions float anywhere; the entire float-out pass is a

+  no-op.

+  So `notWorthFloating` tries to avoid evaluating `n_abs_vars`, in cases where

+  it obviously /is/ worth floating.  (In #24471 it turned out that we were

+  testing `abs_vars` (a relatively complicated calculation that takes at least

+  O(n-free-vars) time to compute) for every sub-expression.)

+  Hence testing `n_abs_vars only` at the very end.

+{- *********************************************************************

+*                                                                      *

+                       Bindings

+        This binding stuff works for top level too.

+*                                                                      *

+********************************************************************* -}

+

+        -- See Note [Bottoming floats] (BF3)

+  | is_bot              -- Send bottoming bindings to the top regardless;

+  = as_far_as_poss      -- see (BF1) and (BF2) in Note [Bottoming floats]

+    -- as_far_as_poss: destination level depends only on the free Ids (more

+    -- precisely, free CoVars) of the /type/, not the free Ids of the /term/.

+    -- Why worry about the free CoVars?  See Note [Floating and kind casts]

+    --

+    -- There may be free Ids in the term, but then we'll just

+    -- lambda-abstract over them

+-- Precisely the same as `maxFvLevel` but for TyCoVarSet rather than DVarSet

+        SimplEnv(..), StaticEnv, pprSimplEnv,

+type StaticEnv = SimplEnv       -- Just the static part is relevant

+

+unitLetFloat :: HasDebugCallStack => OutBind -> LetFloats

+The main motivation is that x can be inlined freely.  There's a chance

+                     -> OutId -> OutExpr

+                     -> SimplM (Maybe (LetFloats, OutId, OutExpr))

+-- Given input x = rhs |> co, the result will be

+--    (x' = rhs, x, x' |> co))

+tryCastWorkerWrapper env bind_cxt bndr (Cast rhs co)

+  | BC_Let top_lvl _ <- bind_cxt  -- Not join points

+  , not (isOpaquePragma (idInlinePragma bndr)) -- Not for OPAQUE bindings

+                                               -- See Note [OPAQUE pragma]

+        ; work_unf <- mk_worker_unfolding top_lvl work_id rhs

+               work_bind     = NonRec work_id_w_unf rhs

+               triv_rhs      = Cast (Var work_id_w_unf) co

+

+        ; wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs

+        ; let wrap_prag = mkCastWrapperInlinePrag (inlinePragInfo info)

+              bndr' = bndr `setInlinePragma` wrap_prag

+                           `setIdUnfolding`  wrap_unf

+

+        ; return (Just (unitLetFloat work_bind, bndr', triv_rhs)) }

+tryCastWorkerWrapper _ _ bndr rhs  -- All other bindings

+       ; return Nothing }

+  | exprIsTrivial expr                  -- Already trivial

+  | not (bindingOk top_lvl expr expr_ty)  -- Cannot trivialise

+  = return (emptyLetFloats, expr)         -- See Note [Cannot trivialise]

+  | otherwise

+              bndr = mkLocalIdWithInfo name ManyTy expr_ty id_info

+              bind_ctxt = BC_Let top_lvl NonRecursive

+        ; (arity_type, expr2) <- tryEtaExpandRhs env bind_ctxt bndr expr1

+        ; unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False expr2

+        ; let bndr'    = addLetBndrInfo bndr arity_type unf

+              anf_bind = NonRec bndr' expr2

+        ; mb_cast_ww <- tryCastWorkerWrapper env bind_ctxt bndr' expr2

+        ; case mb_cast_ww of

+            Nothing -> return (floats `addLetFlts` unitLetFloat anf_bind, Var bndr')

+            Just (work_flts, _, triv_rhs)

+                    -> return (floats `addLetFlts` work_flts, triv_rhs) }

+

+               -- See Note [In-scope set as a substitution]

+            occ_anald_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs

+               -- occ_anald_rhs: see Note [Use occ-anald RHS in postInlineUnconditionally]

+      -- Try postInlineUnconditionally for (x = rhs)

+      -- If that succeeds we don't want to do tryCastWorkerWrapper

+        then post_inline_it (emptyFloats env) occ_anald_rhs

+        else

+

+   do { -- Try cast worker-wrapper

+        mb_cast_ww <- tryCastWorkerWrapper env bind_cxt new_bndr_w_info eta_rhs

+      ; case mb_cast_ww of

+          Nothing -> no_post_inline (emptyFloats env) new_bndr_w_info eta_rhs

+

+          Just (cast_let_flts, new_bndr, new_rhs)

+            -- Try postInlineUnconditionally for (new_bndr = new_rhs)

+            -- Almost always fires, because `new_rhs` is small, but we conservatively

+            -- use `postInlineUnconditionally` so that we check all the right things

+            | postInlineUnconditionally env bind_cxt old_bndr new_bndr new_rhs

+            -> post_inline_it cast_floats new_rhs

+                   -- new_rhs is (x |> co) so no need to occ-anal

+            | otherwise

+            -> no_post_inline cast_floats new_bndr new_rhs

+            where

+              cast_floats = emptyFloats env `addLetFloats` cast_let_flts

+    } }

+  where

+    no_post_inline floats new_bndr new_rhs

+      = do { let the_bind = NonRec new_bndr new_rhs

+                 floats'  = floats `extendFloats` the_bind

+                 env'     = env `setInScopeFromF` floats'

+           ; return (floats', env') }

+

+    post_inline_it floats rhs

+      = do  { simplTrace "PostInlineUnconditionally" (ppr old_bndr <+> ppr rhs) $

+              tick (PostInlineUnconditionally old_bndr)

+            ; let env' = env `setInScopeFromF` floats

+            ; return ( floats

+                     , extendIdSubst env' old_bndr $

+                       DoneEx rhs (idJoinPointHood old_bndr)) }

+

+        -- Make the argument duplicable. Danger: if arg is small and we let-bind

+        -- it, then postInlineUnconditionally will just inline it again, perhaps

+        -- taking an extra Simplifier iteration (e.g. in test T21839c). So make

+        -- a `let` only if `couldBeSmallEnoughToInline` says that it is big enough

+        ; let uf_opts = seUnfoldingOpts env

+        ; (let_floats2, arg'')