    {-# LANGUAGE ViewPatterns #-}

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

    {-
    (c) The University of Glasgow, 1994-2006

    Core pass to saturate constructors and PrimOps
    -}

    module GHC.CoreToStg.Prep
       ( CorePrepConfig (..)
       , CorePrepPgmConfig (..)
       , corePrepPgm
       , corePrepExpr
       )
    where

    import GHC.Prelude

    import GHC.Platform

    import GHC.Driver.Flags

    import GHC.Unit

    import GHC.Builtin.Names
    import GHC.Builtin.PrimOps
    import GHC.Builtin.PrimOps.Ids
    import GHC.Builtin.Types
    import GHC.Builtin.Types.Prim

    import GHC.Core.Utils
    import GHC.Core.Opt.Arity
    import GHC.Core.Lint    ( EndPassConfig(..), endPassIO )
    import GHC.Core
    import GHC.Core.Subst
    import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here
    import GHC.Core.Type
    import GHC.Core.Coercion
    import GHC.Core.TyCon
    import GHC.Core.DataCon
    import GHC.Core.Opt.OccurAnal

    import GHC.Data.Maybe
    import GHC.Data.OrdList
    import GHC.Data.FastString
    import GHC.Data.Graph.UnVar

    import GHC.Utils.Error
    import GHC.Utils.Misc
    import GHC.Utils.Panic
    import GHC.Utils.Outputable
    import GHC.Utils.Monad  ( mapAccumLM )
    import GHC.Utils.Logger

    import GHC.Types.Demand
    import GHC.Types.Var
    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.Id.Make ( realWorldPrimId )
    import GHC.Types.Basic
    import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )
    import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
    import GHC.Types.Literal
    import GHC.Types.Tickish
    import GHC.Types.Unique.Supply

    import qualified Data.ByteString as BS
    import qualified Data.ByteString.Builder as BB
    import Data.ByteString.Builder.Prim

    import Control.Monad

    {-
    Note [CorePrep Overview]
    ~~~~~~~~~~~~~~~~~~~~~~~~

    The goal of this pass is to prepare for code generation.

    1.  Saturate constructor and primop applications.

    2.  Convert to A-normal form; that is, function arguments
        are always variables.

        * Use case for strict arguments:
            f E ==> case E of x -> f x
            (where f is strict)

        * Use let for non-trivial lazy arguments
            f E ==> let x = E in f x
            (were f is lazy and x is non-trivial)

    3.  Similarly, convert any unboxed lets into cases.
        [I'm experimenting with leaving 'ok-for-speculation'
         rhss in let-form right up to this point.]

    4.  Ensure that *value* lambdas only occur as the RHS of a binding
        (The code generator can't deal with anything else.)
        Type lambdas are ok, however, because the code gen discards them.

    5.  ANF-isation results in additional bindings that can obscure values.
        We float these out; see Note [Floating in CorePrep].

    6.  Clone all local Ids.  See Note [Cloning in CorePrep]

    7.  Give each dynamic CCall occurrence a fresh unique; this is
        rather like the cloning step above.

    8.  Inject bindings for the "implicit" Ids:
            * Constructor wrappers
            * Constructor workers
        We want curried definitions for all of these in case they
        aren't inlined by some caller.

     9. Convert bignum literals into their core representation.

    10. Uphold tick consistency while doing this: We move ticks out of
        (non-type) applications where we can, and make sure that we
        annotate according to scoping rules when floating.

    11. Collect cost centres (including cost centres in unfoldings) if we're in
        profiling mode. We have to do this here because we won't have unfoldings
        after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].

    12. Eliminate some magic Ids, specifically
         runRW# (\s. e)  ==>  e[readWorldId/s]
                 lazy e  ==>  e (see Note [lazyId magic] in GHC.Types.Id.Make)
             noinline e  ==>  e
               nospec e  ==>  e
         ToDo:  keepAlive# ...
        This is done in cpeApp

    This is all done modulo type applications and abstractions, so that
    when type erasure is done for conversion to STG, we don't end up with
    any trivial or useless bindings.

    Note [CorePrep invariants]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    Here is the syntax of the Core produced by CorePrep:

        Trivial expressions
           arg ::= lit |  var
                  | arg ty  |  /\a. arg
                  | truv co  |  /\c. arg  |  arg |> co

        Applications
           app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co

        Expressions
           body ::= app
                  | let(rec) x = rhs in body     -- Boxed only
                  | case app of pat -> body
                  | /\a. body | /\c. body
                  | body |> co

        Right hand sides (only place where value lambdas can occur)
           rhs ::= /\a.rhs  |  \x.rhs  |  body

    We define a synonym for each of these non-terminals.  Functions
    with the corresponding name produce a result in that syntax.

    Note [Cloning in CorePrep]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    In CorePrep we
    * Always clone non-CoVar Ids, so each has a unique Unique
    * Sometimes clone CoVars and TyVars

    We always clone non-CoVarIds, for three reasons

    1. Things associated with labels in the final code must be truly unique in
       order to avoid labels being shadowed in the final output.

    2. Even binders without info tables like function arguments or alternative
       bound binders must be unique at least in their type/unique combination.
       We only emit a single declaration for each binder when compiling to C
       so if binders are not unique we would either get duplicate declarations
       or misstyped variables. The later happend in #22402.

    3. We heavily use unique-keyed maps in the backend which can go wrong when
       ids with the same unique are meant to represent the same variable.

    Generally speaking we don't clone TyVars or CoVars. The code gen doesn't need
    that (they are erased), and doing so would be tiresome because then we'd need
    to substitute in types and coercions.  But sometimes need to: see
    Note [Cloning CoVars and TyVars]

    Note [Cloning CoVars and TyVars]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Normally we don't need to clone TyVars and CoVars, but there is one occasion
    when we do (see #24463).  When we have
        case unsafeEqualityProof ... of UnsafeRefl g -> ...
    we try to float it, using UnsafeEqualityCase.
    Why?  See (U3) in Note [Implementing unsafeCoerce]

    Alas, floating it widens the scope of `g`, and that led to catastrophe in
    #24463, when two identically-named g's shadowed.

    Solution: clone `g`; see `cpCloneCoVarBndr`.

    BUT once we clone `g` we must apply the cloning substitution to all types
    and coercions.  But that in turn means that, given a binder like
       /\ (a :: kind |> g). blah
    we must substitute in a's kind, and hence need to substitute for `a`
    itself in `blah`.

    So our plan is:
      * Maintain a full Subst in `cpe_subst`

      * Clone a CoVar when we we meet an `isUnsafeEqualityCase`;
        otherwise TyVar/CoVar binders are never cloned.

      * So generally the TCvSubst is empty

      * Apply the substitution to type and coercion arguments in Core; but
        happily `substTy` has a no-op short-cut for an empty TCvSubst, so this
        is usually very cheap.

      * In `cpCloneBndr`, for a tyvar/covar binder, check for an empty substitution;
        in that case just do nothing
    -}

    type CpeArg  = CoreExpr    -- Non-terminal 'arg'
    type CpeApp  = CoreExpr    -- Non-terminal 'app'
    type CpeBody = CoreExpr    -- Non-terminal 'body'
    type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'

    {-
    ************************************************************************
    *                                                                      *
                    Top level stuff
    *                                                                      *
    ************************************************************************
    -}

    data CorePrepPgmConfig = CorePrepPgmConfig
      { CorePrepPgmConfig -> EndPassConfig
    cpPgm_endPassConfig     :: !EndPassConfig
      , CorePrepPgmConfig -> Bool
    cpPgm_generateDebugInfo :: !Bool
      }

    corePrepPgm :: Logger
                -> CorePrepConfig
                -> CorePrepPgmConfig
                -> Module -> ModLocation -> CoreProgram -> [TyCon]
                -> IO CoreProgram
    corePrepPgm :: Logger
    -> CorePrepConfig
    -> CorePrepPgmConfig
    -> Module
    -> ModLocation
    -> CoreProgram
    -> [TyCon]
    -> IO CoreProgram
    corePrepPgm Logger
    logger CorePrepConfig
    cp_cfg CorePrepPgmConfig
    pgm_cfg
                Module
    this_mod ModLocation
    mod_loc CoreProgram
    binds [TyCon]
    data_tycons =
        Logger
    -> SDoc -> (CoreProgram -> ()) -> IO CoreProgram -> IO CoreProgram
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger
                   (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "CorePrep"SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    brackets (Module -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Module
    this_mod))
                   (\CoreProgram
    a -> CoreProgram
    a CoreProgram -> () -> ()
    forall a b. [a] -> b -> b
    `seqList` ()) (IO CoreProgram -> IO CoreProgram)
    -> IO CoreProgram -> IO CoreProgram
    forall a b. (a -> b) -> a -> b
    $ do
        us <- Char -> IO UniqSupply
    mkSplitUniqSupply Char
    's'
        let initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
    mkInitialCorePrepEnv CorePrepConfig
    cp_cfg

        let
            implicit_binds = Bool -> ModLocation -> [TyCon] -> CoreProgram
    mkDataConWorkers
              (CorePrepPgmConfig -> Bool
    cpPgm_generateDebugInfo CorePrepPgmConfig
    pgm_cfg)
              ModLocation
    mod_loc [TyCon]
    data_tycons
                -- NB: we must feed mkImplicitBinds through corePrep too
                -- so that they are suitably cloned and eta-expanded

            binds_out = UniqSupply -> UniqSM CoreProgram -> CoreProgram
    forall a. UniqSupply -> UniqSM a -> a
    initUs_ UniqSupply
    us (UniqSM CoreProgram -> CoreProgram)
    -> UniqSM CoreProgram -> CoreProgram
    forall a b. (a -> b) -> a -> b
    $ do
                          floats1 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
    corePrepTopBinds CorePrepEnv
    initialCorePrepEnv CoreProgram
    binds
                          floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
                          return (deFloatTop (floats1 `zipFloats` floats2))

        endPassIO logger (cpPgm_endPassConfig pgm_cfg)
                  binds_out []
        return binds_out

    corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr
    corePrepExpr :: Logger -> CorePrepConfig -> CpeRhs -> IO CpeRhs
    corePrepExpr Logger
    logger CorePrepConfig
    config CpeRhs
    expr = do
        Logger -> SDoc -> (CpeRhs -> ()) -> IO CpeRhs -> IO CpeRhs
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "CorePrep [expr]") (\CpeRhs
    e -> CpeRhs
    e CpeRhs -> () -> ()
    forall a b. a -> b -> b
    `seq` ()) (IO CpeRhs -> IO CpeRhs) -> IO CpeRhs -> IO CpeRhs
    forall a b. (a -> b) -> a -> b
    $ do
          us <- Char -> IO UniqSupply
    mkSplitUniqSupply Char
    's'
          let initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
    mkInitialCorePrepEnv CorePrepConfig
    config
          let new_expr = UniqSupply -> UniqSM CpeRhs -> CpeRhs
    forall a. UniqSupply -> UniqSM a -> a
    initUs_ UniqSupply
    us (CorePrepEnv -> CpeRhs -> UniqSM CpeRhs
    cpeBodyNF CorePrepEnv
    initialCorePrepEnv CpeRhs
    expr)
          putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)
          return new_expr

    corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
    -- Note [Floating out of top level bindings]
    corePrepTopBinds :: CorePrepEnv -> CoreProgram -> UniqSM Floats
    corePrepTopBinds CorePrepEnv
    initialCorePrepEnv CoreProgram
    binds
      = CorePrepEnv -> CoreProgram -> UniqSM Floats
    go CorePrepEnv
    initialCorePrepEnv CoreProgram
    binds
      where
        go :: CorePrepEnv -> CoreProgram -> UniqSM Floats
    go CorePrepEnv
    _   []             = Floats -> UniqSM Floats
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Floats
    emptyFloats
        go CorePrepEnv
    env (CoreBind
    bind : CoreProgram
    binds) = do (env', floats, maybe_new_bind)
                                     <- TopLevelFlag
    -> CorePrepEnv
    -> CoreBind
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    cpeBind TopLevelFlag
    TopLevel CorePrepEnv
    env CoreBind
    bind
                                   massert (isNothing maybe_new_bind)
                                     -- Only join points get returned this way by
                                     -- cpeBind, and no join point may float to top
                                   floatss <- go env' binds
                                   return (floats `zipFloats` floatss)

    mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind]
    -- See Note [Data constructor workers]
    -- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy
    mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> CoreProgram
    mkDataConWorkers Bool
    generate_debug_info ModLocation
    mod_loc [TyCon]
    data_tycons
      = [ InVar -> CpeRhs -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec InVar
    id (Name -> CpeRhs -> CpeRhs
    tick_it (DataCon -> Name
    forall a. NamedThing a => a -> Name
    getName DataCon
    data_con) (InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    id))
                                    -- The ice is thin here, but it works
        | TyCon
    tycon <- [TyCon]
    data_tycons,     -- CorePrep will eta-expand it
          DataCon
    data_con <- TyCon -> [DataCon]
    tyConDataCons TyCon
    tycon,
          let id :: InVar
    id = DataCon -> InVar
    dataConWorkId DataCon
    data_con
        ]
     where
       -- If we want to generate debug info, we put a source note on the
       -- worker. This is useful, especially for heap profiling.
       tick_it :: Name -> CpeRhs -> CpeRhs
    tick_it Name
    name
         | Bool -> Bool
    not Bool
    generate_debug_info               = CpeRhs -> CpeRhs
    forall a. a -> a
    id
         | RealSrcSpan RealSrcSpan
    span Maybe BufSpan
    _ <- Name -> SrcSpan
    nameSrcSpan Name
    name = RealSrcSpan -> CpeRhs -> CpeRhs
    tick RealSrcSpan
    span
         | Just String
    file <- ModLocation -> Maybe String
    ml_hs_file ModLocation
    mod_loc       = RealSrcSpan -> CpeRhs -> CpeRhs
    tick (String -> RealSrcSpan
    span1 String
    file)
         | Bool
    otherwise                             = RealSrcSpan -> CpeRhs -> CpeRhs
    tick (String -> RealSrcSpan
    span1 String
    "???")
         where tick :: RealSrcSpan -> CpeRhs -> CpeRhs
    tick RealSrcSpan
    span  = CoreTickish -> CpeRhs -> CpeRhs
    forall b. CoreTickish -> Expr b -> Expr b
    Tick (CoreTickish -> CpeRhs -> CpeRhs)
    -> CoreTickish -> CpeRhs -> CpeRhs
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> LexicalFastString -> CoreTickish
    forall (pass :: TickishPass).
    RealSrcSpan -> LexicalFastString -> GenTickish pass
    SourceNote RealSrcSpan
    span (LexicalFastString -> CoreTickish)
    -> LexicalFastString -> CoreTickish
    forall a b. (a -> b) -> a -> b
    $
                 FastString -> LexicalFastString
    LexicalFastString (FastString -> LexicalFastString)
    -> FastString -> LexicalFastString
    forall a b. (a -> b) -> a -> b
    $ String -> FastString
    mkFastString (String -> FastString) -> String -> FastString
    forall a b. (a -> b) -> a -> b
    $ SDocContext -> SDoc -> String
    renderWithContext SDocContext
    defaultSDocContext (SDoc -> String) -> SDoc -> String
    forall a b. (a -> b) -> a -> b
    $ Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    name
               span1 :: String -> RealSrcSpan
    span1 String
    file = RealSrcLoc -> RealSrcSpan
    realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
    forall a b. (a -> b) -> a -> b
    $ FastString -> Int -> Int -> RealSrcLoc
    mkRealSrcLoc (String -> FastString
    mkFastString String
    file) Int
    1 Int
    1

    {- Note [Floating in CorePrep]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ANFisation risks producing a lot of nested lets that obscures values:
      let v = (:) (f 14) [] in e
      ==> { ANF in CorePrep }
      let v = let sat = f 14 in (:) sat [] in e
    Here, `v` is not a value anymore, and we'd allocate a thunk closure for `v` that
    allocates a thunk for `sat` and then allocates the cons cell.
    Hence we carry around a bunch of floated bindings with us so that we again
    expose the values:
      let v = let sat = f 14 in (:) sat [] in e
      ==> { Float sat }
      let sat = f 14 in
      let v = (:) sat [] in e
    (We will not do this transformation if `v` does not become a value afterwards;
    see Note [wantFloatLocal].)
    If `v` is bound at the top-level, we might even float `sat` to top-level;
    see Note [Floating out of top level bindings].
    For nested let bindings, we have to keep in mind Note [Core letrec invariant]
    and may exploit strict contexts; see Note [wantFloatLocal].

    There are 3 main categories of floats, encoded in the `FloatingBind` type:

      * `Float`: A floated binding, as `sat` above.
        These come in different flavours as described by their `FloatInfo` and
        `BindInfo`, which captures how far the binding can be floated and whether or
        not we want to case-bind. See Note [BindInfo and FloatInfo].
      * `UnsafeEqualityCase`: Used for floating around unsafeEqualityProof bindings;
        see (U3) of Note [Implementing unsafeCoerce].
        It's exactly a `Float` that is `CaseBound` and `LazyContextFloatable`
        (see `mkNonRecFloat`), but one that has a non-DEFAULT Case alternative to
        bind the unsafe coercion field of the Refl constructor.
      * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep].

    Note [Floating out of top level bindings]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    NB: we do need to float out of top-level bindings
    Consider        x = length [True,False]
    We want to get
                    s1 = False : []
                    s2 = True  : s1
                    x  = length s2

    We return a *list* of bindings, because we may start with
            x* = f (g y)
    where x is demanded, in which case we want to finish with
            a = g y
            x* = f a
    And then x will actually end up case-bound

    Note [Join points and floating]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Join points can float out of other join points but not out of value bindings:

      let z =
        let  w = ... in -- can float
        join k = ... in -- can't float
        ... jump k ...
      join j x1 ... xn =
        let  y = ... in -- can float (but don't want to)
        join h = ... in -- can float (but not much point)
        ... jump h ...
      in ...

    Here, the jump to h remains valid if h is floated outward, but the jump to k
    does not.

    We don't float *out* of join points. It would only be safe to float out of
    nullary join points (or ones where the arguments are all either type arguments
    or dead binders). Nullary join points aren't ever recursive, so they're always
    effectively one-shot functions, which we don't float out of. We *could* float
    join points from nullary join points, but there's no clear benefit at this
    stage.

    Note [Data constructor workers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Create any necessary "implicit" bindings for data con workers.  We
    create the rather strange (non-recursive!) binding

            $wC = \x y -> $wC x y

    i.e. a curried constructor that allocates.  This means that we can
    treat the worker for a constructor like any other function in the rest
    of the compiler.  The point here is that CoreToStg will generate a
    StgConApp for the RHS, rather than a call to the worker (which would
    give a loop).  As Lennart says: the ice is thin here, but it works.

    Hmm.  Should we create bindings for dictionary constructors?  They are
    always fully applied, and the bindings are just there to support
    partial applications. But it's easier to let them through.

    Note [Dead code in CorePrep]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Imagine that we got an input program like this (see #4962):

      f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
      f x = (g True (Just x) + g () (Just x), g)
        where
          g :: Show a => a -> Maybe Int -> Int
          g _ Nothing = x
          g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown

    After specialisation and SpecConstr, we would get something like this:

      f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
      f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
        where
          {-# RULES g $dBool = g$Bool
                    g $dUnit = g$Unit #-}
          g = ...
          {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
          g$Bool = ...
          {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
          g$Unit = ...
          g$Bool_True_Just = ...
          g$Unit_Unit_Just = ...

    Note that the g$Bool and g$Unit functions are actually dead code: they
    are only kept alive by the occurrence analyser because they are
    referred to by the rules of g, which is being kept alive by the fact
    that it is used (unspecialised) in the returned pair.

    However, at the CorePrep stage there is no way that the rules for g
    will ever fire, and it really seems like a shame to produce an output
    program that goes to the trouble of allocating a closure for the
    unreachable g$Bool and g$Unit functions.

    The way we fix this is to:
     * In cloneBndr, drop all unfoldings/rules

     * In deFloatTop, run a simple dead code analyser on each top-level
       RHS to drop the dead local bindings.

    The reason we don't just OccAnal the whole output of CorePrep is that
    the tidier ensures that all top-level binders are GlobalIds, so they
    don't show up in the free variables any longer. So if you run the
    occurrence analyser on the output of CoreTidy (or later) you e.g. turn
    this program:

      Rec {
      f = ... f ...
      }

    Into this one:

      f = ... f ...

    (Since f is not considered to be free in its own RHS.)

    Note [keepAlive# magic]
    ~~~~~~~~~~~~~~~~~~~~~~~
    When interacting with foreign code, it is often necessary for the user to
    extend the lifetime of a heap object beyond the lifetime that would be apparent
    from the on-heap references alone. For instance, a program like:

      foreign import safe "hello" hello :: ByteArray# -> IO ()

      callForeign :: IO ()
      callForeign = IO $ \s0 ->
        case newByteArray# n# s0 of (# s1, barr #) ->
          unIO hello barr s1

    As-written this program is susceptible to memory-unsafety since there are
    no references to `barr` visible to the garbage collector. Consequently, if a
    garbage collection happens during the execution of the C function `hello`, it
    may be that the array is freed while in use by the foreign function.

    To address this, we introduced a new primop, keepAlive#, which "scopes over"
    the computation needing the kept-alive value:

      keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b).
                    a -> State# RealWorld -> (State# RealWorld -> b) -> b

    When entered, an application (keepAlive# x s k) will apply `k` to the state
    token, evaluating it to WHNF. However, during the course of this evaluation
    will *guarantee* that `x` is considered to be alive.

    There are a few things to note here:

     - we are RuntimeRep-polymorphic in the value to be kept-alive. This is
       necessary since we will often (but not always) be keeping alive something
       unlifted (like a ByteArray#)

     - we are RuntimeRep-polymorphic in the result value since the result may take
       many forms (e.g. a boxed value, a raw state token, or a (# State s, result #).

    We implement this operation by desugaring to touch# during CorePrep (see
    GHC.CoreToStg.Prep.cpeApp). Specifically,

      keepAlive# x s0 k

    is transformed to:

      case k s0 of r ->
      case touch# x realWorld# of s1 ->
        r

    Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a
    pointer to `x` and entering `k s0`. This compilation strategy is safe
    because we do no optimization on STG that would drop or re-order the
    continuation containing the `touch#`. However, if we were to become more
    aggressive in our STG pipeline then we would need to revisit this.

    Beyond this CorePrep transformation, there is very little special about
    keepAlive#. However, we did explore (and eventually gave up on)
    an optimisation which would allow unboxing of constructed product results,
    which we describe below.

    Lost optimisation: CPR unboxing
    --------------------------------
    One unfortunate property of this approach is that the simplifier is unable to
    unbox the result of a keepAlive# expression. For instance, consider the program:

      case keepAlive# arr s0 (
             \s1 -> case peekInt arr s1 of
                      (# s2, r #) -> I# r
      ) of
        I# x -> ...

    This is a surprisingly common pattern, previously used, e.g., in
    GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around
    with optimising this away by pushing strict contexts (like the
    `case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can
    recover unboxing, it can also unfortunately in general change the asymptotic
    memory (namely stack) behavior of the program. For instance, consider

      writeN =
        ...
          case keepAlive# x s0 (\s1 -> something s1) of
            (# s2, x #) ->
              writeN ...

    As it is tail-recursive, this program will run in constant space. However, if
    we push outer case into the continuation we get:

      writeN =

          case keepAlive# x s0 (\s1 ->
            case something s1 of
              (# s2, x #) ->
                writeN ...
          ) of
            ...

    Which ends up building a stack which is linear in the recursion depth. For this
    reason, we ended up giving up on this optimisation.

    Historical note: touch# and its inadequacy
    ------------------------------------------
    Prior to the introduction of `keepAlive#` we instead addressed the need for
    lifetime extension with the `touch#` primop:

        touch# :: a -> State# s -> State# s

    This operation would ensure that the `a` value passed as the first argument was
    considered "alive" at the time the primop application is entered.

    For instance, the user might modify `callForeign` as:

      callForeign :: IO ()
      callForeign s0 = IO $ \s0 ->
        case newByteArray# n# s0 of (# s1, barr #) ->
        case unIO hello barr s1 of (# s2, () #) ->
        case touch# barr s2 of s3 ->
          (# s3, () #)

    However, in #14346 we discovered that this primop is insufficient in the
    presence of simplification. For instance, consider a program like:

      callForeign :: IO ()
      callForeign s0 = IO $ \s0 ->
        case newByteArray# n# s0 of (# s1, barr #) ->
        case unIO (forever $ hello barr) s1 of (# s2, () #) ->
        case touch# barr s2 of s3 ->
          (# s3, () #)

    In this case the Simplifier may realize that (forever $ hello barr)
    will never return and consequently that the `touch#` that follows is dead code.
    As such, it will be dropped, resulting in memory unsoundness.
    This unsoundness lead to the introduction of keepAlive#.

    Other related tickets:

     - #15544
     - #17760
     - #14375
     - #15260
     - #18061

    ************************************************************************
    *                                                                      *
                    The main code
    *                                                                      *
    ************************************************************************
    -}

    cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
            -> UniqSM (CorePrepEnv,
                       Floats,         -- Floating value bindings
                       Maybe CoreBind) -- Just bind' <=> returned new bind; no float
                                       -- Nothing <=> added bind' to floats instead
    cpeBind :: TopLevelFlag
    -> CorePrepEnv
    -> CoreBind
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    cpeBind TopLevelFlag
    top_lvl CorePrepEnv
    env (NonRec InVar
    bndr CpeRhs
    rhs)
      | Bool -> Bool
    not (InVar -> Bool
    isJoinId InVar
    bndr)
      = do { (env1, bndr1) <- CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
    cpCloneBndr CorePrepEnv
    env InVar
    bndr
           ; let dmd         = InVar -> Demand
    idDemandInfo InVar
    bndr
                 is_unlifted = HasDebugCallStack => Type -> Bool
    Type -> Bool
    isUnliftedType (InVar -> Type
    idType InVar
    bndr)
           ; (floats, rhs1) <- cpePair top_lvl NonRecursive
                                       dmd is_unlifted
                                       env bndr1 rhs
           -- See Note [Inlining in CorePrep]
           ; let triv_rhs = CpeRhs -> Bool
    exprIsTrivial CpeRhs
    rhs1
                 env2    | Bool
    triv_rhs  = CorePrepEnv -> InVar -> CpeRhs -> CorePrepEnv
    extendCorePrepEnvExpr CorePrepEnv
    env1 InVar
    bndr CpeRhs
    rhs1
                         | Bool
    otherwise = CorePrepEnv
    env1
                 floats1 | Bool
    triv_rhs, Name -> Bool
    isInternalName (InVar -> Name
    idName InVar
    bndr)
                         = Floats
    floats
                         | Bool
    otherwise
                         = Floats -> FloatingBind -> Floats
    snocFloat Floats
    floats FloatingBind
    new_float

                 new_float = CorePrepEnv -> Demand -> Bool -> InVar -> CpeRhs -> FloatingBind
    mkNonRecFloat CorePrepEnv
    env Demand
    dmd Bool
    is_unlifted InVar
    bndr1 CpeRhs
    rhs1

           ; return (env2, floats1, Nothing) }

      | Bool
    otherwise -- A join point; see Note [Join points and floating]
      = Bool
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    forall a. HasCallStack => Bool -> a -> a
    assert (Bool -> Bool
    not (TopLevelFlag -> Bool
    isTopLevel TopLevelFlag
    top_lvl)) (UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
     -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind))
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    forall a b. (a -> b) -> a -> b
    $ -- can't have top-level join point
        do { (_, bndr1) <- CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
    cpCloneBndr CorePrepEnv
    env InVar
    bndr
           ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
           ; return (extendCorePrepEnv env bndr bndr2,
                     emptyFloats,
                     Just (NonRec bndr2 rhs1)) }

    cpeBind TopLevelFlag
    top_lvl CorePrepEnv
    env (Rec [(InVar, CpeRhs)]
    pairs)
      | Bool -> Bool
    not (InVar -> Bool
    isJoinId ([InVar] -> InVar
    forall a. HasCallStack => [a] -> a
    head [InVar]
    bndrs))
      = do { (env, bndrs1) <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
    cpCloneBndrs CorePrepEnv
    env [InVar]
    bndrs
           ; let env' = CorePrepEnv -> [InVar] -> CorePrepEnv
    enterRecGroupRHSs CorePrepEnv
    env [InVar]
    bndrs1
           ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
                               bndrs1 rhss

           ; let (zipManyFloats -> floats, rhss1) = unzip stuff
                 -- Glom all floats into the Rec, *except* FloatStrings; see
                 -- see Note [ANF-ising literal string arguments], Wrinkle (FS1)
                 is_lit (Float (NonRec InVar
    _ CpeRhs
    rhs) BindInfo
    CaseBound FloatInfo
    TopLvlFloatable) = CpeRhs -> Bool
    exprIsTickedString CpeRhs
    rhs
                 is_lit FloatingBind
    _                                                = Bool
    False
                 (string_floats, top) = partitionOL is_lit (fs_binds floats)
                     -- Strings will *always* be in `top_floats` (we made sure of
                     -- that in `snocOL`), so that's the only field we need to
                     -- partition.
                 floats'   = Floats
    floats { fs_binds = top }
                 all_pairs = (FloatingBind -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)])
    -> [(InVar, CpeRhs)] -> OrdList FloatingBind -> [(InVar, CpeRhs)]
    forall a b. (a -> b -> b) -> b -> OrdList a -> b
    foldrOL FloatingBind -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
    add_float ([InVar]
    bndrs1 [InVar] -> [CpeRhs] -> [(InVar, CpeRhs)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [CpeRhs]
    rhss1) (Floats -> OrdList FloatingBind
    getFloats Floats
    floats')
           -- use env below, so that we reset cpe_rec_ids
           ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
                     snocFloat (emptyFloats { fs_binds = string_floats })
                               (Float (Rec all_pairs) LetBound TopLvlFloatable),
                     Nothing) }

      | Bool
    otherwise -- See Note [Join points and floating]
      = do { (env, bndrs1) <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
    cpCloneBndrs CorePrepEnv
    env [InVar]
    bndrs
           ; let env' = CorePrepEnv -> [InVar] -> CorePrepEnv
    enterRecGroupRHSs CorePrepEnv
    env [InVar]
    bndrs1
           ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss

           ; let bndrs2 = ((InVar, CpeRhs) -> InVar) -> [(InVar, CpeRhs)] -> [InVar]
    forall a b. (a -> b) -> [a] -> [b]
    map (InVar, CpeRhs) -> InVar
    forall a b. (a, b) -> a
    fst [(InVar, CpeRhs)]
    pairs1
           -- use env below, so that we reset cpe_rec_ids
           ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
                     emptyFloats,
                     Just (Rec pairs1)) }
      where
        ([InVar]
    bndrs, [CpeRhs]
    rhss) = [(InVar, CpeRhs)] -> ([InVar], [CpeRhs])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(InVar, CpeRhs)]
    pairs

        -- Flatten all the floats, and the current
        -- group into a single giant Rec
        add_float :: FloatingBind -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
    add_float (Float CoreBind
    bind BindInfo
    bound FloatInfo
    _) [(InVar, CpeRhs)]
    prs2
          | BindInfo
    bound BindInfo -> BindInfo -> Bool
    forall a. Eq a => a -> a -> Bool
    /= BindInfo
    CaseBound
          Bool -> Bool -> Bool
    || (InVar -> Bool) -> [InVar] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Type -> Bool
    definitelyLiftedType (Type -> Bool) -> (InVar -> Type) -> InVar -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . InVar -> Type
    idType) (CoreBind -> [InVar]
    forall b. Bind b -> [b]
    bindersOf CoreBind
    bind)
               -- The latter check is hit in -O0 (i.e., flavours quick, devel2)
               -- for dictionary args which haven't been floated out yet, #24102.
               -- They are preferably CaseBound, but since they are lifted we may
               -- just as well put them in the Rec, in contrast to lifted bindings.
          = case CoreBind
    bind of
              NonRec InVar
    x CpeRhs
    e -> (InVar
    x,CpeRhs
    e) (InVar, CpeRhs) -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
    forall a. a -> [a] -> [a]
    : [(InVar, CpeRhs)]
    prs2
              Rec [(InVar, CpeRhs)]
    prs1 -> [(InVar, CpeRhs)]
    prs1 [(InVar, CpeRhs)] -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
    forall a. [a] -> [a] -> [a]
    ++ [(InVar, CpeRhs)]
    prs2
        add_float FloatingBind
    f [(InVar, CpeRhs)]
    _ = String -> SDoc -> [(InVar, CpeRhs)]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "cpeBind" (FloatingBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatingBind
    f)

    ---------------
    cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
            -> CorePrepEnv -> OutId -> CoreExpr
            -> UniqSM (Floats, CpeRhs)
    -- Used for all bindings
    -- The binder is already cloned, hence an OutId
    cpePair :: TopLevelFlag
    -> RecFlag
    -> Demand
    -> Bool
    -> CorePrepEnv
    -> InVar
    -> CpeRhs
    -> UniqSM (Floats, CpeRhs)
    cpePair TopLevelFlag
    top_lvl RecFlag
    is_rec Demand
    dmd Bool
    is_unlifted CorePrepEnv
    env InVar
    bndr CpeRhs
    rhs
      = Bool -> UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. HasCallStack => Bool -> a -> a
    assert (Bool -> Bool
    not (InVar -> Bool
    isJoinId InVar
    bndr)) (UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs))
    -> UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a b. (a -> b) -> a -> b
    $ -- those should use cpeJoinPair
        do { (floats1, rhs1) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeRhsE CorePrepEnv
    env CpeRhs
    rhs

           -- See if we are allowed to float this stuff out of the RHS
           ; let dec = Floats -> CpeRhs -> FloatDecision
    want_float_from_rhs Floats
    floats1 CpeRhs
    rhs1
           ; (floats2, rhs2) <- executeFloatDecision dec floats1 rhs1

           -- Make the arity match up
           ; (floats3, rhs3)
                <- if manifestArity rhs1 <= arity
                   then return (floats2, cpeEtaExpand arity rhs2)
                   else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
                                   -- Note [Silly extra arguments]
                        (do { v <- newVar (idType bndr)
                            ; let float = CorePrepEnv -> Demand -> Bool -> InVar -> CpeRhs -> FloatingBind
    mkNonRecFloat CorePrepEnv
    env Demand
    topDmd Bool
    False InVar
    v CpeRhs
    rhs2
                            ; return ( snocFloat floats2 float
                                     , cpeEtaExpand arity (Var v)) })

            -- Wrap floating ticks
           ; let (floats4, rhs4) = wrapTicks floats3 rhs3

           ; return (floats4, rhs4) }
      where
        arity :: Int
    arity = InVar -> Int
    idArity InVar
    bndr        -- We must match this arity

        want_float_from_rhs :: Floats -> CpeRhs -> FloatDecision
    want_float_from_rhs Floats
    floats CpeRhs
    rhs
          | TopLevelFlag -> Bool
    isTopLevel TopLevelFlag
    top_lvl = Floats -> FloatDecision
    wantFloatTop Floats
    floats
          | Bool
    otherwise          = RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision
    wantFloatLocal RecFlag
    is_rec Demand
    dmd Bool
    is_unlifted Floats
    floats CpeRhs
    rhs

    {- Note [Silly extra arguments]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we had this
            f{arity=1} = \x\y. e
    We *must* match the arity on the Id, so we have to generate
            f' = \x\y. e
            f  = \x. f' x

    It's a bizarre case: why is the arity on the Id wrong?  Reason
    (in the days of __inline_me__):
            f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
    When InlineMe notes go away this won't happen any more.  But
    it seems good for CorePrep to be robust.
    -}

    ---------------
    cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
                -> UniqSM (JoinId, CpeRhs)
    -- Used for all join bindings
    -- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils
    cpeJoinPair :: CorePrepEnv -> InVar -> CpeRhs -> UniqSM (InVar, CpeRhs)
    cpeJoinPair CorePrepEnv
    env InVar
    bndr CpeRhs
    rhs
      = Bool -> UniqSM (InVar, CpeRhs) -> UniqSM (InVar, CpeRhs)
    forall a. HasCallStack => Bool -> a -> a
    assert (InVar -> Bool
    isJoinId InVar
    bndr) (UniqSM (InVar, CpeRhs) -> UniqSM (InVar, CpeRhs))
    -> UniqSM (InVar, CpeRhs) -> UniqSM (InVar, CpeRhs)
    forall a b. (a -> b) -> a -> b
    $
        do { let JoinPoint Int
    join_arity = InVar -> JoinPointHood
    idJoinPointHood InVar
    bndr
                 ([InVar]
    bndrs, CpeRhs
    body)        = Int -> CpeRhs -> ([InVar], CpeRhs)
    forall b. Int -> Expr b -> ([b], Expr b)
    collectNBinders Int
    join_arity CpeRhs
    rhs

           ; (env', bndrs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
    cpCloneBndrs CorePrepEnv
    env [InVar]
    bndrs

           ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts
                                          -- with a lambda

           ; let rhs'  = [InVar] -> CpeRhs -> CpeRhs
    mkCoreLams [InVar]
    bndrs' CpeRhs
    body'
                 bndr' = InVar
    bndr InVar -> Unfolding -> InVar
    `setIdUnfolding` Unfolding
    evaldUnfolding
                              InVar -> Int -> InVar
    `setIdArity` (InVar -> Bool) -> [InVar] -> Int
    forall a. (a -> Bool) -> [a] -> Int
    count InVar -> Bool
    isId [InVar]
    bndrs
                                -- See Note [Arity and join points]

           ; return (bndr', rhs') }

    {-
    Note [Arity and join points]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Up to now, we've allowed a join point to have an arity greater than its join
    arity (minus type arguments), since this is what's useful for eta expansion.
    However, for code gen purposes, its arity must be exactly the number of value
    arguments it will be called with, and it must have exactly that many value
    lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:

      join j x y z = \w -> ... in ...
        =>
      join j x y z = (let f = \w -> ... in f) in ...

    This is also what happens with Note [Silly extra arguments]. Note that it's okay
    for us to mess with the arity because a join point is never exported.
    -}

    -- ---------------------------------------------------------------------------
    --              CpeRhs: produces a result satisfying CpeRhs
    -- ---------------------------------------------------------------------------

    cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
    -- If
    --      e  ===>  (bs, e')
    -- then
    --      e = let bs in e'        (semantically, that is!)
    --
    -- For example
    --      f (g x)   ===>   ([v = g x], f v)

    cpeRhsE :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeRhsE CorePrepEnv
    env (Type Type
    ty)
      = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, Type -> CpeRhs
    forall b. Type -> Expr b
    Type (CorePrepEnv -> Type -> Type
    cpSubstTy CorePrepEnv
    env Type
    ty))
    cpeRhsE CorePrepEnv
    env (Coercion Coercion
    co)
      = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, Coercion -> CpeRhs
    forall b. Coercion -> Expr b
    Coercion (CorePrepEnv -> Coercion -> Coercion
    cpSubstCo CorePrepEnv
    env Coercion
    co))
    cpeRhsE CorePrepEnv
    env expr :: CpeRhs
    expr@(Lit Literal
    lit)
      | LitNumber LitNumType
    LitNumBigNat Integer
    i <- Literal
    lit
        = CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
    cpeBigNatLit CorePrepEnv
    env Integer
    i
      | Bool
    otherwise = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, CpeRhs
    expr)
    cpeRhsE CorePrepEnv
    env expr :: CpeRhs
    expr@(Var {})  = CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeApp CorePrepEnv
    env CpeRhs
    expr
    cpeRhsE CorePrepEnv
    env expr :: CpeRhs
    expr@(App {})  = CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeApp CorePrepEnv
    env CpeRhs
    expr

    cpeRhsE CorePrepEnv
    env (Let CoreBind
    bind CpeRhs
    body)
      = do { (env', bind_floats, maybe_bind') <- TopLevelFlag
    -> CorePrepEnv
    -> CoreBind
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    cpeBind TopLevelFlag
    NotTopLevel CorePrepEnv
    env CoreBind
    bind
           ; (body_floats, body') <- cpeRhsE env' body
           ; let expr' = case Maybe CoreBind
    maybe_bind' of Just CoreBind
    bind' -> CoreBind -> CpeRhs -> CpeRhs
    forall b. Bind b -> Expr b -> Expr b
    Let CoreBind
    bind' CpeRhs
    body'
                                             Maybe CoreBind
    Nothing    -> CpeRhs
    body'
           ; return (bind_floats `appFloats` body_floats, expr') }

    cpeRhsE CorePrepEnv
    env (Tick CoreTickish
    tickish CpeRhs
    expr)
      -- Pull out ticks if they are allowed to be floated.
      | CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishFloatable CoreTickish
    tickish
      = do { (floats, body) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeRhsE CorePrepEnv
    env CpeRhs
    expr
             -- See [Floating Ticks in CorePrep]
           ; return (FloatTick tickish `consFloat` floats, body) }
      | Bool
    otherwise
      = do { body <- CorePrepEnv -> CpeRhs -> UniqSM CpeRhs
    cpeBodyNF CorePrepEnv
    env CpeRhs
    expr
           ; return (emptyFloats, mkTick tickish' body) }
      where
        tickish' :: CoreTickish
    tickish' | Breakpoint XBreakpoint 'TickishPassCore
    ext Int
    n [XTickishId 'TickishPassCore]
    fvs Module
    modl <- CoreTickish
    tickish
                 -- See also 'substTickish'
                 = XBreakpoint 'TickishPassCore
    -> Int -> [XTickishId 'TickishPassCore] -> Module -> CoreTickish
    forall (pass :: TickishPass).
    XBreakpoint pass
    -> Int -> [XTickishId pass] -> Module -> GenTickish pass
    Breakpoint XBreakpoint 'TickishPassCore
    ext Int
    n ((InVar -> InVar) -> [InVar] -> [InVar]
    forall a b. (a -> b) -> [a] -> [b]
    map (HasDebugCallStack => CpeRhs -> InVar
    CpeRhs -> InVar
    getIdFromTrivialExpr (CpeRhs -> InVar) -> (InVar -> CpeRhs) -> InVar -> InVar
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CorePrepEnv -> InVar -> CpeRhs
    lookupCorePrepEnv CorePrepEnv
    env) [InVar]
    [XTickishId 'TickishPassCore]
    fvs) Module
    modl
                 | Bool
    otherwise
                 = CoreTickish
    tickish

    cpeRhsE CorePrepEnv
    env (Cast CpeRhs
    expr Coercion
    co)
       = do { (floats, expr') <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeRhsE CorePrepEnv
    env CpeRhs
    expr
            ; return (floats, Cast expr' (cpSubstCo env co)) }

    cpeRhsE CorePrepEnv
    env expr :: CpeRhs
    expr@(Lam {})
       = do { let ([InVar]
    bndrs,CpeRhs
    body) = CpeRhs -> ([InVar], CpeRhs)
    forall b. Expr b -> ([b], Expr b)
    collectBinders CpeRhs
    expr
            ; (env', bndrs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
    cpCloneBndrs CorePrepEnv
    env [InVar]
    bndrs
            ; body' <- cpeBodyNF env' body
            ; return (emptyFloats, mkLams bndrs' body') }

    cpeRhsE CorePrepEnv
    env (Case CpeRhs
    scrut InVar
    bndr Type
    _ alts :: [Alt InVar]
    alts@[Alt AltCon
    con [InVar
    covar] CpeRhs
    _])
      -- See (U3) in Note [Implementing unsafeCoerce]
      -- We need make the Case float, otherwise we get
      --   let x = case ... of UnsafeRefl co ->
      --           let y = expr in
      --           K y
      --   in f x
      -- instead of
      --   case ... of UnsafeRefl co ->
      --   let y = expr in
      --   let x = K y
      --   in f x
      -- Note that `x` is a value here. This is visible in the GHCi debugger tests
      -- (such as `print003`).
      | Just CpeRhs
    rhs <- CpeRhs -> InVar -> [Alt InVar] -> Maybe CpeRhs
    isUnsafeEqualityCase CpeRhs
    scrut InVar
    bndr [Alt InVar]
    alts
      = do { (floats_scrut, scrut) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeBody CorePrepEnv
    env CpeRhs
    scrut

           ; (env, bndr')  <- cpCloneBndr env bndr
           ; (env, covar') <- cpCloneCoVarBndr env covar
                              -- Important: here we clone the CoVar
                              -- See Note [Cloning CoVars and TyVars]

             -- Up until here this should do exactly the same as the regular code
             -- path of `cpeRhsE Case{}`.
           ; (floats_rhs, rhs) <- cpeBody env rhs
             -- ... but we want to float `floats_rhs` as in (U3) so that rhs' might
             -- become a value
           ; let case_float = CpeRhs -> InVar -> AltCon -> [InVar] -> FloatingBind
    UnsafeEqualityCase CpeRhs
    scrut InVar
    bndr' AltCon
    con [InVar
    covar']
             -- NB: It is OK to "evaluate" the proof eagerly.
             --     Usually there's the danger that we float the unsafeCoerce out of
             --     a branching Case alt. Not so here, because the regular code path
             --     for `cpeRhsE Case{}` will not float out of alts.
                 floats = Floats -> FloatingBind -> Floats
    snocFloat Floats
    floats_scrut FloatingBind
    case_float Floats -> Floats -> Floats
    `appFloats` Floats
    floats_rhs
           ; return (floats, rhs) }

    cpeRhsE CorePrepEnv
    env (Case CpeRhs
    scrut InVar
    bndr Type
    ty [Alt InVar]
    alts)
      = do { (floats, scrut') <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeBody CorePrepEnv
    env CpeRhs
    scrut
           ; (env', bndr2) <- cpCloneBndr env bndr
           ; let alts'
                   | CorePrepConfig -> Bool
    cp_catchNonexhaustiveCases (CorePrepConfig -> Bool) -> CorePrepConfig -> Bool
    forall a b. (a -> b) -> a -> b
    $ CorePrepEnv -> CorePrepConfig
    cpe_config CorePrepEnv
    env
                   , Bool -> Bool
    not ([Alt InVar] -> Bool
    forall b. [Alt b] -> Bool
    altsAreExhaustive [Alt InVar]
    alts)
                   = [Alt InVar] -> Maybe CpeRhs -> [Alt InVar]
    forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
    addDefault [Alt InVar]
    alts (CpeRhs -> Maybe CpeRhs
    forall a. a -> Maybe a
    Just CpeRhs
    err)
                   | Bool
    otherwise = [Alt InVar]
    alts
                   where err :: CpeRhs
    err = Type -> String -> CpeRhs
    mkImpossibleExpr Type
    ty String
    "cpeRhsE: missing case alternative"
           ; alts'' <- mapM (sat_alt env') alts'

           ; return (floats, Case scrut' bndr2 (cpSubstTy env ty) alts'') }
      where
        sat_alt :: CorePrepEnv -> Alt InVar -> UniqSM (Alt InVar)
    sat_alt CorePrepEnv
    env (Alt AltCon
    con [InVar]
    bs CpeRhs
    rhs)
           = do { (env2, bs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
    cpCloneBndrs CorePrepEnv
    env [InVar]
    bs
                ; rhs' <- cpeBodyNF env2 rhs
                ; return (Alt con bs' rhs') }

    -- ---------------------------------------------------------------------------
    --              CpeBody: produces a result satisfying CpeBody
    -- ---------------------------------------------------------------------------

    -- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without
    -- producing any floats (any generated floats are immediately
    -- let-bound using 'wrapBinds').  Generally you want this, esp.
    -- when you've reached a binding form (e.g., a lambda) and
    -- floating any further would be incorrect.
    cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
    cpeBodyNF :: CorePrepEnv -> CpeRhs -> UniqSM CpeRhs
    cpeBodyNF CorePrepEnv
    env CpeRhs
    expr
      = do { (floats, body) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeBody CorePrepEnv
    env CpeRhs
    expr
           ; return (wrapBinds floats body) }

    -- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce
    -- a list of 'Floats' which are being propagated upwards.  In
    -- fact, this function is used in only two cases: to
    -- implement 'cpeBodyNF' (which is what you usually want),
    -- and in the case when a let-binding is in a case scrutinee--here,
    -- we can always float out:
    --
    --      case (let x = y in z) of ...
    --      ==> let x = y in case z of ...
    --
    cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
    cpeBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeBody CorePrepEnv
    env CpeRhs
    expr
      = do { (floats1, rhs) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeRhsE CorePrepEnv
    env CpeRhs
    expr
           ; (floats2, body) <- rhsToBody rhs
           ; return (floats1 `appFloats` floats2, body) }

    --------
    rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
    -- Remove top level lambdas by let-binding

    rhsToBody :: CpeRhs -> UniqSM (Floats, CpeRhs)
    rhsToBody (Tick CoreTickish
    t CpeRhs
    expr)
      | CoreTickish -> TickishScoping
    forall (pass :: TickishPass). GenTickish pass -> TickishScoping
    tickishScoped CoreTickish
    t TickishScoping -> TickishScoping -> Bool
    forall a. Eq a => a -> a -> Bool
    == TickishScoping
    NoScope  -- only float out of non-scoped annotations
      = do { (floats, expr') <- CpeRhs -> UniqSM (Floats, CpeRhs)
    rhsToBody CpeRhs
    expr
           ; return (floats, mkTick t expr') }

    rhsToBody (Cast CpeRhs
    e Coercion
    co)
            -- You can get things like
            --      case e of { p -> coerce t (\s -> ...) }
      = do { (floats, e') <- CpeRhs -> UniqSM (Floats, CpeRhs)
    rhsToBody CpeRhs
    e
           ; return (floats, Cast e' co) }

    rhsToBody expr :: CpeRhs
    expr@(Lam {})   -- See Note [No eta reduction needed in rhsToBody]
      | (InVar -> Bool) -> [InVar] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all InVar -> Bool
    isTyVar [InVar]
    bndrs           -- Type lambdas are ok
      = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, CpeRhs
    expr)
      | Bool
    otherwise                   -- Some value lambdas
      = do { let rhs :: CpeRhs
    rhs = Int -> CpeRhs -> CpeRhs
    cpeEtaExpand (CpeRhs -> Int
    exprArity CpeRhs
    expr) CpeRhs
    expr
           ; fn <- Type -> UniqSM InVar
    newVar (HasDebugCallStack => CpeRhs -> Type
    CpeRhs -> Type
    exprType CpeRhs
    rhs)
           ; let float = CoreBind -> BindInfo -> FloatInfo -> FloatingBind
    Float (InVar -> CpeRhs -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec InVar
    fn CpeRhs
    rhs) BindInfo
    LetBound FloatInfo
    TopLvlFloatable
           ; return (unitFloat float, Var fn) }
      where
        ([InVar]
    bndrs,CpeRhs
    _) = CpeRhs -> ([InVar], CpeRhs)
    forall b. Expr b -> ([b], Expr b)
    collectBinders CpeRhs
    expr

    rhsToBody CpeRhs
    expr = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, CpeRhs
    expr)

    {- Note [No eta reduction needed in rhsToBody]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Historical note.  In the olden days we used to have a Prep-specific
    eta-reduction step in rhsToBody:
      rhsToBody expr@(Lam {})
        | Just no_lam_result <- tryEtaReducePrep bndrs body
        = return (emptyFloats, no_lam_result)

    The goal was to reduce
            case x of { p -> \xs. map f xs }
        ==> case x of { p -> map f }

    to avoid allocating a lambda.  Of course, we'd allocate a PAP
    instead, which is hardly better, but that's the way it was.

    Now we simply don't bother with this. It doesn't seem to be a win,
    and it's extra work.
    -}

    -- ---------------------------------------------------------------------------
    --              CpeApp: produces a result satisfying CpeApp
    -- ---------------------------------------------------------------------------

    data ArgInfo = CpeApp  CoreArg
                 | CpeCast Coercion
                 | CpeTick CoreTickish

    instance Outputable ArgInfo where
      ppr :: ArgInfo -> SDoc
    ppr (CpeApp CpeRhs
    arg) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "app" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CpeRhs -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CpeRhs
    arg
      ppr (CpeCast Coercion
    co) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "cast" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Coercion -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Coercion
    co
      ppr (CpeTick CoreTickish
    tick) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "tick" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreTickish -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreTickish
    tick

    {- Note [Ticks and mandatory eta expansion]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Something like
        `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`
    caused a compiler panic in #20938. Why did this happen?
    The simplifier will eta-reduce the rhs giving us a partial
    application of tagToEnum#. The tick is then pushed inside the
    type argument. That is we get
        `(Tick<foo> tagToEnum#) @Bool`
    CorePrep would go on to see a undersaturated tagToEnum# application
    and eta expand the expression under the tick. Giving us:
        (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool
    Suddenly tagToEnum# is applied to a polymorphic type and the code generator
    panics as it needs a concrete type to determine the representation.

    The problem in my eyes was that the tick covers a partial application
    of a primop. There is no clear semantic for such a construct as we can't
    partially apply a primop since they do not have bindings.
    We fix this by expanding the scope of such ticks slightly to cover the body
    of the eta-expanded expression.

    We do this by:
    * Checking if an application is headed by a primOpish thing.
    * If so we collect floatable ticks and usually but also profiling ticks
      along with regular arguments.
    * When rebuilding the application we check if any profiling ticks appear
      before the primop is fully saturated.
    * If the primop isn't fully satured we eta expand the primop application
      and scope the tick to scope over the body of the saturated expression.

    Going back to #20938 this means starting with
        `(Tick<foo> tagToEnum#) @Bool`
    we check if the function head is a primop (yes). This means we collect the
    profiling tick like if it was floatable. Giving us
        (tagToEnum#, [CpeTick foo, CpeApp @Bool]).
    cpe_app filters out the tick as a underscoped tick on the expression
    `tagToEnum# @Bool`. During eta expansion we then put that tick back onto the
    body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.
    -}
    cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
    -- May return a CpeRhs because of saturating primops
    cpeApp :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeApp CorePrepEnv
    top_env CpeRhs
    expr
      = do { let (CpeRhs
    terminal, [ArgInfo]
    args) = CpeRhs -> (CpeRhs, [ArgInfo])
    collect_args CpeRhs
    expr
          --  ; pprTraceM "cpeApp" $ (ppr expr)
           ; CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
    cpe_app CorePrepEnv
    top_env CpeRhs
    terminal [ArgInfo]
    args
           }

      where
        -- We have a nested data structure of the form
        -- e `App` a1 `App` a2 ... `App` an, convert it into
        -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
        -- We use 'ArgInfo' because we may also need to
        -- record casts and ticks.  Depth counts the number
        -- of arguments that would consume strictness information
        -- (so, no type or coercion arguments.)
        collect_args :: CoreExpr -> (CoreExpr, [ArgInfo])
        collect_args :: CpeRhs -> (CpeRhs, [ArgInfo])
    collect_args CpeRhs
    e = CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
    go CpeRhs
    e []
          where
            go :: CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
    go (App CpeRhs
    fun CpeRhs
    arg)      [ArgInfo]
    as
                = CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
    go CpeRhs
    fun (CpeRhs -> ArgInfo
    CpeApp CpeRhs
    arg ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    as)
            go (Cast CpeRhs
    fun Coercion
    co)      [ArgInfo]
    as
                = CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
    go CpeRhs
    fun (Coercion -> ArgInfo
    CpeCast Coercion
    co ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    as)
            go (Tick CoreTickish
    tickish CpeRhs
    fun) [ArgInfo]
    as
                -- Profiling ticks are slightly less strict so we expand their scope
                -- if they cover partial applications of things like primOps.
                -- See Note [Ticks and mandatory eta expansion]
                -- Here we look inside `fun` before we make the final decision about
                -- floating the tick which isn't optimal for perf. But this only makes
                -- a difference if we have a non-floatable tick which is somewhat rare.
                | Var InVar
    vh <- CpeRhs
    head
                , Var InVar
    head' <- CorePrepEnv -> InVar -> CpeRhs
    lookupCorePrepEnv CorePrepEnv
    top_env InVar
    vh
                , InVar -> CoreTickish -> Bool
    forall (pass :: TickishPass). InVar -> GenTickish pass -> Bool
    etaExpansionTick InVar
    head' CoreTickish
    tickish
                = (CpeRhs
    head,[ArgInfo]
    as')
                where
                  (CpeRhs
    head,[ArgInfo]
    as') = CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
    go CpeRhs
    fun (CoreTickish -> ArgInfo
    CpeTick CoreTickish
    tickish ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    as)

            -- Terminal could still be an app if it's wrapped by a tick.
            -- E.g. Tick<foo> (f x) can give us (f x) as terminal.
            go CpeRhs
    terminal [ArgInfo]
    as = (CpeRhs
    terminal, [ArgInfo]
    as)

        cpe_app :: CorePrepEnv
                -> CoreExpr -- The thing we are calling
                -> [ArgInfo]
                -> UniqSM (Floats, CpeRhs)
        cpe_app :: CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
    cpe_app CorePrepEnv
    env (Var InVar
    f) (CpeApp Type{} : CpeApp CpeRhs
    arg : [ArgInfo]
    args)
            | InVar
    f InVar -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    lazyIdKey          -- Replace (lazy a) with a, and
                -- See Note [lazyId magic] in GHC.Types.Id.Make
           Bool -> Bool -> Bool
    || InVar
    f InVar -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    noinlineIdKey Bool -> Bool -> Bool
    || InVar
    f InVar -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    noinlineConstraintIdKey
                -- Replace (noinline a) with a
                -- See Note [noinlineId magic] in GHC.Types.Id.Make
           Bool -> Bool -> Bool
    || InVar
    f InVar -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    nospecIdKey        -- Replace (nospec a) with a
                -- See Note [nospecId magic] in GHC.Types.Id.Make

            -- Consider the code:
            --
            --      lazy (f x) y
            --
            -- We need to make sure that we need to recursively collect arguments on
            -- "f x", otherwise we'll float "f x" out (it's not a variable) and
            -- end up with this awful -ddump-prep:
            --
            --      case f x of f_x {
            --        __DEFAULT -> f_x y
            --      }
            --
            -- rather than the far superior "f x y".  Test case is par01.
            = let (CpeRhs
    terminal, [ArgInfo]
    args') = CpeRhs -> (CpeRhs, [ArgInfo])
    collect_args CpeRhs
    arg
              in CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
    cpe_app CorePrepEnv
    env CpeRhs
    terminal ([ArgInfo]
    args' [ArgInfo] -> [ArgInfo] -> [ArgInfo]
    forall a. [a] -> [a] -> [a]
    ++ [ArgInfo]
    args)

        -- runRW# magic
        cpe_app CorePrepEnv
    env (Var InVar
    f) (CpeApp _runtimeRep :: CpeRhs
    _runtimeRep@Type{} : CpeApp _type :: CpeRhs
    _type@Type{} : CpeApp CpeRhs
    arg : [ArgInfo]
    rest)
            | InVar
    f InVar -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    runRWKey
            -- N.B. While it may appear that n == 1 in the case of runRW#
            -- applications, keep in mind that we may have applications that return
            , [ArgInfo] -> Bool
    has_value_arg (CpeRhs -> ArgInfo
    CpeApp CpeRhs
    arg ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    rest)
            -- See Note [runRW magic]
            -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
            -- is why we return a CorePrepEnv as well)
            = case CpeRhs
    arg of
                Lam InVar
    s CpeRhs
    body -> CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
    cpe_app (CorePrepEnv -> InVar -> InVar -> CorePrepEnv
    extendCorePrepEnv CorePrepEnv
    env InVar
    s InVar
    realWorldPrimId) CpeRhs
    body [ArgInfo]
    rest
                CpeRhs
    _          -> CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
    cpe_app CorePrepEnv
    env CpeRhs
    arg (CpeRhs -> ArgInfo
    CpeApp (InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    realWorldPrimId) ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    rest)
                 -- TODO: What about casts?
            where
              has_value_arg :: [ArgInfo] -> Bool
    has_value_arg [] = Bool
    False
              has_value_arg (CpeApp CpeRhs
    arg:[ArgInfo]
    _rest)
                | Bool -> Bool
    not (CpeRhs -> Bool
    forall b. Expr b -> Bool
    isTyCoArg CpeRhs
    arg) = Bool
    True
              has_value_arg (ArgInfo
    _:[ArgInfo]
    rest) = [ArgInfo] -> Bool
    has_value_arg [ArgInfo]
    rest

        cpe_app CorePrepEnv
    env (Var InVar
    v) [ArgInfo]
    args
          = do { v1 <- InVar -> UniqSM InVar
    fiddleCCall InVar
    v
               ; let e2 = CorePrepEnv -> InVar -> CpeRhs
    lookupCorePrepEnv CorePrepEnv
    env InVar
    v1
                     hd = CpeRhs -> Maybe InVar
    getIdFromTrivialExpr_maybe CpeRhs
    e2
                     -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
                     min_arity = case Maybe InVar
    hd of
                       Just InVar
    v_hd -> if InVar -> Bool
    hasNoBinding InVar
    v_hd then Int -> Maybe Int
    forall a. a -> Maybe a
    Just (Int -> Maybe Int) -> Int -> Maybe Int
    forall a b. (a -> b) -> a -> b
    $! (InVar -> Int
    idArity InVar
    v_hd) else Maybe Int
    forall a. Maybe a
    Nothing
                       Maybe InVar
    Nothing -> Maybe Int
    forall a. Maybe a
    Nothing
              --  ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))
               ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity
               ; mb_saturate hd app floats unsat_ticks depth }
            where
              depth :: Int
    depth = [ArgInfo] -> Int
    val_args [ArgInfo]
    args
              stricts :: [Demand]
    stricts = case InVar -> DmdSig
    idDmdSig InVar
    v of
                                DmdSig (DmdType DmdEnv
    _ [Demand]
    demands)
                                  | [Demand] -> Int -> Ordering
    forall a. [a] -> Int -> Ordering
    listLengthCmp [Demand]
    demands Int
    depth Ordering -> Ordering -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Ordering
    GT -> [Demand]
    demands
                                        -- length demands <= depth
                                  | Bool
    otherwise                         -> []
                    -- If depth < length demands, then we have too few args to
                    -- satisfy strictness  info so we have to  ignore all the
                    -- strictness info, e.g. + (error "urk")
                    -- Here, we can't evaluate the arg strictly, because this
                    -- partial application might be seq'd

            -- We inlined into something that's not a var and has no args.
            -- Bounce it back up to cpeRhsE.
        cpe_app CorePrepEnv
    env CpeRhs
    fun [] = CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeRhsE CorePrepEnv
    env CpeRhs
    fun

        -- Here we get:
        -- N-variable fun, better let-bind it
        -- This case covers literals, apps, lams or let expressions applied to arguments.
        -- Basically things we want to ANF before applying to arguments.
        cpe_app CorePrepEnv
    env CpeRhs
    fun [ArgInfo]
    args
          = do { (fun_floats, fun') <- CorePrepEnv -> Demand -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeArg CorePrepEnv
    env Demand
    evalDmd CpeRhs
    fun
                              -- If evalDmd says that it's sure to be evaluated,
                              -- we'll end up case-binding it
               ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing
               ; mb_saturate Nothing app floats unsat_ticks (val_args args) }

        -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG)
        val_args :: [ArgInfo] -> Int
        val_args :: [ArgInfo] -> Int
    val_args [ArgInfo]
    args = [ArgInfo] -> Int -> Int
    forall {t}. Num t => [ArgInfo] -> t -> t
    go [ArgInfo]
    args Int
    0
          where
            go :: [ArgInfo] -> t -> t
    go [] !t
    n = t
    n
            go (ArgInfo
    info:[ArgInfo]
    infos) t
    n =
              case ArgInfo
    info of
                CpeCast {} -> [ArgInfo] -> t -> t
    go [ArgInfo]
    infos t
    n
                CpeTick CoreTickish
    tickish
                  | CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishFloatable CoreTickish
    tickish                 -> [ArgInfo] -> t -> t
    go [ArgInfo]
    infos t
    n
                  -- If we can't guarantee a tick will be floated out of the application
                  -- we can't guarantee the value args following it will be applied.
                  | Bool
    otherwise                             -> t
    n
                CpeApp CpeRhs
    e                                  -> [ArgInfo] -> t -> t
    go [ArgInfo]
    infos t
    n'
                  where
                    !n' :: t
    n'
                      | CpeRhs -> Bool
    forall b. Expr b -> Bool
    isTypeArg CpeRhs
    e = t
    n
                      | Bool
    otherwise   = t
    nt -> t -> t
    forall a. Num a => a -> a -> a
    +t
    1

        -- Saturate if necessary
        mb_saturate :: Maybe InVar
    -> CpeRhs -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeRhs)
    mb_saturate Maybe InVar
    head CpeRhs
    app a
    floats [CoreTickish]
    unsat_ticks Int
    depth =
           case Maybe InVar
    head of
             Just InVar
    fn_id -> do { sat_app <- InVar -> CpeRhs -> Int -> [CoreTickish] -> UniqSM CpeRhs
    maybeSaturate InVar
    fn_id CpeRhs
    app Int
    depth [CoreTickish]
    unsat_ticks
                              ; return (floats, sat_app) }
             Maybe InVar
    _other     -> do { Bool -> UniqSM ()
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
    massert ([CoreTickish] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [CoreTickish]
    unsat_ticks)
                              ; (a, CpeRhs) -> UniqSM (a, CpeRhs)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    floats, CpeRhs
    app) }

        -- Deconstruct and rebuild the application, floating any non-atomic
        -- arguments to the outside.  We collect the type of the expression,
        -- the head of the application, and the number of actual value arguments,
        -- all of which are used to possibly saturate this application if it
        -- has a constructor or primop at the head.
        rebuild_app
            :: CorePrepEnv
            -> [ArgInfo]                  -- The arguments (inner to outer)
            -> CpeApp                     -- The function
            -> Floats                     -- INVARIANT: These floats don't bind anything that is in the CpeApp!
                                          -- Just stuff floated out from the head of the application.
            -> [Demand]
            -> Maybe Arity
            -> UniqSM (CpeApp
                      ,Floats
                      ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]
                      )
        rebuild_app :: CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> Maybe Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app CorePrepEnv
    env [ArgInfo]
    args CpeRhs
    app Floats
    floats [Demand]
    ss Maybe Int
    req_depth =
          CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    args CpeRhs
    app Floats
    floats [Demand]
    ss [] (Int -> Maybe Int -> Int
    forall a. a -> Maybe a -> a
    fromMaybe Int
    0 Maybe Int
    req_depth)

        rebuild_app'
            :: CorePrepEnv
            -> [ArgInfo] -- The arguments (inner to outer)
            -> CpeApp
            -> Floats
            -> [Demand]
            -> [CoreTickish]
            -> Int -- Number of arguments required to satisfy minimal tick scopes.
            -> UniqSM (CpeApp, Floats, [CoreTickish])
        rebuild_app' :: CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    _ [] CpeRhs
    app Floats
    floats [Demand]
    ss [CoreTickish]
    rt_ticks !Int
    _req_depth
          = Bool
    -> SDoc
    -> ((CpeRhs, Floats, [CoreTickish])
        -> UniqSM (CpeRhs, Floats, [CoreTickish]))
    -> (CpeRhs, Floats, [CoreTickish])
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr ([Demand] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Demand]
    ss) ([Demand] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Demand]
    ss)-- make sure we used all the strictness info
            (CpeRhs, Floats, [CoreTickish])
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CpeRhs
    app, Floats
    floats, [CoreTickish]
    rt_ticks)

        rebuild_app' CorePrepEnv
    env (ArgInfo
    a : [ArgInfo]
    as) CpeRhs
    fun' Floats
    floats [Demand]
    ss [CoreTickish]
    rt_ticks Int
    req_depth = case ArgInfo
    a of
          -- See Note [Ticks and mandatory eta expansion]
          ArgInfo
    _
            | Bool -> Bool
    not ([CoreTickish] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [CoreTickish]
    rt_ticks)
            , Int
    req_depth Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    0
            ->
                let tick_fun :: CpeRhs
    tick_fun = (CoreTickish -> CpeRhs -> CpeRhs)
    -> CpeRhs -> [CoreTickish] -> CpeRhs
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr CoreTickish -> CpeRhs -> CpeRhs
    mkTick CpeRhs
    fun' [CoreTickish]
    rt_ticks
                in CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env (ArgInfo
    a ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    as) CpeRhs
    tick_fun Floats
    floats [Demand]
    ss [CoreTickish]
    rt_ticks Int
    req_depth

          CpeApp (Type Type
    arg_ty)
            -> CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as (CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    App CpeRhs
    fun' (Type -> CpeRhs
    forall b. Type -> Expr b
    Type Type
    arg_ty')) Floats
    floats [Demand]
    ss [CoreTickish]
    rt_ticks Int
    req_depth
            where
               arg_ty' :: Type
    arg_ty' = CorePrepEnv -> Type -> Type
    cpSubstTy CorePrepEnv
    env Type
    arg_ty

          CpeApp (Coercion Coercion
    co)
            -> CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as (CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    App CpeRhs
    fun' (Coercion -> CpeRhs
    forall b. Coercion -> Expr b
    Coercion Coercion
    co')) Floats
    floats (Int -> [Demand] -> [Demand]
    forall a. Int -> [a] -> [a]
    drop Int
    1 [Demand]
    ss) [CoreTickish]
    rt_ticks Int
    req_depth
            where
               co' :: Coercion
    co' = CorePrepEnv -> Coercion -> Coercion
    cpSubstCo CorePrepEnv
    env Coercion
    co

          CpeApp CpeRhs
    arg -> do
            let (Demand
    ss1, [Demand]
    ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make
                   = case ([Demand]
    ss, CpeRhs -> Bool
    isLazyExpr CpeRhs
    arg) of
                       (Demand
    _   : [Demand]
    ss_rest, Bool
    True)  -> (Demand
    topDmd, [Demand]
    ss_rest)
                       (Demand
    ss1 : [Demand]
    ss_rest, Bool
    False) -> (Demand
    ss1,    [Demand]
    ss_rest)
                       ([],            Bool
    _)     -> (Demand
    topDmd, [])
            (fs, arg') <- CorePrepEnv -> Demand -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeArg CorePrepEnv
    top_env Demand
    ss1 CpeRhs
    arg
            rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1)

          CpeCast Coercion
    co
            -> CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as (CpeRhs -> Coercion -> CpeRhs
    forall b. Expr b -> Coercion -> Expr b
    Cast CpeRhs
    fun' Coercion
    co') Floats
    floats [Demand]
    ss [CoreTickish]
    rt_ticks Int
    req_depth
            where
               co' :: Coercion
    co' = CorePrepEnv -> Coercion -> Coercion
    cpSubstCo CorePrepEnv
    env Coercion
    co

          -- See Note [Ticks and mandatory eta expansion]
          CpeTick CoreTickish
    tickish
            | CoreTickish -> TickishPlacement
    forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
    tickishPlace CoreTickish
    tickish TickishPlacement -> TickishPlacement -> Bool
    forall a. Eq a => a -> a -> Bool
    == TickishPlacement
    PlaceRuntime
            , Int
    req_depth Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0
            -> Bool
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    forall a. HasCallStack => Bool -> a -> a
    assert (CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    isProfTick CoreTickish
    tickish) (UniqSM (CpeRhs, Floats, [CoreTickish])
     -> UniqSM (CpeRhs, Floats, [CoreTickish]))
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    forall a b. (a -> b) -> a -> b
    $
               CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as CpeRhs
    fun' Floats
    floats [Demand]
    ss (CoreTickish
    tickishCoreTickish -> [CoreTickish] -> [CoreTickish]
    forall a. a -> [a] -> [a]
    :[CoreTickish]
    rt_ticks) Int
    req_depth
            | Bool
    otherwise
            -- See [Floating Ticks in CorePrep]
            -> CorePrepEnv
    -> [ArgInfo]
    -> CpeRhs
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeRhs, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as CpeRhs
    fun' (Floats -> FloatingBind -> Floats
    snocFloat Floats
    floats (CoreTickish -> FloatingBind
    FloatTick CoreTickish
    tickish)) [Demand]
    ss [CoreTickish]
    rt_ticks Int
    req_depth

    isLazyExpr :: CoreExpr -> Bool
    -- See Note [lazyId magic] in GHC.Types.Id.Make
    isLazyExpr :: CpeRhs -> Bool
    isLazyExpr (Cast CpeRhs
    e Coercion
    _)              = CpeRhs -> Bool
    isLazyExpr CpeRhs
    e
    isLazyExpr (Tick CoreTickish
    _ CpeRhs
    e)              = CpeRhs -> Bool
    isLazyExpr CpeRhs
    e
    isLazyExpr (Var InVar
    f `App` CpeRhs
    _ `App` CpeRhs
    _) = InVar
    f InVar -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    lazyIdKey
    isLazyExpr CpeRhs
    _                       = Bool
    False

    {- Note [runRW magic]
    ~~~~~~~~~~~~~~~~~~~~~
    Some definitions, for instance @runST@, must have careful control over float out
    of the bindings in their body. Consider this use of @runST@,

        f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s
                                 (_, s'') = fill_in_array_or_something a x s'
                             in freezeArray# a s'' )

    If we inline @runST@, we'll get:

        f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}
                  (_, s'') = fill_in_array_or_something a x s'
              in freezeArray# a s''

    And now if we allow the @newArray#@ binding to float out to become a CAF,
    we end up with a result that is totally and utterly wrong:

        f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
            in \ x ->
                let (_, s'') = fill_in_array_or_something a x s'
                in freezeArray# a s''

    All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
    must be prevented.

    This is what @runRW#@ gives us: by being inlined extremely late in the
    optimization (right before lowering to STG, in CorePrep), we can ensure that
    no further floating will occur. This allows us to safely inline things like
    @runST@, which are otherwise needlessly expensive (see #10678 and #5916).

    'runRW' has a variety of quirks:

     * 'runRW' is known-key with a NOINLINE definition in
       GHC.Magic. This definition is used in cases where runRW is curried.

     * In addition to its normal Haskell definition in GHC.Magic, we give it
       a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding
       the incorrect sharing due to float-out noted above.

     * It is levity-polymorphic:

        runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
               => (State# RealWorld -> (# State# RealWorld, o #))
               -> (# State# RealWorld, o #)

     * It has some special simplification logic to allow unboxing of results when
       runRW# appears in a strict context. See Note [Simplification of runRW#]
       below.

     * Since its body is inlined, we allow runRW#'s argument to contain jumps to
       join points. That is, the following is allowed:

        join j x = ...
        in runRW# @_ @_ (\s -> ... jump j 42 ...)

       The Core Linter knows about this. See Note [Linting of runRW#] in
       GHC.Core.Lint for details.

       The occurrence analyser and SetLevels also know about this, as described in
       Note [Simplification of runRW#].

    Other relevant Notes:

     * Note [Simplification of runRW#] below, describing a transformation of runRW
       applications in strict contexts performed by the simplifier.
     * Note [Linting of runRW#] in GHC.Core.Lint
     * Note [runRW arg] below, describing a non-obvious case where the
       late-inlining could go wrong.

    Note [runRW arg]
    ~~~~~~~~~~~~~~~~~~~
    Consider the Core program (from #11291),

       runRW# (case bot of {})

    The late inlining logic in cpe_app would transform this into:

       (case bot of {}) realWorld#

    Which would rise to a panic in CoreToStg.myCollectArgs, which expects only
    variables in function position.

    However, as runRW#'s strictness signature captures the fact that it will call
    its argument this can't happen: the simplifier will transform the bottoming
    application into simply (case bot of {}).

    Note that this reasoning does *not* apply to non-bottoming continuations like:

        hello :: Bool -> Int
        hello n =
          runRW# (
              case n of
                True -> \s -> 23
                _    -> \s -> 10)

    Why? The difference is that (case bot of {}) is considered by okCpeArg to be
    trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both
    the function and the arguments) will forgo binding it to a variable. By
    contrast, in the non-bottoming case of `hello` above  the function will be
    deemed non-trivial and consequently will be case-bound.

    Note [Simplification of runRW#]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider the program,

        case runRW# (\s -> I# 42#) of
          I# n# -> f n#

    There is no reason why we should allocate an I# constructor given that we
    immediately destructure it.

    To avoid this the simplifier has a special transformation rule, specific to
    runRW#, that pushes a strict context into runRW#'s continuation.  See the
    `runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`.  That is, it transforms

        K[ runRW# @r @ty cont ]
                  ~>
        runRW# @r @ty (\s -> K[cont s])

    This has a few interesting implications. Consider, for instance, this program:

        join j = ...
        in case runRW# @r @ty cont of
             result -> jump j result

    Performing the transform described above would result in:

        join j x = ...
        in runRW# @r @ty (\s ->
             case cont of in
               result -> jump j result
           )

    If runRW# were a "normal" function this call to join point j would not be
    allowed in its continuation argument. However, since runRW# is inlined (as
    described in Note [runRW magic] above), such join point occurrences are
    completely fine. Both occurrence analysis (see the runRW guard in occAnalApp)
    and Core Lint (see the App case of lintCoreExpr) have special treatment for
    runRW# applications. See Note [Linting of runRW#] for details on the latter.

    Moreover, it's helpful to ensure that runRW's continuation isn't floated out
    For instance, if we have

        runRW# (\s -> do_something)

    where do_something contains only top-level free variables, we may be tempted to
    float the argument to the top-level. However, we must resist this urge as since
    doing so would then require that runRW# produce an allocation and call, e.g.:

        let lvl = \s -> do_somethign
        in
        ....(runRW# lvl)....

    whereas without floating the inlining of the definition of runRW would result
    in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special
    treatment for runRW# applications, ensure the arguments are not floated as
    MFEs.

    Now that we float evaluation context into runRW#, we also have to give runRW# a
    special higher-order CPR transformer lest we risk #19822. E.g.,

      case runRW# (\s -> doThings) of x -> Data.Text.Text x something something'
          ~>
      runRW# (\s -> case doThings s of x -> Data.Text.Text x something something')

    The former had the CPR property, and so should the latter.

    Other considered designs
    ------------------------

    One design that was rejected was to *require* that runRW#'s continuation be
    headed by a lambda. However, this proved to be quite fragile. For instance,
    SetLevels is very eager to float bottoming expressions. For instance given
    something of the form,

        runRW# @r @ty (\s -> case expr of x -> undefined)

    SetLevels will see that the body the lambda is bottoming and will consequently
    float it to the top-level (assuming expr has no free coercion variables which
    prevent this). We therefore end up with

        runRW# @r @ty (\s -> lvl s)

    Which the simplifier will beta reduce, leaving us with

        runRW# @r @ty lvl

    Breaking our desired invariant. Ultimately we decided to simply accept that
    the continuation may not be a manifest lambda.

    -- ---------------------------------------------------------------------------
    --      CpeArg: produces a result satisfying CpeArg
    -- ---------------------------------------------------------------------------

    Note [ANF-ising literal string arguments]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider a Core program like,

        data Foo = Foo Addr#
        foo = Foo "turtle"#

    String literals are non-trivial, see 'GHC.Types.Literal.litIsTrivial', hence
    they are non-atomic in STG.
    With -O1, FloatOut is likely to have floated most of these strings to top-level,
    not least to give CSE a chance to deduplicate strings early (before the
    linker, that is).
    (Notable exceptions seem to be applications of 'unpackAppendCString#'.)
    But with -O0, there is no FloatOut, so CorePrep must do the ANFisation to

        s = "turtle"#
        foo = Foo s

    (String literals are the only kind of binding allowed at top-level and hence
    their `FloatInfo` is `TopLvlFloatable`.)

    This appears to lead to bad code if the arg is under a lambda, because CorePrep
    doesn't float out of RHSs, e.g., (T23270)

        foo x = ... patError "turtle"# ...
    ==> foo x = ... case "turtle"# of s { __DEFAULT -> petError s } ...

    This looks bad because it evals an HNF on every call.
    But actually, it doesn't, because "turtle"# is already an HNF. Here is the Cmm:

      [section ""cstring" . cB4_str" {
           cB4_str:
               I8[] "turtle"
       }
      ...
      _sAG::I64 = cB4_str;
      R2 = _sAG::I64;
      Sp = Sp + 8;
      call Control.Exception.Base.patError_info(R2) args: 8, res: 0, upd: 8;

    Wrinkles:

    (FS1) We detect string literals in `cpeBind Rec{}` and float them out anyway;
          otherwise we'd try to bind a string literal in a letrec, violating
          Note [Core letrec invariant]. Since we know that literals don't have
          free variables, we float further.
          Arguably, we could just as well relax the letrec invariant for
          string literals, or anthing that is a value (lifted or not).
          This is tracked in #24036.
    -}

    -- This is where we arrange that a non-trivial argument is let-bound
    cpeArg :: CorePrepEnv -> Demand
           -> CoreArg -> UniqSM (Floats, CpeArg)
    cpeArg :: CorePrepEnv -> Demand -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeArg CorePrepEnv
    env Demand
    dmd CpeRhs
    arg
      = do { (floats1, arg1) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
    cpeRhsE CorePrepEnv
    env CpeRhs
    arg     -- arg1 can be a lambda
           ; let arg_ty      = HasDebugCallStack => CpeRhs -> Type
    CpeRhs -> Type
    exprType CpeRhs
    arg1
                 is_unlifted = HasDebugCallStack => Type -> Bool
    Type -> Bool
    isUnliftedType Type
    arg_ty
                 dec         = RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision
    wantFloatLocal RecFlag
    NonRecursive Demand
    dmd Bool
    is_unlifted Floats
    floats1 CpeRhs
    arg1
           ; (floats2, arg2) <- executeFloatDecision dec floats1 arg1
                    -- Else case: arg1 might have lambdas, and we can't
                    --            put them inside a wrapBinds

           -- Now ANF-ise any non-trivial argument
           -- NB: "non-trivial" includes string literals;
           -- see Note [ANF-ising literal string arguments]
           ; if exprIsTrivial arg2
             then return (floats2, arg2)
             else do { v <- newVar arg_ty
                     -- See Note [Eta expansion of arguments in CorePrep]
                     ; let arity = CorePrepEnv -> FloatDecision -> CpeRhs -> Int
    cpeArgArity CorePrepEnv
    env FloatDecision
    dec CpeRhs
    arg2
                           arg3  = Int -> CpeRhs -> CpeRhs
    cpeEtaExpand Int
    arity CpeRhs
    arg2
                           arg_float = CorePrepEnv -> Demand -> Bool -> InVar -> CpeRhs -> FloatingBind
    mkNonRecFloat CorePrepEnv
    env Demand
    dmd Bool
    is_unlifted InVar
    v CpeRhs
    arg3
                     ; return (snocFloat floats2 arg_float, varToCoreExpr v) }
           }

    cpeArgArity :: CorePrepEnv -> FloatDecision -> CoreArg -> Arity
    -- ^ See Note [Eta expansion of arguments in CorePrep]
    -- Returning 0 means "no eta-expansion"; see cpeEtaExpand
    cpeArgArity :: CorePrepEnv -> FloatDecision -> CpeRhs -> Int
    cpeArgArity CorePrepEnv
    env FloatDecision
    float_decision CpeRhs
    arg
      | FloatDecision
    FloatNone <- FloatDecision
    float_decision
      = Int
    0    -- Crucial short-cut
             -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep]

      | Just ArityOpts
    ao <- CorePrepConfig -> Maybe ArityOpts
    cp_arityOpts (CorePrepEnv -> CorePrepConfig
    cpe_config CorePrepEnv
    env) -- Just <=> -O1 or -O2
      , Bool -> Bool
    not (CpeRhs -> Bool
    eta_would_wreck_join CpeRhs
    arg)
                -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]
      = case HasDebugCallStack => ArityOpts -> CpeRhs -> Maybe SafeArityType
    ArityOpts -> CpeRhs -> Maybe SafeArityType
    exprEtaExpandArity ArityOpts
    ao CpeRhs
    arg of
          Maybe SafeArityType
    Nothing -> Int
    0
          Just SafeArityType
    at -> SafeArityType -> Int
    arityTypeArity SafeArityType
    at

      | Bool
    otherwise
      = CpeRhs -> Int
    exprArity CpeRhs
    arg -- this is cheap enough for -O0

    eta_would_wreck_join :: CoreExpr -> Bool
    -- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in
    -- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]
    eta_would_wreck_join :: CpeRhs -> Bool
    eta_would_wreck_join (Let CoreBind
    bs CpeRhs
    e)        = CoreBind -> Bool
    isJoinBind CoreBind
    bs Bool -> Bool -> Bool
    || CpeRhs -> Bool
    eta_would_wreck_join CpeRhs
    e
    eta_would_wreck_join (Lam InVar
    _ CpeRhs
    e)         = CpeRhs -> Bool
    eta_would_wreck_join CpeRhs
    e
    eta_would_wreck_join (Cast CpeRhs
    e Coercion
    _)        = CpeRhs -> Bool
    eta_would_wreck_join CpeRhs
    e
    eta_would_wreck_join (Tick CoreTickish
    _ CpeRhs
    e)        = CpeRhs -> Bool
    eta_would_wreck_join CpeRhs
    e
    eta_would_wreck_join (Case CpeRhs
    _ InVar
    _ Type
    _ [Alt InVar]
    alts) = (CpeRhs -> Bool) -> [CpeRhs] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any CpeRhs -> Bool
    eta_would_wreck_join ([Alt InVar] -> [CpeRhs]
    forall b. [Alt b] -> [Expr b]
    rhssOfAlts [Alt InVar]
    alts)
    eta_would_wreck_join CpeRhs
    _                 = Bool
    False

    maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs
    maybeSaturate :: InVar -> CpeRhs -> Int -> [CoreTickish] -> UniqSM CpeRhs
    maybeSaturate InVar
    fn CpeRhs
    expr Int
    n_args [CoreTickish]
    unsat_ticks
      | InVar -> Bool
    hasNoBinding InVar
    fn        -- There's no binding
        -- See Note [Eta expansion of hasNoBinding things in CorePrep]
      = CpeRhs -> UniqSM CpeRhs
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CpeRhs -> UniqSM CpeRhs) -> CpeRhs -> UniqSM CpeRhs
    forall a b. (a -> b) -> a -> b
    $ (CpeRhs -> CpeRhs) -> CpeRhs -> CpeRhs
    wrapLamBody (\CpeRhs
    body -> (CoreTickish -> CpeRhs -> CpeRhs)
    -> CpeRhs -> [CoreTickish] -> CpeRhs
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr CoreTickish -> CpeRhs -> CpeRhs
    mkTick CpeRhs
    body [CoreTickish]
    unsat_ticks) CpeRhs
    sat_expr

      | Int
    mark_arity Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0 -- A call-by-value function. See Note [CBV Function Ids]
      , Bool -> Bool
    not Bool
    applied_marks
      = Bool -> SDoc -> UniqSM CpeRhs -> UniqSM CpeRhs
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr
          ( Bool -> Bool
    not (InVar -> Bool
    isJoinId InVar
    fn)) -- See Note [Do not eta-expand join points]
          ( InVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr InVar
    fn SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "expr:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CpeRhs -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CpeRhs
    expr SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "n_args:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    n_args SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "marks:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Maybe [CbvMark] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (InVar -> Maybe [CbvMark]
    idCbvMarks_maybe InVar
    fn) SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "join_arity" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> JoinPointHood -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (InVar -> JoinPointHood
    idJoinPointHood InVar
    fn) SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
              String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "fn_arity" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    fn_arity
           ) (UniqSM CpeRhs -> UniqSM CpeRhs) -> UniqSM CpeRhs -> UniqSM CpeRhs
    forall a b. (a -> b) -> a -> b
    $
        -- pprTrace "maybeSat"
        --   ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$
        --       text "marks:" <+> ppr (idCbvMarks_maybe fn) $$
        --       text "join_arity" <+> ppr (isJoinId_maybe fn) $$
        --       text "fn_arity" <+> ppr fn_arity $$
        --       text "excess_arity" <+> ppr excess_arity $$
        --       text "mark_arity" <+> ppr mark_arity
        --    ) $
        CpeRhs -> UniqSM CpeRhs
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CpeRhs
    sat_expr

      | Bool
    otherwise
      = Bool -> UniqSM CpeRhs -> UniqSM CpeRhs
    forall a. HasCallStack => Bool -> a -> a
    assert ([CoreTickish] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [CoreTickish]
    unsat_ticks) (UniqSM CpeRhs -> UniqSM CpeRhs) -> UniqSM CpeRhs -> UniqSM CpeRhs
    forall a b. (a -> b) -> a -> b
    $
        CpeRhs -> UniqSM CpeRhs
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CpeRhs
    expr
      where
        mark_arity :: Int
    mark_arity    = InVar -> Int
    idCbvMarkArity InVar
    fn
        fn_arity :: Int
    fn_arity      = InVar -> Int
    idArity InVar
    fn
        excess_arity :: Int
    excess_arity  = (Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    fn_arity Int
    mark_arity) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    n_args
        sat_expr :: CpeRhs
    sat_expr      = Int -> CpeRhs -> CpeRhs
    cpeEtaExpand Int
    excess_arity CpeRhs
    expr
        applied_marks :: Bool
    applied_marks = Int
    n_args Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= ([CbvMark] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ([CbvMark] -> Int)
    -> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (CbvMark -> Bool) -> [CbvMark] -> [CbvMark]
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Bool -> Bool
    not (Bool -> Bool) -> (CbvMark -> Bool) -> CbvMark -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CbvMark -> Bool
    isMarkedCbv) ([CbvMark] -> [CbvMark])
    -> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                                   [CbvMark] -> [CbvMark]
    forall a. [a] -> [a]
    reverse ([CbvMark] -> [CbvMark])
    -> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Maybe [CbvMark] -> [CbvMark]
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "maybeSaturate" (Maybe [CbvMark] -> Int) -> Maybe [CbvMark] -> Int
    forall a b. (a -> b) -> a -> b
    $ (InVar -> Maybe [CbvMark]
    idCbvMarks_maybe InVar
    fn))
        -- For join points we never eta-expand (See Note [Do not eta-expand join points])
        -- so we assert all arguments that need to be passed cbv are visible so that the
        -- backend can evalaute them if required..

    {- Note [Eta expansion]
    ~~~~~~~~~~~~~~~~~~~~~~~
    Eta expand to match the arity claimed by the binder Remember,
    CorePrep must not change arity

    Eta expansion might not have happened already, because it is done by
    the simplifier only when there at least one lambda already.

    NB1:we could refrain when the RHS is trivial (which can happen
        for exported things).  This would reduce the amount of code
        generated (a little) and make things a little worse for
        code compiled without -O.  The case in point is data constructor
        wrappers.

    NB2: we have to be careful that the result of etaExpand doesn't
       invalidate any of the assumptions that CorePrep is attempting
       to establish.  One possible cause is eta expanding inside of
       an SCC note - we're now careful in etaExpand to make sure the
       SCC is pushed inside any new lambdas that are generated.

    Note [Eta expansion of hasNoBinding things in CorePrep]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    maybeSaturate deals with eta expanding to saturate things that can't deal
    with unsaturated applications (identified by 'hasNoBinding', currently
    foreign calls, unboxed tuple/sum constructors, and representation-polymorphic
    primitives such as 'coerce' and 'unsafeCoerce#').

    Historical Note: Note that eta expansion in CorePrep used to be very fragile
    due to the "prediction" of CAFfyness that we used to make during tidying.  We
    previously saturated primop applications here as well but due to this
    fragility (see #16846) we now deal with this another way, as described in
    Note [Primop wrappers] in GHC.Builtin.PrimOps.

    Note [Eta expansion and the CorePrep invariants]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    It turns out to be much much easier to do eta expansion
    *after* the main CorePrep stuff.  But that places constraints
    on the eta expander: given a CpeRhs, it must return a CpeRhs.

    For example here is what we do not want:
                    f = /\a -> g (h 3)      -- h has arity 2
    After ANFing we get
                    f = /\a -> let s = h 3 in g s
    and now we do NOT want eta expansion to give
                    f = /\a -> \ y -> (let s = h 3 in g s) y

    Instead GHC.Core.Opt.Arity.etaExpand gives
                    f = /\a -> \y -> let s = h 3 in g s y

    Note [Eta expansion of arguments in CorePrep]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to

      let t = g x
      in f t

    We really don't want that `t` to be a thunk! That just wastes runtime, updating
    a thunk with a PAP etc. The code generator could in principle allocate a PAP,
    but in fact it does not know how to do that -- it's easier just to eta-expand:

      let t = \y. g x y
      in f t

    To what arity should we eta-expand the argument? `cpeArg` uses two strategies,
    governed by the presence of `-fdo-clever-arg-eta-expansion` (implied by -O):

      1. Cheap, with -O0: just use `exprArity`.
      2. More clever but expensive, with -O1 -O2: use `exprEtaExpandArity`,
         same function the Simplifier uses to eta expand RHSs and lambda bodies.

    The only reason for using (1) rather than (2) is to keep compile times down.
    Using (2) in -O0 bumped up compiler allocations by 2-3% in tests T4801 and
    T5321*. However, Plan (2) catches cases that (1) misses.
    For example (#23083, assuming -fno-pedantic-bottoms):

      let t = case z of __DEFAULT -> g x
      in f t

    to

      let t = \y -> case z of __DEFAULT -> g x y
      in f t

    Note that there is a missed opportunity in eta expanding `t` earlier, in the
    Simplifier: It would allow us to inline `g`, potentially enabling further
    simplification. But then we could have inlined `g` into the PAP to begin with,
    and that is discussed in #23150; hence we needn't worry about that in CorePrep.

    There is a nasty Wrinkle:

    (EA1) When eta expanding an argument headed by a join point, we might get
          "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts
          it.  This crap means the output does not conform to the syntax in
          Note [CorePrep invariants], which then makes later passes crash (#25033).
          Consider

            f (join j x = rhs in ...(j 1)...(j 2)...)

          where the argument has arity 1. We might be tempted to eta expand, to

            f (\y -> (join j x = rhs in ...(j 1)...(j 2)...) y)

          Why hasn't the App to `y` been pushed into the join point? That's exactly
          the crap of Note [Eta expansion for join points], so we have to put up
          with it here.
          In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid
          `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App
          case of `coreToStgExpr`.

          Hence, in `eta_would_wreck_join`, we check for the cases where an
          intervening join point binding in the tail context of the argument would
          make eta-expansion break Note [CorePrep invariants], in which
          case we abstain from eta expansion.

          This scenario occurs rarely; hence it's OK to generate sub-optimal code.
          The alternative would be to fix Note [Eta expansion for join points], but
          that's quite challenging due to unfoldings of (recursive) join points.

          `eta_would_wreck_join` sees if there are any join points, like `j` above
          that would be messed up.   It must look inside lambdas (#25033); consider
                 f (\x. join j y = ... in ...(j 1)...(j 3)...)
          We can't eta expand that `\x` any more than we could if the join was at
          the top.  (And when there's a lambda, we don't have a thunk anyway.)

    (EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like
               let <binds> in rhs
          where <binds> is non-empty and can't be floated out of a lazy context (see
          `wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0
          forthwith.  Without this short-cut we will call exprEtaExpandArity on the
          `arg`, and <binds> might be enormous. exprEtaExpandArity be very expensive
          on this: it uses arityType, and may look at <binds>.

          On the other hand, if float_decision = FloatAll, there will be no
          let-bindings around 'arg'; they will have floated out.  So
          exprEtaExpandArity is cheap.

          This can make a huge difference on deeply nested expressions like
             f (f (f (f (f  ...))))
          #24471 is a good example, where Prep took 25% of compile time!
    -}

    cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
    cpeEtaExpand :: Int -> CpeRhs -> CpeRhs
    cpeEtaExpand Int
    arity CpeRhs
    expr
      | Int
    arity Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 = CpeRhs
    expr
      | Bool
    otherwise  = Int -> CpeRhs -> CpeRhs
    etaExpand Int
    arity CpeRhs
    expr

    {-
    ************************************************************************
    *                                                                      *
                    Floats
    *                                                                      *
    ************************************************************************

    Note [Pin demand info on floats]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We pin demand info on floated lets, so that we can see the one-shot thunks.

    Note [Speculative evaluation]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Since call-by-value is much cheaper than call-by-need, we case-bind arguments
    that are either

      1. Strictly evaluated anyway, according to the DmdSig of the callee, or
      2. ok-for-spec, according to 'exprOkForSpeculation'.
         This includes DFuns `$fEqList a`, for example.
         (Could identify more in the future; see reference to !1866 below.)

    While (1) is a no-brainer and always beneficial, (2) is a bit
    more subtle, as the careful haddock for 'exprOkForSpeculation'
    points out. Still, by case-binding the argument we don't need
    to allocate a thunk for it, whose closure must be retained as
    long as the callee might evaluate it. And if it is evaluated on
    most code paths anyway, we get to turn the unknown eval in the
    callee into a known call at the call site.

    Very Nasty Wrinkle

    We must be very careful not to speculate recursive calls!  Doing so
    might well change termination behavior.

    That comes up in practice for DFuns, which are considered ok-for-spec,
    because they always immediately return a constructor.
    See Note [NON-BOTTOM-DICTS invariant] in GHC.Core.

    But not so if you speculate the recursive call, as #20836 shows:

      class Foo m => Foo m where
        runFoo :: m a -> m a
      newtype Trans m a = Trans { runTrans :: m a }
      instance Monad m => Foo (Trans m) where
        runFoo = id

    (NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The
    example in #20836 is more compelling, but boils down to the same thing.)
    This program compiles to the following DFun for the `Trans` instance:

      Rec {
      $fFooTrans
        = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)
      end Rec }

    Note that the DFun immediately terminates and produces a dictionary, just
    like DFuns ought to, but it calls itself recursively to produce the `Foo m`
    dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so
    that we can speculate its calls, and hence use call-by-value, we get:

      $fFooTrans
        = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->
                          C:Foo sc (\ @a -> id)

    and that's an infinite loop!
    Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the
    *body* of the letrec, it's absolutely fine to use call-by-value on
    `foo ($fFooTrans d)`.

    Our solution is this: we track in cpe_rec_ids the set of enclosing
    recursively-bound Ids, the RHSs of which we are currently transforming and then
    in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',
    basically) we'll say that any binder in this set is not ok-for-spec.

    Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we
    prep up `rhs1`, we have to include not only `f1`, but all binders of the group
    `f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive
    DFuns.

    NB: If at some point we decide to have a termination analysis for general
    functions (#8655, !1866), we need to take similar precautions for (guarded)
    recursive functions:

      repeat x = x : repeat x

    Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`
    is a cheap call that we are willing to speculate, but *not* in repeat's RHS.
    Fortunately, pce_rec_ids already has all the information we need in that case.

    The problem is very similar to Note [Eta reduction in recursive RHSs].
    Here as well as there it is *unsound* to change the termination properties
    of the very function whose termination properties we are exploiting.

    It is also similar to Note [Do not strictify a DFun's parameter dictionaries],
    where marking recursive DFuns (of undecidable *instances*) strict in dictionary
    *parameters* leads to quite the same change in termination as above.

    Note [BindInfo and FloatInfo]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The `BindInfo` of a `Float` describes whether it will be case-bound or
    let-bound:

      * `LetBound`: A let binding `let x = rhs in ...`, can be Rec or NonRec.
      * `CaseBound`: A case binding `case rhs of x -> { __DEFAULT -> .. }`.
                     (So always NonRec.)
                     Some case-bound things (string literals, lifted bindings)
                     can float to top-level (but not all), hence it is similar
                     to, but not the same as `StrictContextFloatable :: FloatInfo`
                     described below.

    This info is used in `wrapBinds` to pick the corresponding binding form.

    We want to case-bind iff the binding is (non-recursive, and) either

      * ok-for-spec-eval (and perhaps lifted, see Note [Speculative evaluation]), or
      * unlifted, or
      * strictly used

    The `FloatInfo` of a `Float` describes how far it can float without
    (a) violating Core invariants and (b) changing semantics.

      * Any binding is at least `StrictContextFloatable`, meaning we may float it
        out of a strict context such as `f <>` where `f` is strict.

      * A binding is `LazyContextFloatable` if we may float it out of a lazy context
        such as `let x = <> in Just x`.
        Counterexample: A strict or unlifted binding that isn't ok-for-spec-eval
                        such as `case divInt# x y of r -> { __DEFAULT -> I# r }`.
                        Here, we may not foat out the strict `r = divInt# x y`.

      * A binding is `TopLvlFloatable` if it is `LazyContextFloatable` and also can
        be bound at the top level.
        Counterexample: A strict or unlifted binding (ok-for-spec-eval or not)
                        such as `case x +# y of r -> { __DEFAULT -> I# r }`.

    This meaning of "at least" is encoded in `floatsAtLeastAsFarAs`.
    Note that today, `LetBound` implies `TopLvlFloatable`, so we could make do with
    the the following enum (check `mkNonRecFloat` for whether this is up to date):

       LetBoundTopLvlFloatable          (lifted or boxed values)
      CaseBoundTopLvlFloatable          (strings, ok-for-spec-eval and lifted)
      CaseBoundLazyContextFloatable     (ok-for-spec-eval and unlifted)
      CaseBoundStrictContextFloatable   (not ok-for-spec-eval and unlifted)

    Although there is redundancy in the current encoding, SG thinks it is cleaner
    conceptually.

    See also Note [Floats and FloatDecision] for how we maintain whole groups of
    floats and how far they go.

    Note [Controlling Speculative Evaluation]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Most of the time, speculative evaluation has a positive effect on performance,
    but we have found a case where speculative evaluation of dictionary functions
    leads to a performance regression #25284.

    Therefore we have some flags to control it. See the optimization section in
    the User's Guide for the description of these flags and when to use them.

    Note [Floats and FloatDecision]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We have a special datatype `Floats` for modelling a telescope of `FloatingBind`
    and caching its "maximum" `FloatInfo`, according to `floatsAtLeastAsFarAs`
    (see Note [BindInfo and FloatInfo] for the ordering).
    There are several operations for creating and combining `Floats` that maintain
    scoping and the cached `FloatInfo`.

    When deciding whether we want to float out a `Floats` out of a binding context
    such as `let x = <> in e` (let), `f <>` (app), or `x = <>; ...` (top-level),
    we consult the cached `FloatInfo` of the `Floats`:

      * If we want to float to the top-level (`x = <>; ...`), we check whether
        we may float-at-least-as-far-as `TopLvlFloatable`, in which case we
        respond with `FloatAll :: FloatDecision`; otherwise we say `FloatNone`.
      * If we want to float locally (let or app), then the floating decision is
        described in Note [wantFloatLocal].

    `executeFloatDecision` is then used to act on the particular `FloatDecision`.
    -}

    -- See Note [BindInfo and FloatInfo]
    data BindInfo
      = CaseBound -- ^ A strict binding
      | LetBound  -- ^ A lazy or value binding
      deriving BindInfo -> BindInfo -> Bool
    (BindInfo -> BindInfo -> Bool)
    -> (BindInfo -> BindInfo -> Bool) -> Eq BindInfo
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: BindInfo -> BindInfo -> Bool
    == :: BindInfo -> BindInfo -> Bool
    $c/= :: BindInfo -> BindInfo -> Bool
    /= :: BindInfo -> BindInfo -> Bool
    Eq

    -- See Note [BindInfo and FloatInfo]
    data FloatInfo
      = TopLvlFloatable
      -- ^ Anything that can be bound at top-level, such as arbitrary lifted
      -- bindings or anything that responds True to `exprIsHNF`, such as literals or
      -- saturated DataCon apps where unlifted or strict args are values.

      | LazyContextFloatable
      -- ^ Anything that can be floated out of a lazy context.
      -- In addition to any 'TopLvlFloatable' things, this includes (unlifted)
      -- bindings that are ok-for-spec that we intend to case-bind.

      | StrictContextFloatable
      -- ^ Anything that can be floated out of a strict evaluation context.
      -- That is possible for all bindings; this is the Top element of 'FloatInfo'.

      deriving FloatInfo -> FloatInfo -> Bool
    (FloatInfo -> FloatInfo -> Bool)
    -> (FloatInfo -> FloatInfo -> Bool) -> Eq FloatInfo
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: FloatInfo -> FloatInfo -> Bool
    == :: FloatInfo -> FloatInfo -> Bool
    $c/= :: FloatInfo -> FloatInfo -> Bool
    /= :: FloatInfo -> FloatInfo -> Bool
    Eq

    instance Outputable BindInfo where
      ppr :: BindInfo -> SDoc
    ppr BindInfo
    CaseBound = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Case"
      ppr BindInfo
    LetBound  = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Let"

    instance Outputable FloatInfo where
      ppr :: FloatInfo -> SDoc
    ppr FloatInfo
    TopLvlFloatable = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "top-lvl"
      ppr FloatInfo
    LazyContextFloatable = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "lzy-ctx"
      ppr FloatInfo
    StrictContextFloatable = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "str-ctx"

    -- See Note [Floating in CorePrep]
    -- and Note [BindInfo and FloatInfo]
    data FloatingBind
      = Float !CoreBind !BindInfo !FloatInfo    -- Never a join-point binding
      | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr]
      | FloatTick CoreTickish

    -- See Note [Floats and FloatDecision]
    data Floats
      = Floats
      { Floats -> FloatInfo
    fs_info  :: !FloatInfo
      , Floats -> OrdList FloatingBind
    fs_binds :: !(OrdList FloatingBind)
      }

    instance Outputable FloatingBind where
      ppr :: FloatingBind -> SDoc
    ppr (Float CoreBind
    b BindInfo
    bi FloatInfo
    fi) = BindInfo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr BindInfo
    bi SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> FloatInfo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatInfo
    fi SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreBind
    b
      ppr (FloatTick CoreTickish
    t) = CoreTickish -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreTickish
    t
      ppr (UnsafeEqualityCase CpeRhs
    scrut InVar
    b AltCon
    k [InVar]
    bs) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "case" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CpeRhs -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CpeRhs
    scrut
                                    SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "of"SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> InVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr InVar
    b SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "@"
                                    SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> case [InVar]
    bs of
                                       [] -> AltCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr AltCon
    k
                                       [InVar]
    _  -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (AltCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr AltCon
    k SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [InVar] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [InVar]
    bs)

    instance Outputable Floats where
      ppr :: Floats -> SDoc
    ppr (Floats FloatInfo
    info OrdList FloatingBind
    binds) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Floats" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    brackets (FloatInfo -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatInfo
    info) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces (OrdList FloatingBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr OrdList FloatingBind
    binds)

    lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo
    lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo
    lubFloatInfo FloatInfo
    StrictContextFloatable FloatInfo
    _                      = FloatInfo
    StrictContextFloatable
    lubFloatInfo FloatInfo
    _                      FloatInfo
    StrictContextFloatable = FloatInfo
    StrictContextFloatable
    lubFloatInfo FloatInfo
    LazyContextFloatable   FloatInfo
    _                      = FloatInfo
    LazyContextFloatable
    lubFloatInfo FloatInfo
    _                      FloatInfo
    LazyContextFloatable   = FloatInfo
    LazyContextFloatable
    lubFloatInfo FloatInfo
    TopLvlFloatable        FloatInfo
    TopLvlFloatable        = FloatInfo
    TopLvlFloatable

    floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool
    -- See Note [Floats and FloatDecision]
    floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool
    floatsAtLeastAsFarAs FloatInfo
    l FloatInfo
    r = FloatInfo
    l FloatInfo -> FloatInfo -> FloatInfo
    `lubFloatInfo` FloatInfo
    r FloatInfo -> FloatInfo -> Bool
    forall a. Eq a => a -> a -> Bool
    == FloatInfo
    r

    emptyFloats :: Floats
    emptyFloats :: Floats
    emptyFloats = FloatInfo -> OrdList FloatingBind -> Floats
    Floats FloatInfo
    TopLvlFloatable OrdList FloatingBind
    forall a. OrdList a
    nilOL

    isEmptyFloats :: Floats -> Bool
    isEmptyFloats :: Floats -> Bool
    isEmptyFloats (Floats FloatInfo
    _ OrdList FloatingBind
    b) = OrdList FloatingBind -> Bool
    forall a. OrdList a -> Bool
    isNilOL OrdList FloatingBind
    b

    getFloats :: Floats -> OrdList FloatingBind
    getFloats :: Floats -> OrdList FloatingBind
    getFloats = Floats -> OrdList FloatingBind
    fs_binds

    unitFloat :: FloatingBind -> Floats
    unitFloat :: FloatingBind -> Floats
    unitFloat = Floats -> FloatingBind -> Floats
    snocFloat Floats
    emptyFloats

    floatInfo :: FloatingBind -> FloatInfo
    floatInfo :: FloatingBind -> FloatInfo
    floatInfo (Float CoreBind
    _ BindInfo
    _ FloatInfo
    info)     = FloatInfo
    info
    floatInfo UnsafeEqualityCase{} = FloatInfo
    LazyContextFloatable -- See Note [Floating in CorePrep]
    floatInfo FloatTick{}          = FloatInfo
    TopLvlFloatable      -- We filter these out in cpePair,
                                                          -- see Note [Floating Ticks in CorePrep]

    -- | Append a `FloatingBind` `b` to a `Floats` telescope `bs` that may reference any
    -- binding of the 'Floats'.
    snocFloat :: Floats -> FloatingBind -> Floats
    snocFloat :: Floats -> FloatingBind -> Floats
    snocFloat Floats
    floats FloatingBind
    fb =
      Floats { fs_info :: FloatInfo
    fs_info  = FloatInfo -> FloatInfo -> FloatInfo
    lubFloatInfo (Floats -> FloatInfo
    fs_info Floats
    floats) (FloatingBind -> FloatInfo
    floatInfo FloatingBind
    fb)
             , fs_binds :: OrdList FloatingBind
    fs_binds = Floats -> OrdList FloatingBind
    fs_binds Floats
    floats OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> a -> OrdList a
    `snocOL` FloatingBind
    fb }

    -- | Cons a `FloatingBind` `b` to a `Floats` telescope `bs` which scopes over
    -- `b`.
    consFloat :: FloatingBind -> Floats -> Floats
    consFloat :: FloatingBind -> Floats -> Floats
    consFloat FloatingBind
    fb Floats
    floats =
      Floats { fs_info :: FloatInfo
    fs_info  = FloatInfo -> FloatInfo -> FloatInfo
    lubFloatInfo (Floats -> FloatInfo
    fs_info Floats
    floats) (FloatingBind -> FloatInfo
    floatInfo FloatingBind
    fb)
             , fs_binds :: OrdList FloatingBind
    fs_binds = FloatingBind
    fb FloatingBind -> OrdList FloatingBind -> OrdList FloatingBind
    forall a. a -> OrdList a -> OrdList a
    `consOL`  Floats -> OrdList FloatingBind
    fs_binds Floats
    floats }

    -- | Append two telescopes, nesting the right inside the left.
    appFloats :: Floats -> Floats -> Floats
    appFloats :: Floats -> Floats -> Floats
    appFloats Floats
    outer Floats
    inner =
      Floats { fs_info :: FloatInfo
    fs_info  = FloatInfo -> FloatInfo -> FloatInfo
    lubFloatInfo (Floats -> FloatInfo
    fs_info Floats
    outer) (Floats -> FloatInfo
    fs_info Floats
    inner)
             , fs_binds :: OrdList FloatingBind
    fs_binds = Floats -> OrdList FloatingBind
    fs_binds Floats
    outer OrdList FloatingBind
    -> OrdList FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` Floats -> OrdList FloatingBind
    fs_binds Floats
    inner }

    -- | Zip up two `Floats`, none of which scope over the other
    zipFloats :: Floats -> Floats -> Floats
    -- We may certainly just nest one telescope in the other, so appFloats is a
    -- valid implementation strategy.
    zipFloats :: Floats -> Floats -> Floats
    zipFloats = Floats -> Floats -> Floats
    appFloats

    -- | `zipFloats` a bunch of independent telescopes.
    zipManyFloats :: [Floats] -> Floats
    zipManyFloats :: [Floats] -> Floats
    zipManyFloats = (Floats -> Floats -> Floats) -> Floats -> [Floats] -> Floats
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Floats -> Floats -> Floats
    zipFloats Floats
    emptyFloats

    mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
    mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> InVar -> CpeRhs -> FloatingBind
    mkNonRecFloat CorePrepEnv
    env Demand
    dmd Bool
    is_unlifted InVar
    bndr CpeRhs
    rhs
      = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)
        --                             <+> ppr is_lifted <+> ppr is_strict
        --                             <+> ppr ok_for_spec
        --                           $$ ppr rhs) $
        CoreBind -> BindInfo -> FloatInfo -> FloatingBind
    Float (InVar -> CpeRhs -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec InVar
    bndr' CpeRhs
    rhs) BindInfo
    bound FloatInfo
    info
      where
        bndr' :: InVar
    bndr' = InVar -> Demand -> InVar
    setIdDemandInfo InVar
    bndr Demand
    dmd -- See Note [Pin demand info on floats]
        (BindInfo
    bound,FloatInfo
    info)
          | Bool
    is_lifted, Bool
    is_hnf        = (BindInfo
    LetBound, FloatInfo
    TopLvlFloatable)
              -- is_lifted: We currently don't allow unlifted values at the
              --            top-level or inside letrecs
              --            (but SG thinks that in principle, we should)
          | InVar -> Bool
    is_data_con InVar
    bndr         = (BindInfo
    LetBound, FloatInfo
    TopLvlFloatable)
              -- We need this special case for unlifted DataCon workers/wrappers
              -- until #17521 is fixed
          | CpeRhs -> Bool
    exprIsTickedString CpeRhs
    rhs   = (BindInfo
    CaseBound, FloatInfo
    TopLvlFloatable)
              -- String literals are unboxed (so must be case-bound) and float to
              -- the top-level
          | Bool
    is_unlifted, Bool
    ok_for_spec = (BindInfo
    CaseBound, FloatInfo
    LazyContextFloatable)
          | Bool
    is_lifted,   Bool
    ok_for_spec = (BindInfo
    CaseBound, FloatInfo
    TopLvlFloatable)
              -- See Note [Speculative evaluation]
              -- Ok-for-spec-eval things will be case-bound, lifted or not.
              -- But when it's lifted we are ok with floating it to top-level
              -- (where it is actually bound lazily).
          | Bool
    is_unlifted Bool -> Bool -> Bool
    || Bool
    is_strict = (BindInfo
    CaseBound, FloatInfo
    StrictContextFloatable)
              -- These will never be floated out of a lazy RHS context
          | Bool
    otherwise                = Bool -> SDoc -> (BindInfo, FloatInfo) -> (BindInfo, FloatInfo)
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr Bool
    is_lifted (CpeRhs -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CpeRhs
    rhs) ((BindInfo, FloatInfo) -> (BindInfo, FloatInfo))
    -> (BindInfo, FloatInfo) -> (BindInfo, FloatInfo)
    forall a b. (a -> b) -> a -> b
    $
                                       (BindInfo
    LetBound, FloatInfo
    TopLvlFloatable)
              -- And these float freely but can't be speculated, hence LetBound

        is_lifted :: Bool
    is_lifted   = Bool -> Bool
    not Bool
    is_unlifted
        is_hnf :: Bool
    is_hnf      = CpeRhs -> Bool
    exprIsHNF CpeRhs
    rhs
        is_strict :: Bool
    is_strict   = Demand -> Bool
    isStrUsedDmd Demand
    dmd
        cfg :: CorePrepConfig
    cfg         = CorePrepEnv -> CorePrepConfig
    cpe_config CorePrepEnv
    env

        ok_for_spec :: Bool
    ok_for_spec = (InVar -> Bool) -> CpeRhs -> Bool
    exprOkForSpecEval InVar -> Bool
    call_ok_for_spec CpeRhs
    rhs
        -- See Note [Controlling Speculative Evaluation]
        call_ok_for_spec :: InVar -> Bool
    call_ok_for_spec InVar
    x
          | InVar -> Bool
    is_rec_call InVar
    x                           = Bool
    False
          | Bool -> Bool
    not (CorePrepConfig -> Bool
    cp_specEval CorePrepConfig
    cfg)                   = Bool
    False
          | Bool -> Bool
    not (CorePrepConfig -> Bool
    cp_specEvalDFun CorePrepConfig
    cfg) Bool -> Bool -> Bool
    && InVar -> Bool
    isDFunId InVar
    x = Bool
    False
          | Bool
    otherwise                               = Bool
    True
        is_rec_call :: InVar -> Bool
    is_rec_call = (InVar -> UnVarSet -> Bool
    `elemUnVarSet` CorePrepEnv -> UnVarSet
    cpe_rec_ids CorePrepEnv
    env)
        is_data_con :: InVar -> Bool
    is_data_con = Maybe DataCon -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe DataCon -> Bool)
    -> (InVar -> Maybe DataCon) -> InVar -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . InVar -> Maybe DataCon
    isDataConId_maybe

    -- | Wrap floats around an expression
    wrapBinds :: Floats -> CpeBody -> CpeBody
    wrapBinds :: Floats -> CpeRhs -> CpeRhs
    wrapBinds Floats
    floats CpeRhs
    body
      = -- pprTraceWith "wrapBinds" (\res -> ppr floats $$ ppr body $$ ppr res) $
        (FloatingBind -> CpeRhs -> CpeRhs)
    -> CpeRhs -> OrdList FloatingBind -> CpeRhs
    forall a b. (a -> b -> b) -> b -> OrdList a -> b
    foldrOL FloatingBind -> CpeRhs -> CpeRhs
    mk_bind CpeRhs
    body (Floats -> OrdList FloatingBind
    getFloats Floats
    floats)
      where
        -- See Note [BindInfo and FloatInfo] on whether we pick Case or Let here
        mk_bind :: FloatingBind -> CpeRhs -> CpeRhs
    mk_bind f :: FloatingBind
    f@(Float CoreBind
    bind BindInfo
    CaseBound FloatInfo
    _) CpeRhs
    body
          | NonRec InVar
    bndr CpeRhs
    rhs <- CoreBind
    bind
          = CpeRhs -> InVar -> CpeRhs -> CpeRhs
    mkDefaultCase CpeRhs
    rhs InVar
    bndr CpeRhs
    body
          | Bool
    otherwise
          = String -> SDoc -> CpeRhs
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "wrapBinds" (FloatingBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatingBind
    f)
        mk_bind (Float CoreBind
    bind BindInfo
    _ FloatInfo
    _) CpeRhs
    body
          = CoreBind -> CpeRhs -> CpeRhs
    forall b. Bind b -> Expr b -> Expr b
    Let CoreBind
    bind CpeRhs
    body
        mk_bind (UnsafeEqualityCase CpeRhs
    scrut InVar
    b AltCon
    con [InVar]
    bs) CpeRhs
    body
          = CpeRhs -> InVar -> AltCon -> [InVar] -> CpeRhs -> CpeRhs
    mkSingleAltCase CpeRhs
    scrut InVar
    b AltCon
    con [InVar]
    bs CpeRhs
    body
        mk_bind (FloatTick CoreTickish
    tickish) CpeRhs
    body
          = CoreTickish -> CpeRhs -> CpeRhs
    mkTick CoreTickish
    tickish CpeRhs
    body

    -- | Put floats at top-level
    deFloatTop :: Floats -> [CoreBind]
    -- Precondition: No Strict or LazyContextFloatable 'FloatInfo', no ticks!
    deFloatTop :: Floats -> CoreProgram
    deFloatTop Floats
    floats
      = (FloatingBind -> CoreProgram -> CoreProgram)
    -> CoreProgram -> OrdList FloatingBind -> CoreProgram
    forall a b. (a -> b -> b) -> b -> OrdList a -> b
    foldrOL FloatingBind -> CoreProgram -> CoreProgram
    get [] (Floats -> OrdList FloatingBind
    getFloats Floats
    floats)
      where
        get :: FloatingBind -> CoreProgram -> CoreProgram
    get (Float CoreBind
    b BindInfo
    _ FloatInfo
    TopLvlFloatable) CoreProgram
    bs
          = CoreBind -> CoreBind
    get_bind CoreBind
    b CoreBind -> CoreProgram -> CoreProgram
    forall a. a -> [a] -> [a]
    : CoreProgram
    bs
        get FloatingBind
    b CoreProgram
    _  = String -> SDoc -> CoreProgram
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "corePrepPgm" (FloatingBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatingBind
    b)

        -- See Note [Dead code in CorePrep]
        get_bind :: CoreBind -> CoreBind
    get_bind (NonRec InVar
    x CpeRhs
    e) = InVar -> CpeRhs -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec InVar
    x (CpeRhs -> CpeRhs
    occurAnalyseExpr CpeRhs
    e)
        get_bind (Rec [(InVar, CpeRhs)]
    xes)    = [(InVar, CpeRhs)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec [(InVar
    x, CpeRhs -> CpeRhs
    occurAnalyseExpr CpeRhs
    e) | (InVar
    x, CpeRhs
    e) <- [(InVar, CpeRhs)]
    xes]

    ---------------------------------------------------------------------------

    {- Note [wantFloatLocal]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
      let x = let y = e1 in e2
      in e
    Similarly for `(\x. e) (let y = e1 in e2)`.
    Do we want to float out `y` out of `x`?
    (This is discussed in detail in the paper
    "Let-floating: moving bindings to give faster programs".)

    `wantFloatLocal` is concerned with answering this question.
    It considers the Demand on `x`, whether or not `e2` is unlifted and the
    `FloatInfo` of the `y` binding (e.g., it might itself be unlifted, a value,
    strict, or ok-for-spec).

    We float out if ...
      1. ... the binding context is strict anyway, so either `x` is used strictly
         or has unlifted type.
         Doing so is trivially sound and won`t increase allocations, so we
         return `FloatAll`.
         This might happen while ANF-ising `f (g (h 13))` where `f`,`g` are strict:
           f (g (h 13))
           ==> { ANF }
           case (case h 13 of r -> g r) of r2 -> f r2
           ==> { Float }
           case h 13 of r -> case g r of r2 -> f r2
         The latter is easier to read and grows less stack.
      2. ... `e2` becomes a value in doing so, in which case we won't need to
         allocate a thunk for `x`/the arg that closes over the FVs of `e1`.
         In general, this is only sound if `y=e1` is `LazyContextFloatable`.
         (See Note [BindInfo and FloatInfo].)
         Nothing is won if `x` doesn't become a value
         (i.e., `let x = let sat = f 14 in g sat in e`),
         so we return `FloatNone` if there is any float that is
         `StrictContextFloatable`, and return `FloatAll` otherwise.

    To elaborate on (2), consider the case when the floated binding is
    `e1 = divInt# a b`, e.g., not `LazyContextFloatable`:
      let x = I# (a `divInt#` b)
      in e
    this ANFises to
      let x = case a `divInt#` b of r { __DEFAULT -> I# r }
      in e
    If `x` is used lazily, we may not float `r` further out.
    A float binding `x +# y` is OK, though, and so every ok-for-spec-eval
    binding is `LazyContextFloatable`.

    Wrinkles:

     (W1) When the outer binding is a letrec, i.e.,
            letrec x = case a +# b of r { __DEFAULT -> f y r }
                   y = [x]
            in e
          we don't want to float `LazyContextFloatable` bindings such as `r` either
          and require `TopLvlFloatable` instead.
          The reason is that we don't track FV of FloatBindings, so we would need
          to park them in the letrec,
            letrec r = a +# b -- NB: r`s RHS might scope over x and y
                   x = f y r
                   y = [x]
            in e
          and now we have violated Note [Core letrec invariant].
          So we preempt this case in `wantFloatLocal`, responding `FloatNone` unless
          all floats are `TopLvlFloatable`.
    -}

    data FloatDecision
      = FloatNone
      | FloatAll

    executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
    executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
    executeFloatDecision FloatDecision
    dec Floats
    floats CpeRhs
    rhs
      = case FloatDecision
    dec of
          FloatDecision
    FloatAll                 -> (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats, CpeRhs
    rhs)
          FloatDecision
    FloatNone
            | Floats -> Bool
    isEmptyFloats Floats
    floats -> (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, CpeRhs
    rhs)
            | Bool
    otherwise            -> do { (floats', body) <- CpeRhs -> UniqSM (Floats, CpeRhs)
    rhsToBody CpeRhs
    rhs
                                         ; return (emptyFloats, wrapBinds floats $
                                                                wrapBinds floats' body) }
                -- FloatNone case: `rhs` might have lambdas, and we can't
                -- put them inside a wrapBinds, which expects a `CpeBody`.

    wantFloatTop :: Floats -> FloatDecision
    wantFloatTop :: Floats -> FloatDecision
    wantFloatTop Floats
    fs
      | Floats -> FloatInfo
    fs_info Floats
    fs FloatInfo -> FloatInfo -> Bool
    `floatsAtLeastAsFarAs` FloatInfo
    TopLvlFloatable = FloatDecision
    FloatAll
      | Bool
    otherwise                                         = FloatDecision
    FloatNone

    wantFloatLocal :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision
    -- See Note [wantFloatLocal]
    wantFloatLocal :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision
    wantFloatLocal RecFlag
    is_rec Demand
    rhs_dmd Bool
    rhs_is_unlifted Floats
    floats CpeRhs
    rhs
      |  Floats -> Bool
    isEmptyFloats Floats
    floats -- Well yeah...
      Bool -> Bool -> Bool
    || Demand -> Bool
    isStrUsedDmd Demand
    rhs_dmd -- Case (1) of Note [wantFloatLocal]
      Bool -> Bool -> Bool
    || Bool
    rhs_is_unlifted      -- dito
      Bool -> Bool -> Bool
    || (Floats -> FloatInfo
    fs_info Floats
    floats FloatInfo -> FloatInfo -> Bool
    `floatsAtLeastAsFarAs` FloatInfo
    max_float_info Bool -> Bool -> Bool
    && CpeRhs -> Bool
    exprIsHNF CpeRhs
    rhs)
                              -- Case (2) of Note [wantFloatLocal]
      = FloatDecision
    FloatAll

      | Bool
    otherwise
      = FloatDecision
    FloatNone
      where
        max_float_info :: FloatInfo
    max_float_info | RecFlag -> Bool
    isRec RecFlag
    is_rec = FloatInfo
    TopLvlFloatable
                       | Bool
    otherwise    = FloatInfo
    LazyContextFloatable
                        -- See Note [wantFloatLocal], Wrinkle (W1)
                        -- for 'is_rec'

    {-
    ************************************************************************
    *                                                                      *
                    Cloning
    *                                                                      *
    ************************************************************************
    -}

    -- ---------------------------------------------------------------------------
    --                      The environment
    -- ---------------------------------------------------------------------------

    {- Note [Inlining in CorePrep]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    There is a subtle but important invariant that must be upheld in the output
    of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core
    is impermissible:

         let x :: ()
             x = y

    (where y is a reference to a GLOBAL variable).  Thunks like this are silly:
    they can always be profitably replaced by inlining x with y. Consequently,
    the code generator/runtime does not bother implementing this properly
    (specifically, there is no implementation of stg_ap_0_upd_info, which is the
    stack frame that would be used to update this thunk.  The "0" means it has
    zero free variables.)

    In general, the inliner is good at eliminating these let-bindings.  However,
    there is one case where these trivial updatable thunks can arise: when
    we are optimizing away 'lazy' (see Note [lazyId magic], and also
    'cpeRhsE'.)  Then, we could have started with:

         let x :: ()
             x = lazy @ () y

    which is a perfectly fine, non-trivial thunk, but then CorePrep will
    drop 'lazy', giving us 'x = y' which is trivial and impermissible.
    The solution is CorePrep to have a miniature inlining pass which deals
    with cases like this.  We can then drop the let-binding altogether.

    Why does the removal of 'lazy' have to occur in CorePrep?
    The gory details are in Note [lazyId magic] in GHC.Types.Id.Make, but the
    main reason is that lazy must appear in unfoldings (optimizer
    output) and it must prevent call-by-value for catch# (which
    is implemented by CorePrep.)

    An alternate strategy for solving this problem is to have the
    inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
    We decided not to adopt this solution to keep the definition
    of 'exprIsTrivial' simple.

    There is ONE caveat however: for top-level bindings we have
    to preserve the binding so that we float the (hacky) non-recursive
    binding for data constructors; see Note [Data constructor workers].

    Note [CorePrep inlines trivial CoreExpr not Id]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    TODO
    Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
    IdEnv Id?  Naively, we might conjecture that trivial updatable thunks
    as per Note [Inlining in CorePrep] always have the form
    'lazy @ SomeType gbl_id'.  But this is not true: the following is
    perfectly reasonable Core:

         let x :: ()
             x = lazy @ (forall a. a) y @ Bool

    When we inline 'x' after eliminating 'lazy', we need to replace
    occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like
    this can easily arise with higher-rank types; thus, cpe_env must
    map to CoreExprs, not Ids.

    -}

    data CorePrepConfig = CorePrepConfig
      { CorePrepConfig -> Bool
    cp_catchNonexhaustiveCases :: !Bool
      -- ^ Whether to generate a default alternative with ``error`` in these
      -- cases. This is helpful when debugging demand analysis or type
      -- checker bugs which can sometimes manifest as segmentation faults.

      , CorePrepConfig -> Platform
    cp_platform                :: Platform

      , CorePrepConfig -> Maybe ArityOpts
    cp_arityOpts               :: !(Maybe ArityOpts)
      -- ^ Configuration for arity analysis ('exprEtaExpandArity').
      -- See Note [Eta expansion of arguments in CorePrep]
      -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead
      , CorePrepConfig -> Bool
    cp_specEval                :: !Bool
      -- ^ Whether to perform speculative evaluation
      -- See Note [Controlling Speculative Evaluation]
      , CorePrepConfig -> Bool
    cp_specEvalDFun            :: !Bool
      -- ^ Whether to perform speculative evaluation on DFuns
      }

    data CorePrepEnv
      = CPE { CorePrepEnv -> CorePrepConfig
    cpe_config          :: !CorePrepConfig
            -- ^ This flag is intended to aid in debugging strictness
            -- analysis bugs. These are particularly nasty to chase down as
            -- they may manifest as segmentation faults. When this flag is
            -- enabled we instead produce an 'error' expression to catch
            -- the case where a function we think should bottom
            -- unexpectedly returns.

            , CorePrepEnv -> Subst
    cpe_subst :: Subst
            -- ^ The IdEnv part of the substitution is used for three operations:
            --
            --      1. To support cloning of local Ids so that they are
            --      all unique (see Note [Cloning in CorePrep])
            --
            --      2. To support beta-reduction of runRW, see
            --      Note [runRW magic] and Note [runRW arg].
            --
            --      3. To let us inline trivial RHSs of non top-level let-bindings,
            --      see Note [lazyId magic], Note [Inlining in CorePrep]
            --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
            --
            -- The TyCoVar part of the substitution is used only for
            --     Note [Cloning CoVars and TyVars]

            , CorePrepEnv -> UnVarSet
    cpe_rec_ids         :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
        }

    mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
    mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
    mkInitialCorePrepEnv CorePrepConfig
    cfg = CPE
          { cpe_config :: CorePrepConfig
    cpe_config        = CorePrepConfig
    cfg
          , cpe_subst :: Subst
    cpe_subst         = Subst
    emptySubst
          , cpe_rec_ids :: UnVarSet
    cpe_rec_ids       = UnVarSet
    emptyUnVarSet
          }

    extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
    extendCorePrepEnv :: CorePrepEnv -> InVar -> InVar -> CorePrepEnv
    extendCorePrepEnv cpe :: CorePrepEnv
    cpe@(CPE { cpe_subst :: CorePrepEnv -> Subst
    cpe_subst = Subst
    subst }) InVar
    id InVar
    id'
        = CorePrepEnv
    cpe { cpe_subst = subst2 }
        where
          subst1 :: Subst
    subst1 = Subst -> InVar -> Subst
    extendSubstInScope Subst
    subst InVar
    id'
          subst2 :: Subst
    subst2 = Subst -> InVar -> CpeRhs -> Subst
    extendIdSubst Subst
    subst1 InVar
    id (InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    id')

    extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
    extendCorePrepEnvList :: CorePrepEnv -> [(InVar, InVar)] -> CorePrepEnv
    extendCorePrepEnvList cpe :: CorePrepEnv
    cpe@(CPE { cpe_subst :: CorePrepEnv -> Subst
    cpe_subst = Subst
    subst }) [(InVar, InVar)]
    prs
        = CorePrepEnv
    cpe { cpe_subst = subst2 }
        where
          subst1 :: Subst
    subst1 = Subst -> [InVar] -> Subst
    extendSubstInScopeList Subst
    subst (((InVar, InVar) -> InVar) -> [(InVar, InVar)] -> [InVar]
    forall a b. (a -> b) -> [a] -> [b]
    map (InVar, InVar) -> InVar
    forall a b. (a, b) -> b
    snd [(InVar, InVar)]
    prs)
          subst2 :: Subst
    subst2 = Subst -> [(InVar, CpeRhs)] -> Subst
    extendIdSubstList Subst
    subst1 [(InVar
    id, InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    id') | (InVar
    id,InVar
    id') <- [(InVar, InVar)]
    prs]

    extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
    extendCorePrepEnvExpr :: CorePrepEnv -> InVar -> CpeRhs -> CorePrepEnv
    extendCorePrepEnvExpr CorePrepEnv
    cpe InVar
    id CpeRhs
    expr
        = CorePrepEnv
    cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr }

    lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
    lookupCorePrepEnv :: CorePrepEnv -> InVar -> CpeRhs
    lookupCorePrepEnv CorePrepEnv
    cpe InVar
    id
      = case HasDebugCallStack => Subst -> InVar -> Maybe CpeRhs
    Subst -> InVar -> Maybe CpeRhs
    lookupIdSubst_maybe (CorePrepEnv -> Subst
    cpe_subst CorePrepEnv
    cpe) InVar
    id of
           Just CpeRhs
    e -> CpeRhs
    e
           Maybe CpeRhs
    Nothing -> InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    id
        -- Do not use GHC.Core.Subs.lookupIdSubst because that is a no-op on GblIds;
        -- and Tidy has made top-level externally-visible Ids into GblIds

    enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv
    enterRecGroupRHSs :: CorePrepEnv -> [InVar] -> CorePrepEnv
    enterRecGroupRHSs CorePrepEnv
    env [InVar]
    grp
      = CorePrepEnv
    env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }

    cpSubstTy :: CorePrepEnv -> Type -> Type
    cpSubstTy :: CorePrepEnv -> Type -> Type
    cpSubstTy (CPE { cpe_subst :: CorePrepEnv -> Subst
    cpe_subst = Subst
    subst }) Type
    ty = HasDebugCallStack => Subst -> Type -> Type
    Subst -> Type -> Type
    substTy Subst
    subst Type
    ty
              -- substTy has a short-cut if the TCvSubst is empty

    cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
    cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
    cpSubstCo (CPE { cpe_subst :: CorePrepEnv -> Subst
    cpe_subst = Subst
    subst }) Coercion
    co = HasDebugCallStack => Subst -> Coercion -> Coercion
    Subst -> Coercion -> Coercion
    substCo Subst
    subst Coercion
    co
              -- substCo has a short-cut if the TCvSubst is empty

    ------------------------------------------------------------------------------
    -- Cloning binders
    -- ---------------------------------------------------------------------------

    cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
    cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
    cpCloneBndrs CorePrepEnv
    env [InVar]
    bs = (CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar))
    -> CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
    forall (m :: * -> *) (t :: * -> *) acc x y.
    (Monad m, Traversable t) =>
    (acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
    mapAccumLM CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
    cpCloneBndr CorePrepEnv
    env [InVar]
    bs

    cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
    -- Clone the CoVar
    -- See Note [Cloning CoVars and TyVars]
    cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
    cpCloneCoVarBndr env :: CorePrepEnv
    env@(CPE { cpe_subst :: CorePrepEnv -> Subst
    cpe_subst = Subst
    subst }) InVar
    covar
      = Bool
    -> SDoc
    -> UniqSM (CorePrepEnv, InVar)
    -> UniqSM (CorePrepEnv, InVar)
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (InVar -> Bool
    isCoVar InVar
    covar) (InVar -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr InVar
    covar) (UniqSM (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar))
    -> UniqSM (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
    forall a b. (a -> b) -> a -> b
    $
        do { uniq <- UniqSM Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
           ; let covar1 = InVar -> Unique -> InVar
    setVarUnique InVar
    covar Unique
    uniq
                 covar2 = (Type -> Type) -> InVar -> InVar
    updateVarType (HasDebugCallStack => Subst -> Type -> Type
    Subst -> Type -> Type
    substTy Subst
    subst) InVar
    covar1
                 subst1 = Subst -> InVar -> InVar -> Subst
    extendTCvSubstWithClone Subst
    subst InVar
    covar InVar
    covar2
           ; return (env { cpe_subst = subst1 }, covar2) }

    cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
    -- See Note [Cloning in CorePrep]
    cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
    cpCloneBndr env :: CorePrepEnv
    env@(CPE { cpe_subst :: CorePrepEnv -> Subst
    cpe_subst = Subst
    subst }) InVar
    bndr
      | InVar -> Bool
    isTyCoVar InVar
    bndr  -- See Note [Cloning CoVars and TyVars]
      = if Subst -> Bool
    isEmptyTCvSubst Subst
    subst    -- The common case
        then (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv
    env { cpe_subst = extendSubstInScope subst bndr }, InVar
    bndr)
        else -- No need to clone the Unique; but we must apply the substitution
             let bndr1 :: InVar
    bndr1  = (Type -> Type) -> InVar -> InVar
    updateVarType (HasDebugCallStack => Subst -> Type -> Type
    Subst -> Type -> Type
    substTy Subst
    subst) InVar
    bndr
                 subst1 :: Subst
    subst1 = Subst -> InVar -> InVar -> Subst
    extendTCvSubstWithClone Subst
    subst InVar
    bndr InVar
    bndr1
             in (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv
    env { cpe_subst = subst1 }, InVar
    bndr1)

      | Bool
    otherwise  -- A non-CoVar Id
      = do { bndr1 <- InVar -> UniqSM InVar
    forall {m :: * -> *}. MonadUnique m => InVar -> m InVar
    clone_it InVar
    bndr
           ; let bndr2 = (Type -> Type) -> InVar -> InVar
    updateIdTypeAndMult (HasDebugCallStack => Subst -> Type -> Type
    Subst -> Type -> Type
    substTy Subst
    subst) InVar
    bndr1

           -- Drop (now-useless) rules/unfoldings
           -- See Note [Drop unfoldings and rules]
           -- and Note [Preserve evaluatedness] in GHC.Core.Tidy
           -- And force it.. otherwise the old unfolding is just retained.
           -- See #22071
           ; let !unfolding' = Unfolding -> Unfolding
    trimUnfolding (InVar -> Unfolding
    realIdUnfolding InVar
    bndr)
                              -- Simplifier will set the Id's unfolding

                 bndr3 = InVar
    bndr2 InVar -> Unfolding -> InVar
    `setIdUnfolding`      Unfolding
    unfolding'
                               InVar -> RuleInfo -> InVar
    `setIdSpecialisation` RuleInfo
    emptyRuleInfo

           ; return (extendCorePrepEnv env bndr bndr3, bndr3) }
      where
        clone_it :: InVar -> m InVar
    clone_it InVar
    bndr
          | InVar -> Bool
    isLocalId InVar
    bndr
          = do { uniq <- m Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
               ; return (setVarUnique bndr uniq) }

          | Bool
    otherwise   -- Top level things, which we don't want
                        -- to clone, have become GlobalIds by now
          = InVar -> m InVar
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return InVar
    bndr

    {- Note [Drop unfoldings and rules]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We want to drop the unfolding/rules on every Id:

      - We are now past interface-file generation, and in the
        codegen pipeline, so we really don't need full unfoldings/rules

      - The unfolding/rule may be keeping stuff alive that we'd like
        to discard.  See  Note [Dead code in CorePrep]

      - Getting rid of unnecessary unfoldings reduces heap usage

      - We are changing uniques, so if we didn't discard unfoldings/rules
        we'd have to substitute in them

    HOWEVER, we want to preserve evaluated-ness;
    see Note [Preserve evaluatedness] in GHC.Core.Tidy.
    -}

    ------------------------------------------------------------------------------
    -- Cloning ccall Ids; each must have a unique name,
    -- to give the code generator a handle to hang it on
    -- ---------------------------------------------------------------------------

    fiddleCCall :: Id -> UniqSM Id
    fiddleCCall :: InVar -> UniqSM InVar
    fiddleCCall InVar
    id
      | InVar -> Bool
    isFCallId InVar
    id = (InVar
    id InVar -> Unique -> InVar
    `setVarUnique`) (Unique -> InVar) -> UniqSM Unique -> UniqSM InVar
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UniqSM Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
      | Bool
    otherwise    = InVar -> UniqSM InVar
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return InVar
    id

    ------------------------------------------------------------------------------
    -- Generating new binders
    -- ---------------------------------------------------------------------------

    newVar :: Type -> UniqSM Id
    newVar :: Type -> UniqSM InVar
    newVar Type
    ty
     = Type -> ()
    seqType Type
    ty () -> UniqSM InVar -> UniqSM InVar
    forall a b. a -> b -> b
    `seq` FastString -> Type -> Type -> UniqSM InVar
    forall (m :: * -> *).
    MonadUnique m =>
    FastString -> Type -> Type -> m InVar
    mkSysLocalOrCoVarM (String -> FastString
    fsLit String
    "sat") Type
    ManyTy Type
    ty

    ------------------------------------------------------------------------------
    -- Floating ticks
    -- ---------------------------------------------------------------------------
    --
    -- Note [Floating Ticks in CorePrep]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- It might seem counter-intuitive to float ticks by default, given
    -- that we don't actually want to move them if we can help it. On the
    -- other hand, nothing gets very far in CorePrep anyway, and we want
    -- to preserve the order of let bindings and tick annotations in
    -- relation to each other. For example, if we just wrapped let floats
    -- when they pass through ticks, we might end up performing the
    -- following transformation:
    --
    --   src<...> let foo = bar in baz
    --   ==>  let foo = src<...> bar in src<...> baz
    --
    -- Because the let-binding would float through the tick, and then
    -- immediately materialize, achieving nothing but decreasing tick
    -- accuracy. The only special case is the following scenario:
    --
    --   let foo = src<...> (let a = b in bar) in baz
    --   ==>  let foo = src<...> bar; a = src<...> b in baz
    --
    -- Here we would not want the source tick to end up covering "baz" and
    -- therefore refrain from pushing ticks outside. Instead, we copy them
    -- into the floating binds (here "a") in cpePair. Note that where "b"
    -- or "bar" are (value) lambdas we have to push the annotations
    -- further inside in order to uphold our rules.
    --
    -- All of this is implemented below in @wrapTicks@.

    -- | Like wrapFloats, but only wraps tick floats
    wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
    wrapTicks :: Floats -> CpeRhs -> (Floats, CpeRhs)
    wrapTicks Floats
    floats CpeRhs
    expr
      | (Floats
    floats1, OrdList CoreTickish
    ticks1) <- ((OrdList FloatingBind, OrdList CoreTickish)
     -> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish))
    -> Floats -> (Floats, OrdList CoreTickish)
    forall {a}.
    ((OrdList FloatingBind, OrdList a)
     -> FloatingBind -> (OrdList FloatingBind, OrdList a))
    -> Floats -> (Floats, OrdList a)
    fold_fun (OrdList FloatingBind, OrdList CoreTickish)
    -> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish)
    go Floats
    floats
      = (Floats
    floats1, (CoreTickish -> CpeRhs -> CpeRhs)
    -> CpeRhs -> OrdList CoreTickish -> CpeRhs
    forall a b. (a -> b -> b) -> b -> OrdList a -> b
    foldrOL CoreTickish -> CpeRhs -> CpeRhs
    mkTick CpeRhs
    expr OrdList CoreTickish
    ticks1)
      where fold_fun :: ((OrdList FloatingBind, OrdList a)
     -> FloatingBind -> (OrdList FloatingBind, OrdList a))
    -> Floats -> (Floats, OrdList a)
    fold_fun (OrdList FloatingBind, OrdList a)
    -> FloatingBind -> (OrdList FloatingBind, OrdList a)
    f Floats
    floats =
               let (OrdList FloatingBind
    binds, OrdList a
    ticks) = ((OrdList FloatingBind, OrdList a)
     -> FloatingBind -> (OrdList FloatingBind, OrdList a))
    -> (OrdList FloatingBind, OrdList a)
    -> OrdList FloatingBind
    -> (OrdList FloatingBind, OrdList a)
    forall b a. (b -> a -> b) -> b -> OrdList a -> b
    foldlOL (OrdList FloatingBind, OrdList a)
    -> FloatingBind -> (OrdList FloatingBind, OrdList a)
    f (OrdList FloatingBind
    forall a. OrdList a
    nilOL,OrdList a
    forall a. OrdList a
    nilOL) (Floats -> OrdList FloatingBind
    fs_binds Floats
    floats)
               in (Floats
    floats { fs_binds = binds }, OrdList a
    ticks)
            -- Deeply nested constructors will produce long lists of
            -- redundant source note floats here. We need to eliminate
            -- those early, as relying on mkTick to spot it after the fact
            -- can yield O(n^3) complexity [#11095]
            go :: (OrdList FloatingBind, OrdList CoreTickish)
    -> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish)
    go (OrdList FloatingBind
    flt_binds, OrdList CoreTickish
    ticks) (FloatTick CoreTickish
    t)
              = Bool
    -> (OrdList FloatingBind, OrdList CoreTickish)
    -> (OrdList FloatingBind, OrdList CoreTickish)
    forall a. HasCallStack => Bool -> a -> a
    assert (CoreTickish -> TickishPlacement
    forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
    tickishPlace CoreTickish
    t TickishPlacement -> TickishPlacement -> Bool
    forall a. Eq a => a -> a -> Bool
    == TickishPlacement
    PlaceNonLam)
                (OrdList FloatingBind
    flt_binds, if (CoreTickish -> Bool) -> OrdList CoreTickish -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any ((CoreTickish -> CoreTickish -> Bool)
    -> CoreTickish -> CoreTickish -> Bool
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip CoreTickish -> CoreTickish -> Bool
    forall (pass :: TickishPass).
    Eq (GenTickish pass) =>
    GenTickish pass -> GenTickish pass -> Bool
    tickishContains CoreTickish
    t) OrdList CoreTickish
    ticks
                            then OrdList CoreTickish
    ticks else OrdList CoreTickish
    ticks OrdList CoreTickish -> CoreTickish -> OrdList CoreTickish
    forall a. OrdList a -> a -> OrdList a
    `snocOL` CoreTickish
    t)
            go (OrdList FloatingBind
    flt_binds, OrdList CoreTickish
    ticks) f :: FloatingBind
    f@UnsafeEqualityCase{}
              -- unsafe equality case will be erased; don't wrap anything!
              = (OrdList FloatingBind
    flt_binds OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> a -> OrdList a
    `snocOL` FloatingBind
    f, OrdList CoreTickish
    ticks)
            go (OrdList FloatingBind
    flt_binds, OrdList CoreTickish
    ticks) f :: FloatingBind
    f@Float{}
              = (OrdList FloatingBind
    flt_binds OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> a -> OrdList a
    `snocOL` (CoreTickish -> FloatingBind -> FloatingBind)
    -> FloatingBind -> OrdList CoreTickish -> FloatingBind
    forall a b. (a -> b -> b) -> b -> OrdList a -> b
    foldrOL CoreTickish -> FloatingBind -> FloatingBind
    wrap FloatingBind
    f OrdList CoreTickish
    ticks, OrdList CoreTickish
    ticks)

            wrap :: CoreTickish -> FloatingBind -> FloatingBind
    wrap CoreTickish
    t (Float CoreBind
    bind BindInfo
    bound FloatInfo
    info) = CoreBind -> BindInfo -> FloatInfo -> FloatingBind
    Float (CoreTickish -> CoreBind -> CoreBind
    wrapBind CoreTickish
    t CoreBind
    bind) BindInfo
    bound FloatInfo
    info
            wrap CoreTickish
    _ FloatingBind
    f                 = String -> SDoc -> FloatingBind
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "Unexpected FloatingBind" (FloatingBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatingBind
    f)
            wrapBind :: CoreTickish -> CoreBind -> CoreBind
    wrapBind CoreTickish
    t (NonRec InVar
    binder CpeRhs
    rhs) = InVar -> CpeRhs -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec InVar
    binder (CoreTickish -> CpeRhs -> CpeRhs
    mkTick CoreTickish
    t CpeRhs
    rhs)
            wrapBind CoreTickish
    t (Rec [(InVar, CpeRhs)]
    pairs)         = [(InVar, CpeRhs)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec ((CpeRhs -> CpeRhs) -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
    forall (f :: * -> *) b c a.
    Functor f =>
    (b -> c) -> f (a, b) -> f (a, c)
    mapSnd (CoreTickish -> CpeRhs -> CpeRhs
    mkTick CoreTickish
    t) [(InVar, CpeRhs)]
    pairs)

    ------------------------------------------------------------------------------
    -- Numeric literals
    -- ---------------------------------------------------------------------------

    -- | Converts Bignum literals into their final CoreExpr
    cpeBigNatLit
       :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
    cpeBigNatLit :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
    cpeBigNatLit CorePrepEnv
    env Integer
    i = Bool -> UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a. HasCallStack => Bool -> a -> a
    assert (Integer
    i Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Integer
    0) (UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs))
    -> UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
    forall a b. (a -> b) -> a -> b
    $ do
      let
        platform :: Platform
    platform = CorePrepConfig -> Platform
    cp_platform (CorePrepEnv -> CorePrepConfig
    cpe_config CorePrepEnv
    env)

        -- Per the documentation in GHC.Num.BigNat, a BigNat# is:
        --   "Represented as an array of limbs (Word#) stored in
        --   little-endian order (Word# themselves use machine order)."
        --
        --   "Invariant (canonical representation): higher Word# is non-zero."
        -- So we need to break up the integer into target-word-sized chunks,
        -- and encode each of them using the target's byte-order.
        encodeBigNat
          :: forall a. Num a => FixedPrim a -> BS.ByteString
        encodeBigNat :: forall a. Num a => FixedPrim a -> ByteString
    encodeBigNat FixedPrim a
    encodeWord
          = LazyByteString -> ByteString
    BS.toStrict (Builder -> LazyByteString
    BB.toLazyByteString (FixedPrim a
    -> (Integer -> Maybe (a, Integer)) -> Integer -> Builder
    forall b a. FixedPrim b -> (a -> Maybe (b, a)) -> a -> Builder
    primUnfoldrFixed FixedPrim a
    encodeWord Integer -> Maybe (a, Integer)
    f Integer
    i))
          -- (quadratic complexity due to repeated shifts... ok for now)
          where
            f :: Integer -> Maybe (a, Integer)
    f Integer
    0 = Maybe (a, Integer)
    forall a. Maybe a
    Nothing
            f Integer
    x = let low :: a
    low  = Integer -> a
    forall a. Num a => Integer -> a
    fromInteger Integer
    x :: a
                      high :: Integer
    high = Integer
    x Integer -> Int -> Integer
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    bits
                  in (a, Integer) -> Maybe (a, Integer)
    forall a. a -> Maybe a
    Just (a
    low, Integer
    high)
            bits :: Int
    bits = Platform -> Int
    platformWordSizeInBits Platform
    platform

        words :: BS.ByteString
        words :: ByteString
    words = case (Platform -> PlatformWordSize
    platformWordSize Platform
    platform, Platform -> ByteOrder
    platformByteOrder Platform
    platform) of
          (PlatformWordSize
    PW4, ByteOrder
    LittleEndian) -> FixedPrim Word32 -> ByteString
    forall a. Num a => FixedPrim a -> ByteString
    encodeBigNat FixedPrim Word32
    word32LE
          (PlatformWordSize
    PW4, ByteOrder
    BigEndian   ) -> FixedPrim Word32 -> ByteString
    forall a. Num a => FixedPrim a -> ByteString
    encodeBigNat FixedPrim Word32
    word32BE
          (PlatformWordSize
    PW8, ByteOrder
    LittleEndian) -> FixedPrim Word64 -> ByteString
    forall a. Num a => FixedPrim a -> ByteString
    encodeBigNat FixedPrim Word64
    word64LE
          (PlatformWordSize
    PW8, ByteOrder
    BigEndian   ) -> FixedPrim Word64 -> ByteString
    forall a. Num a => FixedPrim a -> ByteString
    encodeBigNat FixedPrim Word64
    word64BE

      -- Ideally we would just generate a ByteArray# literal here:
      --   pure (emptyFloats, Lit (LitByteArray words))
      -- But sadly we don't have those yet, even in Core. (See also #17747.)
      -- So instead we generate:
      --   * An `Addr#` literal that contains the contents of the
      --      `ByteArray#` we want to create.  This gets its own float.
      --   * A call to `newByteArray#` with the appropriate size
      --   * A call to `copyAddrToByteArray#` to initialize the `ByteArray#`
      --   * A call to `unsafeFreezeByteArray#` to make the types match
      litAddrId <- FastString -> Type -> Type -> UniqSM InVar
    forall (m :: * -> *).
    MonadUnique m =>
    FastString -> Type -> Type -> m InVar
    mkSysLocalM (String -> FastString
    fsLit String
    "bigNatGuts") Type
    ManyTy Type
    addrPrimTy
      -- returned from newByteArray#:
      deadNewByteArrayTupleId
        <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $
             mkTupleTy Unboxed [ realWorldStatePrimTy
                               , realWorldMutableByteArrayPrimTy
                               ]
      stateTokenFromNewByteArrayId
        <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
      mutableByteArrayId
        <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy
      -- returned from copyAddrToByteArray#:
      stateTokenFromCopyId
        <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
      -- returned from unsafeFreezeByteArray#:
      deadFreezeTupleId
        <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $
             mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy]
      stateTokenFromFreezeId
        <- (`setIdOccInfo` IAmDead) <$>
             mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
      byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy

      let
        litAddrRhs = Literal -> Expr b
    forall b. Literal -> Expr b
    Lit (ByteString -> Literal
    LitString ByteString
    words)
          -- not "mkLitString"; that does UTF-8 encoding, which we don't want here
        litAddrFloat = CorePrepEnv -> Demand -> Bool -> InVar -> CpeRhs -> FloatingBind
    mkNonRecFloat CorePrepEnv
    env Demand
    topDmd Bool
    True InVar
    litAddrId CpeRhs
    forall {b}. Expr b
    litAddrRhs

        contentsLength = Platform -> Integer -> CpeRhs
    forall b. Platform -> Integer -> Expr b
    mkIntLit Platform
    platform (Int -> Integer
    forall a. Integral a => a -> Integer
    toInteger (ByteString -> Int
    BS.length ByteString
    words))

        newByteArrayCall =
          InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var (PrimOp -> InVar
    primOpId PrimOp
    NewByteArrayOp_Char)
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` Type -> CpeRhs
    forall b. Type -> Expr b
    Type Type
    realWorldTy
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` CpeRhs
    contentsLength
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    realWorldPrimId

        copyContentsCall =
          InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var (PrimOp -> InVar
    primOpId PrimOp
    CopyAddrToByteArrayOp)
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` Type -> CpeRhs
    forall b. Type -> Expr b
    Type Type
    realWorldTy
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    litAddrId
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    mutableByteArrayId
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` Platform -> Integer -> CpeRhs
    forall b. Platform -> Integer -> Expr b
    mkIntLit Platform
    platform Integer
    0
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` CpeRhs
    contentsLength
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    stateTokenFromNewByteArrayId

        unsafeFreezeCall =
          InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var (PrimOp -> InVar
    primOpId PrimOp
    UnsafeFreezeByteArrayOp)
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` Type -> CpeRhs
    forall b. Type -> Expr b
    Type Type
    realWorldTy
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    mutableByteArrayId
            CpeRhs -> CpeRhs -> CpeRhs
    forall b. Expr b -> Expr b -> Expr b
    `App` InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    stateTokenFromCopyId

        unboxed2tuple_altcon :: AltCon
        unboxed2tuple_altcon = DataCon -> AltCon
    DataAlt (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed Int
    2)

        finalRhs =
          CpeRhs -> InVar -> Type -> [Alt InVar] -> CpeRhs
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CpeRhs
    newByteArrayCall InVar
    deadNewByteArrayTupleId Type
    byteArrayPrimTy
            [ AltCon -> [InVar] -> CpeRhs -> Alt InVar
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    unboxed2tuple_altcon
                  [InVar
    stateTokenFromNewByteArrayId, InVar
    mutableByteArrayId]
                  CpeRhs
    copyContentsCase
            ]

        copyContentsCase =
          CpeRhs -> InVar -> Type -> [Alt InVar] -> CpeRhs
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CpeRhs
    copyContentsCall InVar
    stateTokenFromCopyId Type
    byteArrayPrimTy
            [ AltCon -> [InVar] -> CpeRhs -> Alt InVar
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    DEFAULT [] CpeRhs
    unsafeFreezeCase
            ]

        unsafeFreezeCase =
          CpeRhs -> InVar -> Type -> [Alt InVar] -> CpeRhs
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CpeRhs
    unsafeFreezeCall InVar
    deadFreezeTupleId Type
    byteArrayPrimTy
            [ AltCon -> [InVar] -> CpeRhs -> Alt InVar
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    unboxed2tuple_altcon
                  [InVar
    stateTokenFromFreezeId, InVar
    byteArrayId]
                  (InVar -> CpeRhs
    forall b. InVar -> Expr b
    Var InVar
    byteArrayId)
            ]

      pure (emptyFloats `snocFloat` litAddrFloat, finalRhs)