+        unitCaseFloat, addLetFlts,  mapLetFloats,

+import GHC.Core.Make            ( mkWildValBinder )

+import qualified GHC.Core.Make

+

+A binding that does not satisfy the let-can-float invariant (the last two

+examples above) is represented by a FloatCase, not a FloatLet:

+  FloatCase (a /# b) x# DEFAULT []

+That is done once and for all by `unitLetFloat`, so a FloatLet in a LetFloats

+is always a valid let-binding, and `wrapFloats` does not need to check.

+Such bindings can arise from `makeTrivial`, because an argument need not

+satisfy the let-can-float invariant.  They also arise because

+exprOkForSpeculation is conservative: e.g. it says False for (# s, x #)

+where x is lifted, because it checks the arguments against the

+(representation-polymorphic) type of the unboxed-tuple worker.

+

+However, a FloatLet can still be FltCareful: the first FltCareful example

+above, NonRec x* (f y), where x* is lifted but has a strict demand

+(isStrUsedDmd).  That is a perfectly valid (lazy) let-binding, but its demand

+info is valid only where it is.  If we floated it out of the RHS of a lazy

+binding

+     let v = let x* = f y in x*+1 in body

+ ==> let x* = f y; v = x*+1 in body

+then x's demand info would be a lie, and CorePrep, which case-binds a let

+whose binder has a strict demand, would evaluate (f y) eagerly.  Hence

+FltCareful, which doFloatFromRhs allows to float only out of a strict binding.

+

+As well as let-bindings, a LetFloats can contain single-alternative case

+floats (FloatCase), for example

+  case e of b { (# a, c #) -> <hole> }

+These are classified just like a strict binding:

+

+  FloatCase (y +# 3) b DEFAULT []      FltOkSpec   -- Scrutinee ok-for-speculation

+  FloatCase (f y) b (# a,c #) [a,c]    FltCareful  -- Might fail or diverge

+

+Being strict they are never FltLifted, so they never float to top level or into

+a recursive group.

+

+Currently, we never put a FloatTick in a LetFloats.

+data LetFloats = LetFloats FloatBinds FloatFlag

+                 -- Contains only FloatLet and FloatCase; never FloatTick

+-- If the binding does not satisfy the let-can-float invariant, it

+-- makes a FloatCase. See Note [LetFloats]

+                    mk_float bind

+    mk_float bind@(Rec {})       = let_float FltLifted bind

+    mk_float bind@(NonRec bndr rhs)

+      | not (isStrictId bndr)    = let_float FltLifted bind

+      | exprIsTickedString rhs   = let_float FltLifted bind

+      | exprOkForSpeculation rhs = let_float FltOkSpec bind  -- Unlifted, and lifted but ok-for-spec (eg HNF)

+      | needsCaseBinding (idType bndr) rhs

+      = pprTrace "TMP-unitLetFloat-case" (ppr bind) $

+        LetFloats (unitOL (FloatCase rhs bndr DEFAULT [])) FltCareful

+          -- Unlifted, and not ok-for-spec: does not satisfy let-can-float invariant

+      | otherwise                = let_float FltCareful bind

+

+    let_float flag bind = LetFloats (unitOL (FloatLet bind)) flag

+

+unitCaseFloat :: OutExpr -> OutId -> AltCon -> [OutVar] -> LetFloats

+-- Constructs a singleton single-alternative case float

+--   case scrut of bndr { con bndrs -> <hole> }

+-- See Note [LetFloats]

+unitCaseFloat scrut bndr con bndrs

+  = LetFloats (unitOL (FloatCase scrut bndr con bndrs)) flag

+  where

+    flag | exprOkForSpeculation scrut = FltOkSpec

+         | otherwise                  = FltCareful

+  = foldlOL extend in_scope binds

+  where

+    extend in_scope (FloatLet bind)        = in_scope `extendInScopeSetBind` bind

+    extend in_scope (FloatCase _ b _ bs)   = in_scope `extendInScopeSetList` (b:bs)

+    extend in_scope (FloatTick {})         = in_scope

+-- Precondition: there are no case-floats

+-- True, for example, if the FloatFlag is FltLifted

+letFloatBinds (LetFloats bs _) = map get_bind (fromOL bs)

+  where

+    get_bind (FloatLet bind) = bind

+    get_bind flt             = pprPanic "letFloatBinds" (ppr flt)

+mkRecFloats floats@(SimplFloats { sfLetFloats  = lfs@(LetFloats bs _ff)

+              | otherwise   = unitLetFloat (Rec (flattenBinds (letFloatBinds lfs)))

+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _

+  = GHC.Core.Make.wrapFloats bs (wrapJoinFloats jbs body)

+     -- No need to worry about the let-can-float invariant: unitLetFloat

+     -- has made a FloatCase for any binding that does not satisfy it

+    app (FloatLet (NonRec b e)) = case fun (b,e) of (b',e') -> FloatLet (NonRec b' e')

+    app (FloatLet (Rec bs))     = FloatLet (Rec (strictMap fun bs))

+    app (FloatCase e b con bs)  = case fun (b,e) of (b',e') -> FloatCase e' b' con bs

+    app flt@(FloatTick {})      = pprPanic "mapLetFloats" (ppr flt)

+

+           -- In rec_floats, all the `sfLetFloats` bindings are `FltLifted`

+-- Invariant: in the returned SimplFloats,

+--            all the `sfLetFloats` bindings are `FltLifted`

+       ; traceSmpl "reallyRebuildCase" (vcat [ ppr case_bndr

+                                             , text "cont':" <+> ppr cont'

+                                             , text "in_scope" <+> ppr (seInScope env') ])

+       ; (alt_env, scrut', case_bndr', imposs_deflt_cons, in_alts)

+             <- prepareCase (saf,env') scrut (scaleIdBy holeScaling case_bndr)

+                                             (scaleAltsBy holeScaling alts)

+       ; case in_alts of

+           [in_alt] -> do { (alt_floats, alt') <- simplAlt (saf,alt_env) (Just scrut')

+                                                     imposs_deflt_cons case_bndr'

+                                                     bndr_swap cont' in_alt

+                          ; (case_floats, res) <- rebuildSingleAltCase env' scrut' case_bndr'

+                                                         cont' alt_floats alt'

+                          ; return (floats `addFloats` case_floats, res) }

+

+           _ -> do { case_expr <- simplAlts (saf,alt_env) scrut' case_bndr'

+                                            imposs_deflt_cons bndr_swap cont' in_alts

+                   ; return (floats, case_expr) } }

+    bndr_swap = scrutOkForBinderSwap scrut

+

+rebuildSingleAltCase :: SimplEnv -> OutExpr -> OutId -> SimplCont

+                     -> SimplFloats -> OutAlt

+                     -> SimplM (SimplFloats, OutExpr)

+-- Build a single-alternative case; but return it as a FloatCase float, so that

+-- the floats from its RHS are not trapped inside it.

+-- See Note [Floating single-alternative cases]

+rebuildSingleAltCase env scrut case_bndr cont alt_floats (Alt con bs rhs)

+  = do { let alts_ty = contResultType cont

+       -- See Note [Avoiding space leaks in OutType]

+       ; case_expr <- seqType alts_ty `seq`

+                      mkCase (seMode env) scrut case_bndr alts_ty

+                             [Alt con bs (wrapFloats alt_floats rhs)]

+                      -- wrapFloats: lazily; see (FSC1)

+       ; case case_expr of

+           Case scrut2 bndr2 _ [Alt con2 bs2 rhs2]

+             | not (noFloats alt_floats)

+             , bndr2 == case_bndr   -- mkCase has not changed the case; see (FSC1)

+             -> return (case_float `addFloats` alt_floats, rhs)

+             | otherwise

+             -> return (case_float, rhs2)

+             where

+               case_float = emptyFloats env `addLetFloats`

+                            unitCaseFloat scrut2 bndr2 con2 bs2

+           _ -> return (emptyFloats env, case_expr) }

+  where

+    noFloats (SimplFloats { sfLetFloats = lfs, sfJoinFloats = jfs })

+      = isEmptyLetFloats lfs && isEmptyJoinFloats jfs

+

+prepareCase :: (SimplAltFlag, SimplEnv)

+            -> OutExpr          -- Scrutinee

+            -> InId -> [InAlt]  -- Case binder and alts (non-empty)

+            -> SimplM ( SimplEnv   -- For the alternatives

+                      , OutExpr    -- Scrutinee, perhaps improved by improveSeq

+                      , OutId      -- Case binder

+                      , [AltCon]   -- Constructors impossible in the DEFAULT alt

+                      , [InAlt] )  -- Alternatives, from prepareAlts

+prepareCase (saf,env0) scrut case_bndr alts

+  = do  { (env1, case_bndr1) <- simplAltIdBinder (saf,env0) case_bndr

+        ; return (alt_env', scrut', case_bndr', imposs_deflt_cons, in_alts) }

+

+simplAlts :: (SimplAltFlag, SimplEnv)

+          -> OutExpr -> OutId       -- Scrutinee and case binder

+          -> [AltCon]               -- Constructors impossible in the DEFAULT alt

+          -> BinderSwapDecision

+          -> SimplCont

+          -> [InAlt]

+          -> SimplM OutExpr  -- Returns the complete simplified case expression

+-- The arguments are prepared by prepareCase

+simplAlts (saf,env) scrut' case_bndr' imposs_deflt_cons bndr_swap cont' in_alts

+  = do  { alts' <- forM in_alts $

+            simplAltC (saf,env) (Just scrut') imposs_deflt_cons

+                      case_bndr' bndr_swap cont'

+          mkCase (seMode env) scrut' case_bndr' alts_ty' alts' }

+{- Note [Floating single-alternative cases]

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

+When reallyRebuildCase finds a single-alternative case (after prepareAlts)

+   case e of b { (# a, c #) -> let x1 = .. in ... let xn = .. in (# e1, e2 #) }

+it does not return the case expression; instead it returns

+  * floats:  [FloatCase e b (# a,c #) [a,c], x1 = .., ..., xn = ..]

+  * result:  (# e1, e2 #)

+This is done by rebuildSingleAltCase.  See Note [LetFloats] in GHC.Core.Opt.Simplify.Env.

+

+Why?  Because a caller (notably rebuildWithFloats, when case-of-case is

+switched off) may want to do case-of-known-constructor on the result. If we

+returned the whole case, exprIsConApp_maybe would have to walk all the way

+down through the case and the lets, which can be quadratic (#27737, T18223).

+

+This is not restricted to the no-case-of-case path: when case-of-case is on,

+the continuation has already been pushed into the alternative, and the

+floats are simply wrapped around the result, or floated further out of a

+strict let (which a StrictBind continuation would do anyway).  The

+FloatFlag (FltCareful or FltOkSpec) stops a case-float from floating out of

+a lazy let, or to top level; see doFloatFromRhs.

+

+Wrinkles:

+

+(FSC1) mkCase may transform the case, e.g. by case-merging, identity-case

+  elimination, or caseRules (mkCase2), which renames the case binder and

+  wraps (let b = ..) around the RHS.  So we call mkCase on the alternative

+  with its floats wrapped (lazily: mkCase inspects only the top of the RHS),

+  and then:

+   - If the alternative has floats, and mkCase has left the case binder

+     unchanged, mkCase cannot have done anything to the RHS (which starts

+     with a let), so we return (case-float + alt-floats, unwrapped RHS).

+   - Otherwise we return the case-float with whatever RHS mkCase produced.

+-}

+

+simplAltC :: (SimplAltFlag, SimplEnv) -> Maybe OutExpr -> [AltCon] -> OutId

+          -> BinderSwapDecision -> SimplCont -> InAlt

+          -> SimplM OutAlt

+-- Like simplAlt, but wraps the floats around the RHS

+simplAltC env scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' alt

+  = do { (floats, Alt con bs rhs) <- simplAlt env scrut' imposs_deflt_cons

+                                              case_bndr' bndr_swap' cont' alt

+       ; return (Alt con bs (wrapFloats floats rhs)) }

+

+         -> SimplM (SimplFloats, OutAlt)

+         -- The floats scope over the RHS only, and may mention the

+         -- binders of the alternative

+        ; (floats, rhs') <- simplAltExprF (saf,env') rhs cont'

+        ; return (floats, Alt DEFAULT [] rhs') }

+        ; (floats, rhs') <- simplAltExprF (saf,env') rhs cont'

+        ; return (floats, Alt (LitAlt lit) [] rhs') }

+        ; (floats, rhs') <- simplAltExprF (saf,env'') rhs cont'

+        ; return (floats, Alt (DataAlt con) vs' rhs') }

+            simplAltC (saf,alt_env1) Nothing [] case_bndr' NoBinderSwap alt_cont