    {-# LANGUAGE BangPatterns #-}

    {-# 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
       , mkConvertNumLiteral
       )
    where

    import GHC.Prelude

    import GHC.Platform

    import GHC.Driver.Flags

    import GHC.Tc.Utils.Env
    import GHC.Unit

    import GHC.Builtin.Names
    import GHC.Builtin.Types

    import GHC.Core.Utils
    import GHC.Core.Opt.Arity
    import GHC.Core.Lint    ( EndPassConfig(..), endPassIO )
    import GHC.Core
    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.Core.TyCo.Rep( UnivCoProvenance(..) )

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

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

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

    import Data.List        ( unfoldr )
    import Data.Functor.Identity
    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.  [Not any more; nuked Jun 2002] Do the seq/par munging.

    6.  Clone all local Ids.
        This means that all such Ids are unique, rather than the
        weaker guarantee of no clashes which the simplifier provides.
        And that is what the code generator needs.

        We don't clone TyVars or CoVars. The code gen doesn't need that,
        and doing so would be tiresome because then we'd need
        to substitute in types and coercions.

        We need to clone ids for two reasons:
        + Things associated with labels in the final code must be truly unique in
          order to avoid labels being shadowed in the final output.
        + 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.
        + 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.

    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 case clutter in favour of unsafe coercions.
        See Note [Unsafe coercions]

    13. 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 [Unsafe coercions]
    ~~~~~~~~~~~~~~~~~~~~~~~
    CorePrep does these two transformations:

    1. Convert empty case to cast with an unsafe coercion
              (case e of {}) ===>  e |> unsafe-co
       See Note [Empty case alternatives] in GHC.Core: if the case
       alternatives are empty, the scrutinee must diverge or raise an
       exception, so we can just dive into it.

       Of course, if the scrutinee *does* return, we may get a seg-fault.
       A belt-and-braces approach would be to persist empty-alternative
       cases to code generator, and put a return point anyway that calls a
       runtime system error function.

       Notice that eliminating empty case can lead to an ill-kinded coercion
           case error @Int "foo" of {}  :: Int#
           ===> error @Int "foo" |> unsafe-co
           where unsafe-co :: Int ~ Int#
       But that's fine because the expression diverges anyway. And it's
       no different to what happened before.

    2. Eliminate unsafeEqualityProof in favour of an unsafe coercion
               case unsafeEqualityProof of UnsafeRefl g -> e
               ===>  e[unsafe-co/g]
       See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce

       Note that this requires us to substitute 'unsafe-co' for 'g', and
       that is the main (current) reason for cpe_tyco_env in CorePrepEnv.
       Tiresome, but not difficult.

    These transformations get rid of "case clutter", leaving only casts.
    We are doing no further significant transformations, so the reasons
    for the case forms have disappeared. And it is extremely helpful for
    the ANF-ery, CoreToStg, and backends, if trivial expressions really do
    look trivial. #19700 was an example.

    In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)),
    The boolean 'b' says whether the unsafe coercion is supposed to be
    kind-homogeneous (yes for (2), no for (1).  This information is used
    /only/ by Lint.

    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 body 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.
    -}

    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
        UniqSupply
    us <- Char -> IO UniqSupply
    mkSplitUniqSupply Char
    's'
        let initialCorePrepEnv :: CorePrepEnv
    initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
    mkInitialCorePrepEnv CorePrepConfig
    cp_cfg

        let
            implicit_binds :: CoreProgram
    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 :: CoreProgram
    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
                          Floats
    floats1 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
    corePrepTopBinds CorePrepEnv
    initialCorePrepEnv CoreProgram
    binds
                          Floats
    floats2 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
    corePrepTopBinds CorePrepEnv
    initialCorePrepEnv CoreProgram
    implicit_binds
                          CoreProgram -> UniqSM CoreProgram
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats -> CoreProgram
    deFloatTop (Floats
    floats1 Floats -> Floats -> Floats
    `appendFloats` Floats
    floats2))

        Logger -> EndPassConfig -> CoreProgram -> [CoreRule] -> IO ()
    endPassIO Logger
    logger (CorePrepPgmConfig -> EndPassConfig
    cpPgm_endPassConfig CorePrepPgmConfig
    pgm_cfg)
                  CoreProgram
    binds_out []
        CoreProgram -> IO CoreProgram
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CoreProgram
    binds_out

    corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr
    corePrepExpr :: Logger -> CorePrepConfig -> CpeApp -> IO CpeApp
    corePrepExpr Logger
    logger CorePrepConfig
    config CpeApp
    expr = do
        Logger -> SDoc -> (CpeApp -> ()) -> IO CpeApp -> IO CpeApp
    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]") (\CpeApp
    e -> CpeApp
    e CpeApp -> () -> ()
    forall a b. a -> b -> b
    `seq` ()) (IO CpeApp -> IO CpeApp) -> IO CpeApp -> IO CpeApp
    forall a b. (a -> b) -> a -> b
    $ do
          UniqSupply
    us <- Char -> IO UniqSupply
    mkSplitUniqSupply Char
    's'
          let initialCorePrepEnv :: CorePrepEnv
    initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
    mkInitialCorePrepEnv CorePrepConfig
    config
          let new_expr :: CpeApp
    new_expr = UniqSupply -> UniqSM CpeApp -> CpeApp
    forall a. UniqSupply -> UniqSM a -> a
    initUs_ UniqSupply
    us (CorePrepEnv -> CpeApp -> UniqSM CpeApp
    cpeBodyNF CorePrepEnv
    initialCorePrepEnv CpeApp
    expr)
          Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    putDumpFileMaybe Logger
    logger DumpFlag
    Opt_D_dump_prep String
    "CorePrep" DumpFormat
    FormatCore (CpeApp -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CpeApp
    new_expr)
          CpeApp -> IO CpeApp
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CpeApp
    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 (CorePrepEnv
    env', Floats
    floats, Maybe CoreBind
    maybe_new_bind)
                                     <- TopLevelFlag
    -> CorePrepEnv
    -> CoreBind
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    cpeBind TopLevelFlag
    TopLevel CorePrepEnv
    env CoreBind
    bind
                                   Bool -> UniqSM ()
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
    massert (Maybe CoreBind -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe CoreBind
    maybe_new_bind)
                                     -- Only join points get returned this way by
                                     -- cpeBind, and no join point may float to top
                                   Floats
    floatss <- CorePrepEnv -> CoreProgram -> UniqSM Floats
    go CorePrepEnv
    env' CoreProgram
    binds
                                   Floats -> UniqSM Floats
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats Floats -> Floats -> Floats
    `appendFloats` Floats
    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
      = [ Id -> CpeApp -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    id (Name -> CpeApp -> CpeApp
    tick_it (DataCon -> Name
    forall a. NamedThing a => a -> Name
    getName DataCon
    data_con) (Id -> CpeApp
    forall b. Id -> Expr b
    Var Id
    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 :: Id
    id = DataCon -> Id
    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 -> CpeApp -> CpeApp
    tick_it Name
    name
         | Bool -> Bool
    not Bool
    generate_debug_info               = CpeApp -> CpeApp
    forall a. a -> a
    id
         | RealSrcSpan RealSrcSpan
    span Maybe BufSpan
    _ <- Name -> SrcSpan
    nameSrcSpan Name
    name = RealSrcSpan -> CpeApp -> CpeApp
    tick RealSrcSpan
    span
         | Just String
    file <- ModLocation -> Maybe String
    ml_hs_file ModLocation
    mod_loc       = RealSrcSpan -> CpeApp -> CpeApp
    tick (String -> RealSrcSpan
    span1 String
    file)
         | Bool
    otherwise                             = RealSrcSpan -> CpeApp -> CpeApp
    tick (String -> RealSrcSpan
    span1 String
    "???")
         where tick :: RealSrcSpan -> CpeApp -> CpeApp
    tick RealSrcSpan
    span  = CoreTickish -> CpeApp -> CpeApp
    forall b. CoreTickish -> Expr b -> Expr b
    Tick (CoreTickish -> CpeApp -> CpeApp)
    -> CoreTickish -> CpeApp -> CpeApp
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> String -> CoreTickish
    forall (pass :: TickishPass).
    RealSrcSpan -> String -> GenTickish pass
    SourceNote RealSrcSpan
    span (String -> CoreTickish) -> String -> CoreTickish
    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 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 Id
    bndr CpeApp
    rhs)
      | Bool -> Bool
    not (Id -> Bool
    isJoinId Id
    bndr)
      = do { (CorePrepEnv
    env1, Id
    bndr1) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
    cpCloneBndr CorePrepEnv
    env Id
    bndr
           ; let dmd :: Demand
    dmd         = Id -> Demand
    idDemandInfo Id
    bndr
                 is_unlifted :: Bool
    is_unlifted = (() :: Constraint) => Type -> Bool
    Type -> Bool
    isUnliftedType (Id -> Type
    idType Id
    bndr)
           ; (Floats
    floats, CpeApp
    rhs1) <- TopLevelFlag
    -> RecFlag
    -> Demand
    -> Bool
    -> CorePrepEnv
    -> Id
    -> CpeApp
    -> UniqSM (Floats, CpeApp)
    cpePair TopLevelFlag
    top_lvl RecFlag
    NonRecursive
                                       Demand
    dmd Bool
    is_unlifted
                                       CorePrepEnv
    env Id
    bndr1 CpeApp
    rhs
           -- See Note [Inlining in CorePrep]
           ; let triv_rhs :: Bool
    triv_rhs = CpeApp -> Bool
    exprIsTrivial CpeApp
    rhs1
                 env2 :: CorePrepEnv
    env2    | Bool
    triv_rhs  = CorePrepEnv -> Id -> CpeApp -> CorePrepEnv
    extendCorePrepEnvExpr CorePrepEnv
    env1 Id
    bndr CpeApp
    rhs1
                         | Bool
    otherwise = CorePrepEnv
    env1
                 floats1 :: Floats
    floats1 | Bool
    triv_rhs, Name -> Bool
    isInternalName (Id -> Name
    idName Id
    bndr)
                         = Floats
    floats
                         | Bool
    otherwise
                         = Floats -> FloatingBind -> Floats
    addFloat Floats
    floats FloatingBind
    new_float

                 new_float :: FloatingBind
    new_float = CorePrepEnv -> Demand -> Bool -> Id -> CpeApp -> FloatingBind
    mkFloat CorePrepEnv
    env Demand
    dmd Bool
    is_unlifted Id
    bndr1 CpeApp
    rhs1

           ; (CorePrepEnv, Floats, Maybe CoreBind)
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv
    env2, Floats
    floats1, Maybe CoreBind
    forall a. Maybe a
    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 { (CorePrepEnv
    _, Id
    bndr1) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
    cpCloneBndr CorePrepEnv
    env Id
    bndr
           ; (Id
    bndr2, CpeApp
    rhs1) <- CorePrepEnv -> Id -> CpeApp -> UniqSM (Id, CpeApp)
    cpeJoinPair CorePrepEnv
    env Id
    bndr1 CpeApp
    rhs
           ; (CorePrepEnv, Floats, Maybe CoreBind)
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv -> Id -> Id -> CorePrepEnv
    extendCorePrepEnv CorePrepEnv
    env Id
    bndr Id
    bndr2,
                     Floats
    emptyFloats,
                     CoreBind -> Maybe CoreBind
    forall a. a -> Maybe a
    Just (Id -> CpeApp -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    bndr2 CpeApp
    rhs1)) }

    cpeBind TopLevelFlag
    top_lvl CorePrepEnv
    env (Rec [(Id, CpeApp)]
    pairs)
      | Bool -> Bool
    not (Id -> Bool
    isJoinId ([Id] -> Id
    forall a. HasCallStack => [a] -> a
    head [Id]
    bndrs))
      = do { (CorePrepEnv
    env, [Id]
    bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
    cpCloneBndrs CorePrepEnv
    env [Id]
    bndrs
           ; let env' :: CorePrepEnv
    env' = CorePrepEnv -> [Id] -> CorePrepEnv
    enterRecGroupRHSs CorePrepEnv
    env [Id]
    bndrs1
           ; [(Floats, CpeApp)]
    stuff <- (Id -> CpeApp -> UniqSM (Floats, CpeApp))
    -> [Id] -> [CpeApp] -> UniqSM [(Floats, CpeApp)]
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m [c]
    zipWithM (TopLevelFlag
    -> RecFlag
    -> Demand
    -> Bool
    -> CorePrepEnv
    -> Id
    -> CpeApp
    -> UniqSM (Floats, CpeApp)
    cpePair TopLevelFlag
    top_lvl RecFlag
    Recursive Demand
    topDmd Bool
    False CorePrepEnv
    env')
                               [Id]
    bndrs1 [CpeApp]
    rhss

           ; let ([Floats]
    floats_s, [CpeApp]
    rhss1) = [(Floats, CpeApp)] -> ([Floats], [CpeApp])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Floats, CpeApp)]
    stuff
                 all_pairs :: [(Id, CpeApp)]
    all_pairs = (FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)])
    -> [(Id, CpeApp)] -> OrdList FloatingBind -> [(Id, CpeApp)]
    forall a b. (a -> b -> b) -> b -> OrdList a -> b
    foldrOL FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)]
    add_float ([Id]
    bndrs1 [Id] -> [CpeApp] -> [(Id, CpeApp)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [CpeApp]
    rhss1)
                                               ([Floats] -> OrdList FloatingBind
    concatFloats [Floats]
    floats_s)
           -- use env below, so that we reset cpe_rec_ids
           ; (CorePrepEnv, Floats, Maybe CoreBind)
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
    extendCorePrepEnvList CorePrepEnv
    env ([Id]
    bndrs [Id] -> [Id] -> [(Id, Id)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [Id]
    bndrs1),
                     FloatingBind -> Floats
    unitFloat (CoreBind -> FloatingBind
    FloatLet ([(Id, CpeApp)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec [(Id, CpeApp)]
    all_pairs)),
                     Maybe CoreBind
    forall a. Maybe a
    Nothing) }

      | Bool
    otherwise -- See Note [Join points and floating]
      = do { (CorePrepEnv
    env, [Id]
    bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
    cpCloneBndrs CorePrepEnv
    env [Id]
    bndrs
           ; let env' :: CorePrepEnv
    env' = CorePrepEnv -> [Id] -> CorePrepEnv
    enterRecGroupRHSs CorePrepEnv
    env [Id]
    bndrs1
           ; [(Id, CpeApp)]
    pairs1 <- (Id -> CpeApp -> UniqSM (Id, CpeApp))
    -> [Id] -> [CpeApp] -> UniqSM [(Id, CpeApp)]
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m [c]
    zipWithM (CorePrepEnv -> Id -> CpeApp -> UniqSM (Id, CpeApp)
    cpeJoinPair CorePrepEnv
    env') [Id]
    bndrs1 [CpeApp]
    rhss

           ; let bndrs2 :: [Id]
    bndrs2 = ((Id, CpeApp) -> Id) -> [(Id, CpeApp)] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map (Id, CpeApp) -> Id
    forall a b. (a, b) -> a
    fst [(Id, CpeApp)]
    pairs1
           -- use env below, so that we reset cpe_rec_ids
           ; (CorePrepEnv, Floats, Maybe CoreBind)
    -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
    extendCorePrepEnvList CorePrepEnv
    env ([Id]
    bndrs [Id] -> [Id] -> [(Id, Id)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [Id]
    bndrs2),
                     Floats
    emptyFloats,
                     CoreBind -> Maybe CoreBind
    forall a. a -> Maybe a
    Just ([(Id, CpeApp)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec [(Id, CpeApp)]
    pairs1)) }
      where
        ([Id]
    bndrs, [CpeApp]
    rhss) = [(Id, CpeApp)] -> ([Id], [CpeApp])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Id, CpeApp)]
    pairs

            -- Flatten all the floats, and the current
            -- group into a single giant Rec
        add_float :: FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)]
    add_float (FloatLet (NonRec Id
    b CpeApp
    r)) [(Id, CpeApp)]
    prs2 = (Id
    b,CpeApp
    r) (Id, CpeApp) -> [(Id, CpeApp)] -> [(Id, CpeApp)]
    forall a. a -> [a] -> [a]
    : [(Id, CpeApp)]
    prs2
        add_float (FloatLet (Rec [(Id, CpeApp)]
    prs1))   [(Id, CpeApp)]
    prs2 = [(Id, CpeApp)]
    prs1 [(Id, CpeApp)] -> [(Id, CpeApp)] -> [(Id, CpeApp)]
    forall a. [a] -> [a] -> [a]
    ++ [(Id, CpeApp)]
    prs2
        add_float FloatingBind
    b                       [(Id, CpeApp)]
    _    = String -> SDoc -> [(Id, CpeApp)]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "cpeBind" (FloatingBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatingBind
    b)

    ---------------
    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
    -> Id
    -> CpeApp
    -> UniqSM (Floats, CpeApp)
    cpePair TopLevelFlag
    top_lvl RecFlag
    is_rec Demand
    dmd Bool
    is_unlifted CorePrepEnv
    env Id
    bndr CpeApp
    rhs
      = Bool -> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. HasCallStack => Bool -> a -> a
    assert (Bool -> Bool
    not (Id -> Bool
    isJoinId Id
    bndr)) (UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp))
    -> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a b. (a -> b) -> a -> b
    $ -- those should use cpeJoinPair
        do { (Floats
    floats1, CpeApp
    rhs1) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env CpeApp
    rhs

           -- See if we are allowed to float this stuff out of the RHS
           ; (Floats
    floats2, CpeApp
    rhs2) <- Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    float_from_rhs Floats
    floats1 CpeApp
    rhs1

           -- Make the arity match up
           ; (Floats
    floats3, CpeApp
    rhs3)
                <- if CpeApp -> Int
    manifestArity CpeApp
    rhs1 Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    arity
                   then (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats2, Int -> CpeApp -> CpeApp
    cpeEtaExpand Int
    arity CpeApp
    rhs2)
                   else Bool
    -> String
    -> SDoc
    -> UniqSM (Floats, CpeApp)
    -> UniqSM (Floats, CpeApp)
    forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
    warnPprTrace Bool
    True String
    "CorePrep: silly extra arguments:" (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    bndr) (UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp))
    -> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a b. (a -> b) -> a -> b
    $
                                   -- Note [Silly extra arguments]
                        (do { Id
    v <- Type -> UniqSM Id
    newVar (Id -> Type
    idType Id
    bndr)
                            ; let float :: FloatingBind
    float = CorePrepEnv -> Demand -> Bool -> Id -> CpeApp -> FloatingBind
    mkFloat CorePrepEnv
    env Demand
    topDmd Bool
    False Id
    v CpeApp
    rhs2
                            ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( Floats -> FloatingBind -> Floats
    addFloat Floats
    floats2 FloatingBind
    float
                                     , Int -> CpeApp -> CpeApp
    cpeEtaExpand Int
    arity (Id -> CpeApp
    forall b. Id -> Expr b
    Var Id
    v)) })

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

           ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats4, CpeApp
    rhs4) }
      where
        arity :: Int
    arity = Id -> Int
    idArity Id
    bndr        -- We must match this arity

        ---------------------
        float_from_rhs :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    float_from_rhs Floats
    floats CpeApp
    rhs
          | Floats -> Bool
    isEmptyFloats Floats
    floats = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, CpeApp
    rhs)
          | TopLevelFlag -> Bool
    isTopLevel TopLevelFlag
    top_lvl   = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    float_top    Floats
    floats CpeApp
    rhs
          | Bool
    otherwise            = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    float_nested Floats
    floats CpeApp
    rhs

        ---------------------
        float_nested :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    float_nested Floats
    floats CpeApp
    rhs
          | RecFlag -> Demand -> Bool -> Floats -> CpeApp -> Bool
    wantFloatNested RecFlag
    is_rec Demand
    dmd Bool
    is_unlifted Floats
    floats CpeApp
    rhs
                      = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats, CpeApp
    rhs)
          | Bool
    otherwise = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    dontFloat Floats
    floats CpeApp
    rhs

        ---------------------
        float_top :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    float_top Floats
    floats CpeApp
    rhs
          | Floats -> Bool
    allLazyTop Floats
    floats
          = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats, CpeApp
    rhs)

          | Just (Floats, CpeApp)
    floats <- Floats -> CpeApp -> Maybe (Floats, CpeApp)
    canFloat Floats
    floats CpeApp
    rhs
          = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats, CpeApp)
    floats

          | Bool
    otherwise
          = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    dontFloat Floats
    floats CpeApp
    rhs

    dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
    -- Non-empty floats, but do not want to float from rhs
    -- So wrap the rhs in the floats
    -- But: rhs1 might have lambdas, and we can't
    --      put them inside a wrapBinds
    dontFloat :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    dontFloat Floats
    floats1 CpeApp
    rhs
      = do { (Floats
    floats2, CpeApp
    body) <- CpeApp -> UniqSM (Floats, CpeApp)
    rhsToBody CpeApp
    rhs
            ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, Floats -> CpeApp -> CpeApp
    wrapBinds Floats
    floats1 (CpeApp -> CpeApp) -> CpeApp -> CpeApp
    forall a b. (a -> b) -> a -> b
    $
                                   Floats -> CpeApp -> CpeApp
    wrapBinds Floats
    floats2 CpeApp
    body) }

    {- 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 -> Id -> CpeApp -> UniqSM (Id, CpeApp)
    cpeJoinPair CorePrepEnv
    env Id
    bndr CpeApp
    rhs
      = Bool -> UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp)
    forall a. HasCallStack => Bool -> a -> a
    assert (Id -> Bool
    isJoinId Id
    bndr) (UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp))
    -> UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp)
    forall a b. (a -> b) -> a -> b
    $
        do { let Just Int
    join_arity = Id -> Maybe Int
    isJoinId_maybe Id
    bndr
                 ([Id]
    bndrs, CpeApp
    body)   = Int -> CpeApp -> ([Id], CpeApp)
    forall b. Int -> Expr b -> ([b], Expr b)
    collectNBinders Int
    join_arity CpeApp
    rhs

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

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

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

           ; (Id, CpeApp) -> UniqSM (Id, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id
    bndr', CpeApp
    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 -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env (Type Type
    ty)
      = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, Type -> CpeApp
    forall b. Type -> Expr b
    Type (CorePrepEnv -> Type -> Type
    cpSubstTy CorePrepEnv
    env Type
    ty))
    cpeRhsE CorePrepEnv
    env (Coercion Coercion
    co)
      = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, Coercion -> CpeApp
    forall b. Coercion -> Expr b
    Coercion (CorePrepEnv -> Coercion -> Coercion
    cpSubstCo CorePrepEnv
    env Coercion
    co))
    cpeRhsE CorePrepEnv
    env expr :: CpeApp
    expr@(Lit (LitNumber LitNumType
    nt Integer
    i))
       = case CorePrepConfig -> LitNumType -> Integer -> Maybe CpeApp
    cp_convertNumLit (CorePrepEnv -> CorePrepConfig
    cpe_config CorePrepEnv
    env) LitNumType
    nt Integer
    i of
          Maybe CpeApp
    Nothing -> (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, CpeApp
    expr)
          Just CpeApp
    e  -> CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env CpeApp
    e
    cpeRhsE CorePrepEnv
    _env expr :: CpeApp
    expr@(Lit {}) = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, CpeApp
    expr)
    cpeRhsE CorePrepEnv
    env expr :: CpeApp
    expr@(Var {})  = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeApp CorePrepEnv
    env CpeApp
    expr
    cpeRhsE CorePrepEnv
    env expr :: CpeApp
    expr@(App {})  = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeApp CorePrepEnv
    env CpeApp
    expr

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

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

    cpeRhsE CorePrepEnv
    env (Cast CpeApp
    expr Coercion
    co)
       = do { (Floats
    floats, CpeApp
    expr') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env CpeApp
    expr
            ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats, CpeApp -> Coercion -> CpeApp
    forall b. Expr b -> Coercion -> Expr b
    Cast CpeApp
    expr' (CorePrepEnv -> Coercion -> Coercion
    cpSubstCo CorePrepEnv
    env Coercion
    co)) }

    cpeRhsE CorePrepEnv
    env expr :: CpeApp
    expr@(Lam {})
       = do { let ([Id]
    bndrs,CpeApp
    body) = CpeApp -> ([Id], CpeApp)
    forall b. Expr b -> ([b], Expr b)
    collectBinders CpeApp
    expr
            ; (CorePrepEnv
    env', [Id]
    bndrs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
    cpCloneBndrs CorePrepEnv
    env [Id]
    bndrs
            ; CpeApp
    body' <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
    cpeBodyNF CorePrepEnv
    env' CpeApp
    body
            ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, [Id] -> CpeApp -> CpeApp
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    bndrs' CpeApp
    body') }

    -- Eliminate empty case
    -- See Note [Unsafe coercions]
    cpeRhsE CorePrepEnv
    env (Case CpeApp
    scrut Id
    _ Type
    ty [])
      = do { (Floats
    floats, CpeApp
    scrut') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env CpeApp
    scrut
           ; let ty' :: Type
    ty'       = CorePrepEnv -> Type -> Type
    cpSubstTy CorePrepEnv
    env Type
    ty
                 scrut_ty' :: Type
    scrut_ty' = (() :: Constraint) => CpeApp -> Type
    CpeApp -> Type
    exprType CpeApp
    scrut'
                 co' :: Coercion
    co'       = UnivCoProvenance -> Role -> Type -> Type -> Coercion
    mkUnivCo UnivCoProvenance
    prov Role
    Representational Type
    scrut_ty' Type
    ty'
                 prov :: UnivCoProvenance
    prov      = Bool -> UnivCoProvenance
    CorePrepProv Bool
    False
                   -- False says that the kinds of two types may differ
                   -- E.g. we might cast Int to Int#.  This is fine
                   -- because the scrutinee is guaranteed to diverge

           ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats, CpeApp -> Coercion -> CpeApp
    forall b. Expr b -> Coercion -> Expr b
    Cast CpeApp
    scrut' Coercion
    co') }
       -- This can give rise to
       --   Warning: Unsafe coercion: between unboxed and boxed value
       -- but it's fine because 'scrut' diverges

    -- Eliminate unsafeEqualityProof
    -- See Note [Unsafe coercions]
    cpeRhsE CorePrepEnv
    env (Case CpeApp
    scrut Id
    bndr Type
    _ [Alt Id]
    alts)
      | CpeApp -> Bool
    isUnsafeEqualityProof CpeApp
    scrut
      , Id -> Bool
    isDeadBinder Id
    bndr -- We can only discard the case if the case-binder
                          -- is dead.  It usually is, but see #18227
      , [Alt AltCon
    _ [Id
    co_var] CpeApp
    rhs] <- [Alt Id]
    alts
      , let Pair Type
    ty1 Type
    ty2 = (() :: Constraint) => Id -> Pair Type
    Id -> Pair Type
    coVarTypes Id
    co_var
            the_co :: Coercion
    the_co = UnivCoProvenance -> Role -> Type -> Type -> Coercion
    mkUnivCo UnivCoProvenance
    prov Role
    Nominal (CorePrepEnv -> Type -> Type
    cpSubstTy CorePrepEnv
    env Type
    ty1) (CorePrepEnv -> Type -> Type
    cpSubstTy CorePrepEnv
    env Type
    ty2)
            prov :: UnivCoProvenance
    prov   = Bool -> UnivCoProvenance
    CorePrepProv Bool
    True  -- True <=> kind homogeneous
            env' :: CorePrepEnv
    env'   = CorePrepEnv -> Id -> Coercion -> CorePrepEnv
    extendCoVarEnv CorePrepEnv
    env Id
    co_var Coercion
    the_co
      = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env' CpeApp
    rhs

    cpeRhsE CorePrepEnv
    env (Case CpeApp
    scrut Id
    bndr Type
    ty [Alt Id]
    alts)
      = do { (Floats
    floats, CpeApp
    scrut') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeBody CorePrepEnv
    env CpeApp
    scrut
           ; (CorePrepEnv
    env', Id
    bndr2) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
    cpCloneBndr CorePrepEnv
    env Id
    bndr
           ; let alts' :: [Alt Id]
    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 Id] -> Bool
    forall b. [Alt b] -> Bool
    altsAreExhaustive [Alt Id]
    alts)
                   = [Alt Id] -> Maybe CpeApp -> [Alt Id]
    forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
    addDefault [Alt Id]
    alts (CpeApp -> Maybe CpeApp
    forall a. a -> Maybe a
    Just CpeApp
    err)
                   | Bool
    otherwise = [Alt Id]
    alts
                   where err :: CpeApp
    err = Type -> String -> CpeApp
    mkImpossibleExpr Type
    ty String
    "cpeRhsE: missing case alternative"
           ; [Alt Id]
    alts'' <- (Alt Id -> UniqSM (Alt Id)) -> [Alt Id] -> UniqSM [Alt Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (CorePrepEnv -> Alt Id -> UniqSM (Alt Id)
    sat_alt CorePrepEnv
    env') [Alt Id]
    alts'

           ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats, CpeApp -> Id -> Type -> [Alt Id] -> CpeApp
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CpeApp
    scrut' Id
    bndr2 Type
    ty [Alt Id]
    alts'') }
      where
        sat_alt :: CorePrepEnv -> Alt Id -> UniqSM (Alt Id)
    sat_alt CorePrepEnv
    env (Alt AltCon
    con [Id]
    bs CpeApp
    rhs)
           = do { (CorePrepEnv
    env2, [Id]
    bs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
    cpCloneBndrs CorePrepEnv
    env [Id]
    bs
                ; CpeApp
    rhs' <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
    cpeBodyNF CorePrepEnv
    env2 CpeApp
    rhs
                ; Alt Id -> UniqSM (Alt Id)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (AltCon -> [Id] -> CpeApp -> Alt Id
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    con [Id]
    bs' CpeApp
    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 -> CpeApp -> UniqSM CpeApp
    cpeBodyNF CorePrepEnv
    env CpeApp
    expr
      = do { (Floats
    floats, CpeApp
    body) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeBody CorePrepEnv
    env CpeApp
    expr
           ; CpeApp -> UniqSM CpeApp
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats -> CpeApp -> CpeApp
    wrapBinds Floats
    floats CpeApp
    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 -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeBody CorePrepEnv
    env CpeApp
    expr
      = do { (Floats
    floats1, CpeApp
    rhs) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env CpeApp
    expr
           ; (Floats
    floats2, CpeApp
    body) <- CpeApp -> UniqSM (Floats, CpeApp)
    rhsToBody CpeApp
    rhs
           ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats1 Floats -> Floats -> Floats
    `appendFloats` Floats
    floats2, CpeApp
    body) }

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

    rhsToBody :: CpeApp -> UniqSM (Floats, CpeApp)
    rhsToBody (Tick CoreTickish
    t CpeApp
    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
    floats, CpeApp
    expr') <- CpeApp -> UniqSM (Floats, CpeApp)
    rhsToBody CpeApp
    expr
           ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats, CoreTickish -> CpeApp -> CpeApp
    mkTick CoreTickish
    t CpeApp
    expr') }

    rhsToBody (Cast CpeApp
    e Coercion
    co)
            -- You can get things like
            --      case e of { p -> coerce t (\s -> ...) }
      = do { (Floats
    floats, CpeApp
    e') <- CpeApp -> UniqSM (Floats, CpeApp)
    rhsToBody CpeApp
    e
           ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats, CpeApp -> Coercion -> CpeApp
    forall b. Expr b -> Coercion -> Expr b
    Cast CpeApp
    e' Coercion
    co) }

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

    rhsToBody CpeApp
    expr = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    emptyFloats, CpeApp
    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 CpeApp
    arg) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "app" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CpeApp -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CpeApp
    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 -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeApp CorePrepEnv
    top_env CpeApp
    expr
      = do { let (CpeApp
    terminal, [ArgInfo]
    args) = CpeApp -> (CpeApp, [ArgInfo])
    collect_args CpeApp
    expr
          --  ; pprTraceM "cpeApp" $ (ppr expr)
           ; CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
    cpe_app CorePrepEnv
    top_env CpeApp
    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 :: CpeApp -> (CpeApp, [ArgInfo])
    collect_args CpeApp
    e = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
    go CpeApp
    e []
          where
            go :: CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
    go (App CpeApp
    fun CpeApp
    arg)      [ArgInfo]
    as
                = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
    go CpeApp
    fun (CpeApp -> ArgInfo
    CpeApp CpeApp
    arg ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    as)
            go (Cast CpeApp
    fun Coercion
    co)      [ArgInfo]
    as
                = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
    go CpeApp
    fun (Coercion -> ArgInfo
    CpeCast Coercion
    co ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    as)
            go (Tick CoreTickish
    tickish CpeApp
    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 Id
    vh <- CpeApp
    head
                , Var Id
    head' <- CorePrepEnv -> Id -> CpeApp
    lookupCorePrepEnv CorePrepEnv
    top_env Id
    vh
                , Id -> CoreTickish -> Bool
    forall (pass :: TickishPass). Id -> GenTickish pass -> Bool
    etaExpansionTick Id
    head' CoreTickish
    tickish
                = (CpeApp
    head,[ArgInfo]
    as')
                where
                  (CpeApp
    head,[ArgInfo]
    as') = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
    go CpeApp
    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 CpeApp
    terminal [ArgInfo]
    as = (CpeApp
    terminal, [ArgInfo]
    as)

        cpe_app :: CorePrepEnv
                -> CoreExpr -- The thing we are calling
                -> [ArgInfo]
                -> UniqSM (Floats, CpeRhs)
        cpe_app :: CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
    cpe_app CorePrepEnv
    env (Var Id
    f) (CpeApp Type{} : CpeApp CpeApp
    arg : [ArgInfo]
    args)
            | Id
    f Id -> 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
    || Id
    f Id -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    noinlineIdKey Bool -> Bool -> Bool
    || Id
    f Id -> 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
    || Id
    f Id -> 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 (CpeApp
    terminal, [ArgInfo]
    args') = CpeApp -> (CpeApp, [ArgInfo])
    collect_args CpeApp
    arg
              in CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
    cpe_app CorePrepEnv
    env CpeApp
    terminal ([ArgInfo]
    args' [ArgInfo] -> [ArgInfo] -> [ArgInfo]
    forall a. [a] -> [a] -> [a]
    ++ [ArgInfo]
    args)

        -- runRW# magic
        cpe_app CorePrepEnv
    env (Var Id
    f) (CpeApp _runtimeRep :: CpeApp
    _runtimeRep@Type{} : CpeApp _type :: CpeApp
    _type@Type{} : CpeApp CpeApp
    arg : [ArgInfo]
    rest)
            | Id
    f Id -> 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 (CpeApp -> ArgInfo
    CpeApp CpeApp
    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 CpeApp
    arg of
                Lam Id
    s CpeApp
    body -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
    cpe_app (CorePrepEnv -> Id -> Id -> CorePrepEnv
    extendCorePrepEnv CorePrepEnv
    env Id
    s Id
    realWorldPrimId) CpeApp
    body [ArgInfo]
    rest
                CpeApp
    _          -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
    cpe_app CorePrepEnv
    env CpeApp
    arg (CpeApp -> ArgInfo
    CpeApp (Id -> CpeApp
    forall b. Id -> Expr b
    Var Id
    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 CpeApp
    arg:[ArgInfo]
    _rest)
                | Bool -> Bool
    not (CpeApp -> Bool
    forall b. Expr b -> Bool
    isTyCoArg CpeApp
    arg) = Bool
    True
              has_value_arg (ArgInfo
    _:[ArgInfo]
    rest) = [ArgInfo] -> Bool
    has_value_arg [ArgInfo]
    rest

        cpe_app CorePrepEnv
    env (Var Id
    v) [ArgInfo]
    args
          = do { Id
    v1 <- Id -> UniqSM Id
    fiddleCCall Id
    v
               ; let e2 :: CpeApp
    e2 = CorePrepEnv -> Id -> CpeApp
    lookupCorePrepEnv CorePrepEnv
    env Id
    v1
                     hd :: Maybe Id
    hd = CpeApp -> Maybe Id
    getIdFromTrivialExpr_maybe CpeApp
    e2
                     -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
                     min_arity :: Maybe Int
    min_arity = case Maybe Id
    hd of
                       Just Id
    v_hd -> if Id -> Bool
    hasNoBinding Id
    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
    $! (Id -> Int
    idArity Id
    v_hd) else Maybe Int
    forall a. Maybe a
    Nothing
                       Maybe Id
    Nothing -> Maybe Int
    forall a. Maybe a
    Nothing
              --  ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))
               ; (CpeApp
    app, Floats
    floats, [CoreTickish]
    unsat_ticks) <- CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> Maybe Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app CorePrepEnv
    env [ArgInfo]
    args CpeApp
    e2 Floats
    emptyFloats [Demand]
    stricts Maybe Int
    min_arity
               ; Maybe Id
    -> CpeApp
    -> Floats
    -> [CoreTickish]
    -> Int
    -> UniqSM (Floats, CpeApp)
    forall {a}.
    Maybe Id
    -> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
    mb_saturate Maybe Id
    hd CpeApp
    app Floats
    floats [CoreTickish]
    unsat_ticks Int
    depth }
            where
              depth :: Int
    depth = [ArgInfo] -> Int
    val_args [ArgInfo]
    args
              stricts :: [Demand]
    stricts = case Id -> DmdSig
    idDmdSig Id
    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 CpeApp
    fun [] = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env CpeApp
    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 CpeApp
    fun [ArgInfo]
    args
          = do { (Floats
    fun_floats, CpeApp
    fun') <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeArg CorePrepEnv
    env Demand
    evalDmd CpeApp
    fun
                              -- If evalDmd says that it's sure to be evaluated,
                              -- we'll end up case-binding it
               ; (CpeApp
    app, Floats
    floats,[CoreTickish]
    unsat_ticks) <- CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> Maybe Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app CorePrepEnv
    env [ArgInfo]
    args CpeApp
    fun' Floats
    fun_floats [] Maybe Int
    forall a. Maybe a
    Nothing
               ; Maybe Id
    -> CpeApp
    -> Floats
    -> [CoreTickish]
    -> Int
    -> UniqSM (Floats, CpeApp)
    forall {a}.
    Maybe Id
    -> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
    mb_saturate Maybe Id
    forall a. Maybe a
    Nothing CpeApp
    app Floats
    floats [CoreTickish]
    unsat_ticks ([ArgInfo] -> Int
    val_args [ArgInfo]
    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 CpeApp
    e                                  -> [ArgInfo] -> t -> t
    go [ArgInfo]
    infos t
    n'
                  where
                    !n' :: t
    n'
                      | CpeApp -> Bool
    forall b. Expr b -> Bool
    isTypeArg CpeApp
    e = t
    n
                      | Bool
    otherwise   = t
    nt -> t -> t
    forall a. Num a => a -> a -> a
    +t
    1

        -- Saturate if necessary
        mb_saturate :: Maybe Id
    -> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
    mb_saturate Maybe Id
    head CpeApp
    app a
    floats [CoreTickish]
    unsat_ticks Int
    depth =
           case Maybe Id
    head of
             Just Id
    fn_id -> do { CpeApp
    sat_app <- Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeApp
    maybeSaturate Id
    fn_id CpeApp
    app Int
    depth [CoreTickish]
    unsat_ticks
                              ; (a, CpeApp) -> UniqSM (a, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    floats, CpeApp
    sat_app) }
             Maybe Id
    _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, CpeApp) -> UniqSM (a, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    floats, CpeApp
    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
            -> [Demand]
            -> Maybe Arity
            -> UniqSM (CpeApp
                      ,Floats
                      ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]
                      )
        rebuild_app :: CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> Maybe Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app CorePrepEnv
    env [ArgInfo]
    args CpeApp
    app Floats
    floats [Demand]
    ss Maybe Int
    req_depth =
          CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    args CpeApp
    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]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    _ [] CpeApp
    app Floats
    floats [Demand]
    ss [CoreTickish]
    rt_ticks !Int
    _req_depth
          = Bool
    -> SDoc
    -> ((CpeApp, Floats, [CoreTickish])
        -> UniqSM (CpeApp, Floats, [CoreTickish]))
    -> (CpeApp, Floats, [CoreTickish])
    -> UniqSM (CpeApp, 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
            (CpeApp, Floats, [CoreTickish])
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CpeApp
    app, Floats
    floats, [CoreTickish]
    rt_ticks)

        rebuild_app' CorePrepEnv
    env (ArgInfo
    a : [ArgInfo]
    as) CpeApp
    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 :: CpeApp
    tick_fun = (CoreTickish -> CpeApp -> CpeApp)
    -> CpeApp -> [CoreTickish] -> CpeApp
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr CoreTickish -> CpeApp -> CpeApp
    mkTick CpeApp
    fun' [CoreTickish]
    rt_ticks
                in CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env (ArgInfo
    a ArgInfo -> [ArgInfo] -> [ArgInfo]
    forall a. a -> [a] -> [a]
    : [ArgInfo]
    as) CpeApp
    tick_fun Floats
    floats [Demand]
    ss [CoreTickish]
    rt_ticks Int
    req_depth

          CpeApp (Type Type
    arg_ty)
            -> CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as (CpeApp -> CpeApp -> CpeApp
    forall b. Expr b -> Expr b -> Expr b
    App CpeApp
    fun' (Type -> CpeApp
    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]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as (CpeApp -> CpeApp -> CpeApp
    forall b. Expr b -> Expr b -> Expr b
    App CpeApp
    fun' (Coercion -> CpeApp
    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 CpeApp
    arg -> do
            let (Demand
    ss1, [Demand]
    ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make
                   = case ([Demand]
    ss, CpeApp -> Bool
    isLazyExpr CpeApp
    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, [])
            (Floats
    fs, CpeApp
    arg') <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeArg CorePrepEnv
    top_env Demand
    ss1 CpeApp
    arg
            CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as (CpeApp -> CpeApp -> CpeApp
    forall b. Expr b -> Expr b -> Expr b
    App CpeApp
    fun' CpeApp
    arg') (Floats
    fs Floats -> Floats -> Floats
    `appendFloats` Floats
    floats) [Demand]
    ss_rest [CoreTickish]
    rt_ticks (Int
    req_depthInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)

          CpeCast Coercion
    co
            -> CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as (CpeApp -> Coercion -> CpeApp
    forall b. Expr b -> Coercion -> Expr b
    Cast CpeApp
    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 (CpeApp, Floats, [CoreTickish])
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    forall a. HasCallStack => Bool -> a -> a
    assert (CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    isProfTick CoreTickish
    tickish) (UniqSM (CpeApp, Floats, [CoreTickish])
     -> UniqSM (CpeApp, Floats, [CoreTickish]))
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    forall a b. (a -> b) -> a -> b
    $
               CorePrepEnv
    -> [ArgInfo]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as CpeApp
    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]
    -> CpeApp
    -> Floats
    -> [Demand]
    -> [CoreTickish]
    -> Int
    -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' CorePrepEnv
    env [ArgInfo]
    as CpeApp
    fun' (Floats -> FloatingBind -> Floats
    addFloat 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 :: CpeApp -> Bool
    isLazyExpr (Cast CpeApp
    e Coercion
    _)              = CpeApp -> Bool
    isLazyExpr CpeApp
    e
    isLazyExpr (Tick CoreTickish
    _ CpeApp
    e)              = CpeApp -> Bool
    isLazyExpr CpeApp
    e
    isLazyExpr (Var Id
    f `App` CpeApp
    _ `App` CpeApp
    _) = Id
    f Id -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    lazyIdKey
    isLazyExpr CpeApp
    _                       = 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 program like,

        data Foo = Foo Addr#

        foo = Foo "turtle"#

    When we go to ANFise this we might think that we want to float the string
    literal like we do any other non-trivial argument. This would look like,

        foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }

    However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)
    wreaks havoc on the CAF annotations that we produce here since we the result
    above is caffy since it is updateable. Ideally at some point in the future we
    would like to just float the literal to the top level as suggested in #11312,

        s = "turtle"#
        foo = Foo s

    However, until then we simply add a special case excluding literals from the
    floating done by cpeArg.
    -}

    -- | Is an argument okay to CPE?
    okCpeArg :: CoreExpr -> Bool
    -- Don't float literals. See Note [ANF-ising literal string arguments].
    okCpeArg :: CpeApp -> Bool
    okCpeArg (Lit Literal
    _) = Bool
    False
    -- Do not eta expand a trivial argument
    okCpeArg CpeApp
    expr    = Bool -> Bool
    not (CpeApp -> Bool
    exprIsTrivial CpeApp
    expr)

    -- This is where we arrange that a non-trivial argument is let-bound
    cpeArg :: CorePrepEnv -> Demand
           -> CoreArg -> UniqSM (Floats, CpeArg)
    cpeArg :: CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeArg CorePrepEnv
    env Demand
    dmd CpeApp
    arg
      = do { (Floats
    floats1, CpeApp
    arg1) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
    cpeRhsE CorePrepEnv
    env CpeApp
    arg     -- arg1 can be a lambda
           ; let arg_ty :: Type
    arg_ty      = (() :: Constraint) => CpeApp -> Type
    CpeApp -> Type
    exprType CpeApp
    arg1
                 is_unlifted :: Bool
    is_unlifted = (() :: Constraint) => Type -> Bool
    Type -> Bool
    isUnliftedType Type
    arg_ty
                 want_float :: Floats -> CpeApp -> Bool
    want_float  = RecFlag -> Demand -> Bool -> Floats -> CpeApp -> Bool
    wantFloatNested RecFlag
    NonRecursive Demand
    dmd Bool
    is_unlifted
           ; (Floats
    floats2, CpeApp
    arg2) <- if Floats -> CpeApp -> Bool
    want_float Floats
    floats1 CpeApp
    arg1
                                then (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats1, CpeApp
    arg1)
                                else Floats -> CpeApp -> UniqSM (Floats, CpeApp)
    dontFloat Floats
    floats1 CpeApp
    arg1
                    -- Else case: arg1 might have lambdas, and we can't
                    --            put them inside a wrapBinds

           ; if CpeApp -> Bool
    okCpeArg CpeApp
    arg2
             then do { Id
    v <- Type -> UniqSM Id
    newVar Type
    arg_ty
                     ; let arg3 :: CpeApp
    arg3      = Int -> CpeApp -> CpeApp
    cpeEtaExpand (CpeApp -> Int
    exprArity CpeApp
    arg2) CpeApp
    arg2
                           arg_float :: FloatingBind
    arg_float = CorePrepEnv -> Demand -> Bool -> Id -> CpeApp -> FloatingBind
    mkFloat CorePrepEnv
    env Demand
    dmd Bool
    is_unlifted Id
    v CpeApp
    arg3
                     ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats -> FloatingBind -> Floats
    addFloat Floats
    floats2 FloatingBind
    arg_float, Id -> CpeApp
    forall b. Id -> Expr b
    varToCoreExpr Id
    v) }
             else (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Floats
    floats2, CpeApp
    arg2)
           }

    {-
    Note [Floating unlifted arguments]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider    C (let v* = expensive in v)

    where the "*" indicates "will be demanded".  Usually v will have been
    inlined by now, but let's suppose it hasn't (see #2756).  Then we
    do *not* want to get

         let v* = expensive in C v

    because that has different strictness.  Hence the use of 'allLazy'.
    (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)

    ------------------------------------------------------------------------------
    -- Building the saturated syntax
    -- ---------------------------------------------------------------------------

    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.
    -}

    maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs
    maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeApp
    maybeSaturate Id
    fn CpeApp
    expr Int
    n_args [CoreTickish]
    unsat_ticks
      | Id -> Bool
    hasNoBinding Id
    fn        -- There's no binding
      = CpeApp -> UniqSM CpeApp
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CpeApp -> UniqSM CpeApp) -> CpeApp -> UniqSM CpeApp
    forall a b. (a -> b) -> a -> b
    $ (CpeApp -> CpeApp) -> CpeApp -> CpeApp
    wrapLamBody (\CpeApp
    body -> (CoreTickish -> CpeApp -> CpeApp)
    -> CpeApp -> [CoreTickish] -> CpeApp
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr CoreTickish -> CpeApp -> CpeApp
    mkTick CpeApp
    body [CoreTickish]
    unsat_ticks) CpeApp
    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 CpeApp -> UniqSM CpeApp
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr
          ( Bool -> Bool
    not (Id -> Bool
    isJoinId Id
    fn)) -- See Note [Do not eta-expand join points]
          ( Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    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
    <+> CpeApp -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CpeApp
    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 (Id -> Maybe [CbvMark]
    idCbvMarks_maybe Id
    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
    <+> Maybe Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Maybe Int
    isJoinId_maybe Id
    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 CpeApp -> UniqSM CpeApp) -> UniqSM CpeApp -> UniqSM CpeApp
    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
        --    ) $
        CpeApp -> UniqSM CpeApp
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CpeApp
    sat_expr

      | Bool
    otherwise
      = Bool -> UniqSM CpeApp -> UniqSM CpeApp
    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 CpeApp -> UniqSM CpeApp) -> UniqSM CpeApp -> UniqSM CpeApp
    forall a b. (a -> b) -> a -> b
    $
        CpeApp -> UniqSM CpeApp
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CpeApp
    expr
      where
        mark_arity :: Int
    mark_arity    = Id -> Int
    idCbvMarkArity Id
    fn
        fn_arity :: Int
    fn_arity      = Id -> Int
    idArity Id
    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 :: CpeApp
    sat_expr      = Int -> CpeApp -> CpeApp
    cpeEtaExpand Int
    excess_arity CpeApp
    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
    $ (Id -> Maybe [CbvMark]
    idCbvMarks_maybe Id
    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..
    {-
    ************************************************************************
    *                                                                      *
                    Simple GHC.Core operations
    *                                                                      *
    ************************************************************************
    -}

    {-
    -- -----------------------------------------------------------------------------
    --      Eta reduction
    -- -----------------------------------------------------------------------------

    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 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

    -}

    cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
    cpeEtaExpand :: Int -> CpeApp -> CpeApp
    cpeEtaExpand Int
    arity CpeApp
    expr
      | Int
    arity Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 = CpeApp
    expr
      | Bool
    otherwise  = Int -> CpeApp -> CpeApp
    etaExpand Int
    arity CpeApp
    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'

    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.

    However, 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.
    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.
    -}

    data FloatingBind
      = FloatLet CoreBind    -- Rhs of bindings are CpeRhss
                             -- They are always of lifted type;
                             -- unlifted ones are done with FloatCase

     | FloatCase
          CpeBody         -- Always ok-for-speculation
          Id              -- Case binder
          AltCon [Var]    -- Single alternative
          Bool            -- Ok-for-speculation; False of a strict,
                          -- but lifted binding

     -- | See Note [Floating Ticks in CorePrep]
     | FloatTick CoreTickish

    data Floats = Floats OkToSpec (OrdList FloatingBind)

    instance Outputable FloatingBind where
      ppr :: FloatingBind -> SDoc
    ppr (FloatLet CoreBind
    b) = CoreBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreBind
    b
      ppr (FloatCase CpeApp
    r Id
    b AltCon
    k [Id]
    bs Bool
    ok) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "case" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces (Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Bool
    ok) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CpeApp -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CpeApp
    r
                                    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
    <+> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    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 [Id]
    bs of
                                       [] -> AltCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr AltCon
    k
                                       [Id]
    _  -> 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
    <+> [Id] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Id]
    bs)
      ppr (FloatTick CoreTickish
    t) = CoreTickish -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreTickish
    t

    instance Outputable Floats where
      ppr :: Floats -> SDoc
    ppr (Floats OkToSpec
    flag OrdList FloatingBind
    fs) = 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 (OkToSpec -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr OkToSpec
    flag) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
                             SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ((FloatingBind -> SDoc) -> [FloatingBind] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map FloatingBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (OrdList FloatingBind -> [FloatingBind]
    forall a. OrdList a -> [a]
    fromOL OrdList FloatingBind
    fs)))

    instance Outputable OkToSpec where
      ppr :: OkToSpec -> SDoc
    ppr OkToSpec
    OkToSpec    = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "OkToSpec"
      ppr OkToSpec
    IfUnboxedOk = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "IfUnboxedOk"
      ppr OkToSpec
    NotOkToSpec = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "NotOkToSpec"

    -- Can we float these binds out of the rhs of a let?  We cache this decision
    -- to avoid having to recompute it in a non-linear way when there are
    -- deeply nested lets.
    data OkToSpec
       = OkToSpec           -- Lazy bindings of lifted type
       | IfUnboxedOk        -- A mixture of lazy lifted bindings and n
                            -- ok-to-speculate unlifted bindings
       | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings

    mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
    mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeApp -> FloatingBind
    mkFloat CorePrepEnv
    env Demand
    dmd Bool
    is_unlifted Id
    bndr CpeApp
    rhs
      | Bool
    is_strict Bool -> Bool -> Bool
    || Bool
    ok_for_spec -- See Note [Speculative evaluation]
      , Bool -> Bool
    not Bool
    is_hnf  = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
    FloatCase CpeApp
    rhs Id
    bndr AltCon
    DEFAULT [] Bool
    ok_for_spec
        -- Don't make a case for a HNF binding, even if it's strict
        -- Otherwise we get  case (\x -> e) of ...!

      | Bool
    is_unlifted = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
    FloatCase CpeApp
    rhs Id
    bndr AltCon
    DEFAULT [] Bool
    True
          -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled
          -- because exprOkForSpeculation isn't stable under ANF-ing. See for
          -- example #19489 where the following unlifted expression:
          --
          --    GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0]
          --                    (GHC.Types.: @a_ax0 a2_agq a3_agl)
          --
          -- is ok-for-spec but is ANF-ised into:
          --
          --    let sat = GHC.Types.: @a_ax0 a2_agq a3_agl
          --    in GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0] sat
          --
          -- which isn't ok-for-spec because of the let-expression.

      | Bool
    is_hnf      = CoreBind -> FloatingBind
    FloatLet (Id -> CpeApp -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    bndr                       CpeApp
    rhs)
      | Bool
    otherwise   = CoreBind -> FloatingBind
    FloatLet (Id -> CpeApp -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec (Id -> Demand -> Id
    setIdDemandInfo Id
    bndr Demand
    dmd) CpeApp
    rhs)
                       -- See Note [Pin demand info on floats]
      where
        is_hnf :: Bool
    is_hnf      = CpeApp -> Bool
    exprIsHNF CpeApp
    rhs
        is_strict :: Bool
    is_strict   = Demand -> Bool
    isStrUsedDmd Demand
    dmd
        ok_for_spec :: Bool
    ok_for_spec = (Id -> Bool) -> CpeApp -> Bool
    exprOkForSpecEval (Bool -> Bool
    not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> Bool
    is_rec_call) CpeApp
    rhs
        is_rec_call :: Id -> Bool
    is_rec_call = (Id -> UnVarSet -> Bool
    `elemUnVarSet` CorePrepEnv -> UnVarSet
    cpe_rec_ids CorePrepEnv
    env)

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

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

    wrapBinds :: Floats -> CpeBody -> CpeBody
    wrapBinds :: Floats -> CpeApp -> CpeApp
    wrapBinds (Floats OkToSpec
    _ OrdList FloatingBind
    binds) CpeApp
    body
      = (FloatingBind -> CpeApp -> CpeApp)
    -> CpeApp -> OrdList FloatingBind -> CpeApp
    forall a b. (a -> b -> b) -> b -> OrdList a -> b
    foldrOL FloatingBind -> CpeApp -> CpeApp
    mk_bind CpeApp
    body OrdList FloatingBind
    binds
      where
        mk_bind :: FloatingBind -> CpeApp -> CpeApp
    mk_bind (FloatCase CpeApp
    rhs Id
    bndr AltCon
    con [Id]
    bs Bool
    _) CpeApp
    body = CpeApp -> Id -> Type -> [Alt Id] -> CpeApp
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CpeApp
    rhs Id
    bndr ((() :: Constraint) => CpeApp -> Type
    CpeApp -> Type
    exprType CpeApp
    body) [AltCon -> [Id] -> CpeApp -> Alt Id
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    con [Id]
    bs CpeApp
    body]
        mk_bind (FloatLet CoreBind
    bind)               CpeApp
    body = CoreBind -> CpeApp -> CpeApp
    forall b. Bind b -> Expr b -> Expr b
    Let CoreBind
    bind CpeApp
    body
        mk_bind (FloatTick CoreTickish
    tickish)           CpeApp
    body = CoreTickish -> CpeApp -> CpeApp
    mkTick CoreTickish
    tickish CpeApp
    body

    addFloat :: Floats -> FloatingBind -> Floats
    addFloat :: Floats -> FloatingBind -> Floats
    addFloat (Floats OkToSpec
    ok_to_spec OrdList FloatingBind
    floats) FloatingBind
    new_float
      = OkToSpec -> OrdList FloatingBind -> Floats
    Floats (OkToSpec -> OkToSpec -> OkToSpec
    combine OkToSpec
    ok_to_spec (FloatingBind -> OkToSpec
    check FloatingBind
    new_float)) (OrdList FloatingBind
    floats OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> a -> OrdList a
    `snocOL` FloatingBind
    new_float)
      where
        check :: FloatingBind -> OkToSpec
    check (FloatLet {})  = OkToSpec
    OkToSpec
        check (FloatCase CpeApp
    _ Id
    _ AltCon
    _ [Id]
    _ Bool
    ok_for_spec)
          | Bool
    ok_for_spec = OkToSpec
    IfUnboxedOk
          | Bool
    otherwise   = OkToSpec
    NotOkToSpec
        check FloatTick{}    = OkToSpec
    OkToSpec
            -- The ok-for-speculation flag says that it's safe to
            -- float this Case out of a let, and thereby do it more eagerly
            -- We need the top-level flag because it's never ok to float
            -- an unboxed binding to the top level

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

    appendFloats :: Floats -> Floats -> Floats
    appendFloats :: Floats -> Floats -> Floats
    appendFloats (Floats OkToSpec
    spec1 OrdList FloatingBind
    floats1) (Floats OkToSpec
    spec2 OrdList FloatingBind
    floats2)
      = OkToSpec -> OrdList FloatingBind -> Floats
    Floats (OkToSpec -> OkToSpec -> OkToSpec
    combine OkToSpec
    spec1 OkToSpec
    spec2) (OrdList FloatingBind
    floats1 OrdList FloatingBind
    -> OrdList FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList FloatingBind
    floats2)

    concatFloats :: [Floats] -> OrdList FloatingBind
    concatFloats :: [Floats] -> OrdList FloatingBind
    concatFloats = (Floats -> OrdList FloatingBind -> OrdList FloatingBind)
    -> OrdList FloatingBind -> [Floats] -> OrdList FloatingBind
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\ (Floats OkToSpec
    _ OrdList FloatingBind
    bs1) OrdList FloatingBind
    bs2 -> OrdList FloatingBind
    -> OrdList FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> OrdList a -> OrdList a
    appOL OrdList FloatingBind
    bs1 OrdList FloatingBind
    bs2) OrdList FloatingBind
    forall a. OrdList a
    nilOL

    combine :: OkToSpec -> OkToSpec -> OkToSpec
    combine :: OkToSpec -> OkToSpec -> OkToSpec
    combine OkToSpec
    NotOkToSpec OkToSpec
    _ = OkToSpec
    NotOkToSpec
    combine OkToSpec
    _ OkToSpec
    NotOkToSpec = OkToSpec
    NotOkToSpec
    combine OkToSpec
    IfUnboxedOk OkToSpec
    _ = OkToSpec
    IfUnboxedOk
    combine OkToSpec
    _ OkToSpec
    IfUnboxedOk = OkToSpec
    IfUnboxedOk
    combine OkToSpec
    _ OkToSpec
    _           = OkToSpec
    OkToSpec

    deFloatTop :: Floats -> [CoreBind]
    -- For top level only; we don't expect any FloatCases
    deFloatTop :: Floats -> CoreProgram
    deFloatTop (Floats OkToSpec
    _ OrdList FloatingBind
    floats)
      = (FloatingBind -> CoreProgram -> CoreProgram)
    -> CoreProgram -> OrdList FloatingBind -> CoreProgram
    forall a b. (a -> b -> b) -> b -> OrdList a -> b
    foldrOL FloatingBind -> CoreProgram -> CoreProgram
    get [] OrdList FloatingBind
    floats
      where
        get :: FloatingBind -> CoreProgram -> CoreProgram
    get (FloatLet CoreBind
    b)               CoreProgram
    bs = CoreBind -> CoreBind
    get_bind CoreBind
    b                 CoreBind -> CoreProgram -> CoreProgram
    forall a. a -> [a] -> [a]
    : CoreProgram
    bs
        get (FloatCase CpeApp
    body Id
    var AltCon
    _ [Id]
    _ Bool
    _) CoreProgram
    bs = CoreBind -> CoreBind
    get_bind (Id -> CpeApp -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    var CpeApp
    body) 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 Id
    x CpeApp
    e) = Id -> CpeApp -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    x (CpeApp -> CpeApp
    occurAnalyseExpr CpeApp
    e)
        get_bind (Rec [(Id, CpeApp)]
    xes)    = [(Id, CpeApp)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec [(Id
    x, CpeApp -> CpeApp
    occurAnalyseExpr CpeApp
    e) | (Id
    x, CpeApp
    e) <- [(Id, CpeApp)]
    xes]

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

    canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
    canFloat :: Floats -> CpeApp -> Maybe (Floats, CpeApp)
    canFloat (Floats OkToSpec
    ok_to_spec OrdList FloatingBind
    fs) CpeApp
    rhs
      | OkToSpec
    OkToSpec <- OkToSpec
    ok_to_spec           -- Worth trying
      , Just OrdList FloatingBind
    fs' <- OrdList FloatingBind
    -> [FloatingBind] -> Maybe (OrdList FloatingBind)
    go OrdList FloatingBind
    forall a. OrdList a
    nilOL (OrdList FloatingBind -> [FloatingBind]
    forall a. OrdList a -> [a]
    fromOL OrdList FloatingBind
    fs)
      = (Floats, CpeApp) -> Maybe (Floats, CpeApp)
    forall a. a -> Maybe a
    Just (OkToSpec -> OrdList FloatingBind -> Floats
    Floats OkToSpec
    OkToSpec OrdList FloatingBind
    fs', CpeApp
    rhs)
      | Bool
    otherwise
      = Maybe (Floats, CpeApp)
    forall a. Maybe a
    Nothing
      where
        go :: OrdList FloatingBind -> [FloatingBind]
           -> Maybe (OrdList FloatingBind)

        go :: OrdList FloatingBind
    -> [FloatingBind] -> Maybe (OrdList FloatingBind)
    go (OrdList FloatingBind
    fbs_out) [] = OrdList FloatingBind -> Maybe (OrdList FloatingBind)
    forall a. a -> Maybe a
    Just OrdList FloatingBind
    fbs_out

        go OrdList FloatingBind
    fbs_out (fb :: FloatingBind
    fb@(FloatLet CoreBind
    _) : [FloatingBind]
    fbs_in)
          = OrdList FloatingBind
    -> [FloatingBind] -> Maybe (OrdList FloatingBind)
    go (OrdList FloatingBind
    fbs_out OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> a -> OrdList a
    `snocOL` FloatingBind
    fb) [FloatingBind]
    fbs_in

        go OrdList FloatingBind
    fbs_out (ft :: FloatingBind
    ft@FloatTick{} : [FloatingBind]
    fbs_in)
          = OrdList FloatingBind
    -> [FloatingBind] -> Maybe (OrdList FloatingBind)
    go (OrdList FloatingBind
    fbs_out OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
    forall a. OrdList a -> a -> OrdList a
    `snocOL` FloatingBind
    ft) [FloatingBind]
    fbs_in

        go OrdList FloatingBind
    _ (FloatCase{} : [FloatingBind]
    _) = Maybe (OrdList FloatingBind)
    forall a. Maybe a
    Nothing

    wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
    wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeApp -> Bool
    wantFloatNested RecFlag
    is_rec Demand
    dmd Bool
    is_unlifted Floats
    floats CpeApp
    rhs
      =  Floats -> Bool
    isEmptyFloats Floats
    floats
      Bool -> Bool -> Bool
    || Demand -> Bool
    isStrUsedDmd Demand
    dmd
      Bool -> Bool -> Bool
    || Bool
    is_unlifted
      Bool -> Bool -> Bool
    || (RecFlag -> Floats -> Bool
    allLazyNested RecFlag
    is_rec Floats
    floats Bool -> Bool -> Bool
    && CpeApp -> Bool
    exprIsHNF CpeApp
    rhs)
            -- Why the test for allLazyNested?
            --      v = f (x `divInt#` y)
            -- we don't want to float the case, even if f has arity 2,
            -- because floating the case would make it evaluated too early

    allLazyTop :: Floats -> Bool
    allLazyTop :: Floats -> Bool
    allLazyTop (Floats OkToSpec
    OkToSpec OrdList FloatingBind
    _) = Bool
    True
    allLazyTop Floats
    _                   = Bool
    False

    allLazyNested :: RecFlag -> Floats -> Bool
    allLazyNested :: RecFlag -> Floats -> Bool
    allLazyNested RecFlag
    _      (Floats OkToSpec
    OkToSpec    OrdList FloatingBind
    _) = Bool
    True
    allLazyNested RecFlag
    _      (Floats OkToSpec
    NotOkToSpec OrdList FloatingBind
    _) = Bool
    False
    allLazyNested RecFlag
    is_rec (Floats OkToSpec
    IfUnboxedOk OrdList FloatingBind
    _) = RecFlag -> Bool
    isNonRec RecFlag
    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]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    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 -> LitNumType -> Integer -> Maybe CpeApp
    cp_convertNumLit           :: !(LitNumType -> Integer -> Maybe CoreExpr)
      -- ^ Convert some numeric literals (Integer, Natural) into their final
      -- Core form.
      }

    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 -> IdEnv CpeApp
    cpe_env             :: IdEnv CoreExpr   -- Clone local Ids
            -- ^ This environment is used for three operations:
            --
            --      1. To support cloning of local Ids so that they are
            --      all unique (see item (6) of CorePrep overview).
            --
            --      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)

            , CorePrepEnv -> Maybe CpeTyCoEnv
    cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv]

            , 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_env :: IdEnv CpeApp
    cpe_env           = IdEnv CpeApp
    forall a. VarEnv a
    emptyVarEnv
          , cpe_tyco_env :: Maybe CpeTyCoEnv
    cpe_tyco_env      = Maybe CpeTyCoEnv
    forall a. Maybe a
    Nothing
          , cpe_rec_ids :: UnVarSet
    cpe_rec_ids       = UnVarSet
    emptyUnVarSet
          }

    extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
    extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
    extendCorePrepEnv CorePrepEnv
    cpe Id
    id Id
    id'
        = CorePrepEnv
    cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }

    extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
    extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CpeApp -> CorePrepEnv
    extendCorePrepEnvExpr CorePrepEnv
    cpe Id
    id CpeApp
    expr
        = CorePrepEnv
    cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }

    extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
    extendCorePrepEnvList :: CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
    extendCorePrepEnvList CorePrepEnv
    cpe [(Id, Id)]
    prs
        = CorePrepEnv
    cpe { cpe_env = extendVarEnvList (cpe_env cpe)
                            (map (\(Id
    id, Id
    id') -> (Id
    id, Id -> CpeApp
    forall b. Id -> Expr b
    Var Id
    id')) prs) }

    lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
    lookupCorePrepEnv :: CorePrepEnv -> Id -> CpeApp
    lookupCorePrepEnv CorePrepEnv
    cpe Id
    id
      = case IdEnv CpeApp -> Id -> Maybe CpeApp
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv (CorePrepEnv -> IdEnv CpeApp
    cpe_env CorePrepEnv
    cpe) Id
    id of
            Maybe CpeApp
    Nothing  -> Id -> CpeApp
    forall b. Id -> Expr b
    Var Id
    id
            Just CpeApp
    exp -> CpeApp
    exp

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

    ------------------------------------------------------------------------------
    --           CpeTyCoEnv
    -- ---------------------------------------------------------------------------

    {- Note [CpeTyCoEnv]
    ~~~~~~~~~~~~~~~~~~~~
    The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution
    for type and coercion variables

    * We need the coercion substitution to support the elimination of
      unsafeEqualityProof (see Note [Unsafe coercions])

    * We need the type substitution in case one of those unsafe
      coercions occurs in the kind of tyvar binder (sigh)

    We don't need an in-scope set because we don't clone any of these
    binders at all, so no new capture can take place.

    The cpe_tyco_env is almost always empty -- it only gets populated
    when we get under an usafeEqualityProof.  Hence the Maybe CpeTyCoEnv,
    which makes everything into a no-op in the common case.
    -}

    data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv

    emptyTCE :: CpeTyCoEnv
    emptyTCE :: CpeTyCoEnv
    emptyTCE = TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
    TCE TvSubstEnv
    emptyTvSubstEnv CvSubstEnv
    emptyCvSubstEnv

    extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv
    extend_tce_cv :: CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
    extend_tce_cv (TCE TvSubstEnv
    tv_env CvSubstEnv
    cv_env) Id
    cv Coercion
    co
      = TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
    TCE TvSubstEnv
    tv_env (CvSubstEnv -> Id -> Coercion -> CvSubstEnv
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv CvSubstEnv
    cv_env Id
    cv Coercion
    co)

    extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv
    extend_tce_tv :: CpeTyCoEnv -> Id -> Type -> CpeTyCoEnv
    extend_tce_tv (TCE TvSubstEnv
    tv_env CvSubstEnv
    cv_env) Id
    tv Type
    ty
      = TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
    TCE (TvSubstEnv -> Id -> Type -> TvSubstEnv
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv TvSubstEnv
    tv_env Id
    tv Type
    ty) CvSubstEnv
    cv_env

    lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion
    lookup_tce_cv :: CpeTyCoEnv -> Id -> Coercion
    lookup_tce_cv (TCE TvSubstEnv
    _ CvSubstEnv
    cv_env) Id
    cv
      = case CvSubstEnv -> Id -> Maybe Coercion
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv CvSubstEnv
    cv_env Id
    cv of
            Just Coercion
    co -> Coercion
    co
            Maybe Coercion
    Nothing -> Id -> Coercion
    mkCoVarCo Id
    cv

    lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type
    lookup_tce_tv :: CpeTyCoEnv -> Id -> Type
    lookup_tce_tv (TCE TvSubstEnv
    tv_env CvSubstEnv
    _) Id
    tv
      = case TvSubstEnv -> Id -> Maybe Type
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv TvSubstEnv
    tv_env Id
    tv of
            Just Type
    ty -> Type
    ty
            Maybe Type
    Nothing -> Id -> Type
    mkTyVarTy Id
    tv

    extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv
    extendCoVarEnv :: CorePrepEnv -> Id -> Coercion -> CorePrepEnv
    extendCoVarEnv cpe :: CorePrepEnv
    cpe@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
    cpe_tyco_env = Maybe CpeTyCoEnv
    mb_tce }) Id
    cv Coercion
    co
      = CorePrepEnv
    cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) }
      where
        tce :: CpeTyCoEnv
    tce = Maybe CpeTyCoEnv
    mb_tce Maybe CpeTyCoEnv -> CpeTyCoEnv -> CpeTyCoEnv
    forall a. Maybe a -> a -> a
    `orElse` CpeTyCoEnv
    emptyTCE

    cpSubstTy :: CorePrepEnv -> Type -> Type
    cpSubstTy :: CorePrepEnv -> Type -> Type
    cpSubstTy (CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
    cpe_tyco_env = Maybe CpeTyCoEnv
    mb_env }) Type
    ty
      = case Maybe CpeTyCoEnv
    mb_env of
          Just CpeTyCoEnv
    env -> Identity Type -> Type
    forall a. Identity a -> a
    runIdentity (CpeTyCoEnv -> Type -> Identity Type
    subst_ty CpeTyCoEnv
    env Type
    ty)
          Maybe CpeTyCoEnv
    Nothing  -> Type
    ty

    cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
    cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
    cpSubstCo (CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
    cpe_tyco_env = Maybe CpeTyCoEnv
    mb_env }) Coercion
    co
      = case Maybe CpeTyCoEnv
    mb_env of
          Just CpeTyCoEnv
    tce -> Identity Coercion -> Coercion
    forall a. Identity a -> a
    runIdentity (CpeTyCoEnv -> Coercion -> Identity Coercion
    subst_co CpeTyCoEnv
    tce Coercion
    co)
          Maybe CpeTyCoEnv
    Nothing  -> Coercion
    co

    subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
    subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
    subst_tyco_mapper = TyCoMapper
      { tcm_tyvar :: CpeTyCoEnv -> Id -> Identity Type
    tcm_tyvar      = \CpeTyCoEnv
    env Id
    tv -> Type -> Identity Type
    forall a. a -> Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CpeTyCoEnv -> Id -> Type
    lookup_tce_tv CpeTyCoEnv
    env Id
    tv)
      , tcm_covar :: CpeTyCoEnv -> Id -> Identity Coercion
    tcm_covar      = \CpeTyCoEnv
    env Id
    cv -> Coercion -> Identity Coercion
    forall a. a -> Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CpeTyCoEnv -> Id -> Coercion
    lookup_tce_cv CpeTyCoEnv
    env Id
    cv)
      , tcm_hole :: CpeTyCoEnv -> CoercionHole -> Identity Coercion
    tcm_hole       = \CpeTyCoEnv
    _ CoercionHole
    hole -> String -> SDoc -> Identity Coercion
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "subst_co_mapper:hole" (CoercionHole -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoercionHole
    hole)
      , tcm_tycobinder :: CpeTyCoEnv -> Id -> ForAllTyFlag -> Identity (CpeTyCoEnv, Id)
    tcm_tycobinder = \CpeTyCoEnv
    env Id
    tcv ForAllTyFlag
    _vis -> if Id -> Bool
    isTyVar Id
    tcv
                                          then (CpeTyCoEnv, Id) -> Identity (CpeTyCoEnv, Id)
    forall a. a -> Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
    subst_tv_bndr CpeTyCoEnv
    env Id
    tcv)
                                          else (CpeTyCoEnv, Id) -> Identity (CpeTyCoEnv, Id)
    forall a. a -> Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
    subst_cv_bndr CpeTyCoEnv
    env Id
    tcv)
      , tcm_tycon :: TyCon -> Identity TyCon
    tcm_tycon      = \TyCon
    tc -> TyCon -> Identity TyCon
    forall a. a -> Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TyCon
    tc }

    subst_ty :: CpeTyCoEnv -> Type     -> Identity Type
    subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion
    (CpeTyCoEnv -> Type -> Identity Type
    subst_ty, CpeTyCoEnv -> [Type] -> Identity [Type]
    _, CpeTyCoEnv -> Coercion -> Identity Coercion
    subst_co, CpeTyCoEnv -> [Coercion] -> Identity [Coercion]
    _) = TyCoMapper CpeTyCoEnv Identity
    -> (CpeTyCoEnv -> Type -> Identity Type,
        CpeTyCoEnv -> [Type] -> Identity [Type],
        CpeTyCoEnv -> Coercion -> Identity Coercion,
        CpeTyCoEnv -> [Coercion] -> Identity [Coercion])
    forall (m :: * -> *) env.
    Monad m =>
    TyCoMapper env m
    -> (env -> Type -> m Type, env -> [Type] -> m [Type],
        env -> Coercion -> m Coercion, env -> [Coercion] -> m [Coercion])
    mapTyCoX TyCoMapper CpeTyCoEnv Identity
    subst_tyco_mapper

    cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar)
    cpSubstTyVarBndr :: CorePrepEnv -> Id -> (CorePrepEnv, Id)
    cpSubstTyVarBndr env :: CorePrepEnv
    env@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
    cpe_tyco_env = Maybe CpeTyCoEnv
    mb_env }) Id
    tv
      = case Maybe CpeTyCoEnv
    mb_env of
          Maybe CpeTyCoEnv
    Nothing  -> (CorePrepEnv
    env, Id
    tv)
          Just CpeTyCoEnv
    tce -> (CorePrepEnv
    env { cpe_tyco_env = Just tce' }, Id
    tv')
                   where
                      (CpeTyCoEnv
    tce', Id
    tv') = CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
    subst_tv_bndr CpeTyCoEnv
    tce Id
    tv

    subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)
    subst_tv_bndr :: CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
    subst_tv_bndr CpeTyCoEnv
    tce Id
    tv
      = (CpeTyCoEnv -> Id -> Type -> CpeTyCoEnv
    extend_tce_tv CpeTyCoEnv
    tce Id
    tv (Id -> Type
    mkTyVarTy Id
    tv'), Id
    tv')
      where
        tv' :: Id
    tv'   = Name -> Type -> Id
    mkTyVar (Id -> Name
    tyVarName Id
    tv) Type
    kind'
        kind' :: Type
    kind' = Identity Type -> Type
    forall a. Identity a -> a
    runIdentity (Identity Type -> Type) -> Identity Type -> Type
    forall a b. (a -> b) -> a -> b
    $ CpeTyCoEnv -> Type -> Identity Type
    subst_ty CpeTyCoEnv
    tce (Type -> Identity Type) -> Type -> Identity Type
    forall a b. (a -> b) -> a -> b
    $ Id -> Type
    tyVarKind Id
    tv

    cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)
    cpSubstCoVarBndr :: CorePrepEnv -> Id -> (CorePrepEnv, Id)
    cpSubstCoVarBndr env :: CorePrepEnv
    env@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
    cpe_tyco_env = Maybe CpeTyCoEnv
    mb_env }) Id
    cv
      = case Maybe CpeTyCoEnv
    mb_env of
          Maybe CpeTyCoEnv
    Nothing  -> (CorePrepEnv
    env, Id
    cv)
          Just CpeTyCoEnv
    tce -> (CorePrepEnv
    env { cpe_tyco_env = Just tce' }, Id
    cv')
                   where
                      (CpeTyCoEnv
    tce', Id
    cv') = CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
    subst_cv_bndr CpeTyCoEnv
    tce Id
    cv

    subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)
    subst_cv_bndr :: CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
    subst_cv_bndr CpeTyCoEnv
    tce Id
    cv
      = (CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
    extend_tce_cv CpeTyCoEnv
    tce Id
    cv (Id -> Coercion
    mkCoVarCo Id
    cv'), Id
    cv')
      where
        cv' :: Id
    cv' = Name -> Type -> Id
    mkCoVar (Id -> Name
    varName Id
    cv) Type
    ty'
        ty' :: Type
    ty' = Identity Type -> Type
    forall a. Identity a -> a
    runIdentity (CpeTyCoEnv -> Type -> Identity Type
    subst_ty CpeTyCoEnv
    tce (Type -> Identity Type) -> Type -> Identity Type
    forall a b. (a -> b) -> a -> b
    $ Id -> Type
    varType Id
    cv)

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

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

    cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
    cpCloneBndr :: CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
    cpCloneBndr CorePrepEnv
    env Id
    bndr
      | Id -> Bool
    isTyVar Id
    bndr
      = (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv -> Id -> (CorePrepEnv, Id)
    cpSubstTyVarBndr CorePrepEnv
    env Id
    bndr)

      | Id -> Bool
    isCoVar Id
    bndr
      = (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv -> Id -> (CorePrepEnv, Id)
    cpSubstCoVarBndr CorePrepEnv
    env Id
    bndr)

      | Bool
    otherwise
      = do { Id
    bndr' <- Id -> UniqSM Id
    clone_it Id
    bndr

           -- 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' = Unfolding -> Unfolding
    trimUnfolding (Id -> Unfolding
    realIdUnfolding Id
    bndr)
                              -- Simplifier will set the Id's unfolding

                 bndr'' :: Id
    bndr'' = Id
    bndr' Id -> Unfolding -> Id
    `setIdUnfolding`      Unfolding
    unfolding'
                                Id -> RuleInfo -> Id
    `setIdSpecialisation` RuleInfo
    emptyRuleInfo

           ; (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CorePrepEnv -> Id -> Id -> CorePrepEnv
    extendCorePrepEnv CorePrepEnv
    env Id
    bndr Id
    bndr'', Id
    bndr'') }
      where
        clone_it :: Id -> UniqSM Id
    clone_it Id
    bndr
          | Id -> Bool
    isLocalId Id
    bndr
          = do { Unique
    uniq <- UniqSM Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
               ; let ty' :: Type
    ty' = CorePrepEnv -> Type -> Type
    cpSubstTy CorePrepEnv
    env (Id -> Type
    idType Id
    bndr)
               ; Id -> UniqSM Id
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> Unique -> Id
    setVarUnique (Id -> Type -> Id
    setIdType Id
    bndr Type
    ty') Unique
    uniq) }

          | Bool
    otherwise   -- Top level things, which we don't want
                        -- to clone, have become GlobalIds by now
          = Id -> UniqSM Id
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Id
    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 :: Id -> UniqSM Id
    fiddleCCall Id
    id
      | Id -> Bool
    isFCallId Id
    id = (Id
    id Id -> Unique -> Id
    `setVarUnique`) (Unique -> Id) -> UniqSM Unique -> UniqSM Id
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UniqSM Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
      | Bool
    otherwise    = Id -> UniqSM Id
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Id
    id

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

    newVar :: Type -> UniqSM Id
    newVar :: Type -> UniqSM Id
    newVar Type
    ty
     = Type -> ()
    seqType Type
    ty () -> UniqSM Id -> UniqSM Id
    forall a b. a -> b -> b
    `seq` FastString -> Type -> Type -> UniqSM Id
    forall (m :: * -> *).
    MonadUnique m =>
    FastString -> Type -> Type -> m Id
    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 -> CpeApp -> (Floats, CpeApp)
    wrapTicks (Floats OkToSpec
    flag OrdList FloatingBind
    floats0) CpeApp
    expr =
        (OkToSpec -> OrdList FloatingBind -> Floats
    Floats OkToSpec
    flag ([FloatingBind] -> OrdList FloatingBind
    forall a. [a] -> OrdList a
    toOL ([FloatingBind] -> OrdList FloatingBind)
    -> [FloatingBind] -> OrdList FloatingBind
    forall a b. (a -> b) -> a -> b
    $ [FloatingBind] -> [FloatingBind]
    forall a. [a] -> [a]
    reverse [FloatingBind]
    floats1), (CoreTickish -> CpeApp -> CpeApp)
    -> CpeApp -> [CoreTickish] -> CpeApp
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr CoreTickish -> CpeApp -> CpeApp
    mkTick CpeApp
    expr ([CoreTickish] -> [CoreTickish]
    forall a. [a] -> [a]
    reverse [CoreTickish]
    ticks1))
      where ([FloatingBind]
    floats1, [CoreTickish]
    ticks1) = (([FloatingBind], [CoreTickish])
     -> FloatingBind -> ([FloatingBind], [CoreTickish]))
    -> ([FloatingBind], [CoreTickish])
    -> OrdList FloatingBind
    -> ([FloatingBind], [CoreTickish])
    forall b a. (b -> a -> b) -> b -> OrdList a -> b
    foldlOL ([FloatingBind], [CoreTickish])
    -> FloatingBind -> ([FloatingBind], [CoreTickish])
    go ([], []) (OrdList FloatingBind -> ([FloatingBind], [CoreTickish]))
    -> OrdList FloatingBind -> ([FloatingBind], [CoreTickish])
    forall a b. (a -> b) -> a -> b
    $ OrdList FloatingBind
    floats0
            -- 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 :: ([FloatingBind], [CoreTickish])
    -> FloatingBind -> ([FloatingBind], [CoreTickish])
    go ([FloatingBind]
    floats, [CoreTickish]
    ticks) (FloatTick CoreTickish
    t)
              = Bool
    -> ([FloatingBind], [CoreTickish])
    -> ([FloatingBind], [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)
                ([FloatingBind]
    floats, if (CoreTickish -> Bool) -> [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) [CoreTickish]
    ticks
                         then [CoreTickish]
    ticks else CoreTickish
    tCoreTickish -> [CoreTickish] -> [CoreTickish]
    forall a. a -> [a] -> [a]
    :[CoreTickish]
    ticks)
            go ([FloatingBind]
    floats, [CoreTickish]
    ticks) FloatingBind
    f
              = ((CoreTickish -> FloatingBind -> FloatingBind)
    -> FloatingBind -> [CoreTickish] -> FloatingBind
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr CoreTickish -> FloatingBind -> FloatingBind
    wrap FloatingBind
    f ([CoreTickish] -> [CoreTickish]
    forall a. [a] -> [a]
    reverse [CoreTickish]
    ticks)FloatingBind -> [FloatingBind] -> [FloatingBind]
    forall a. a -> [a] -> [a]
    :[FloatingBind]
    floats, [CoreTickish]
    ticks)

            wrap :: CoreTickish -> FloatingBind -> FloatingBind
    wrap CoreTickish
    t (FloatLet CoreBind
    bind)           = CoreBind -> FloatingBind
    FloatLet (CoreTickish -> CoreBind -> CoreBind
    wrapBind CoreTickish
    t CoreBind
    bind)
            wrap CoreTickish
    t (FloatCase CpeApp
    r Id
    b AltCon
    con [Id]
    bs Bool
    ok) = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
    FloatCase (CoreTickish -> CpeApp -> CpeApp
    mkTick CoreTickish
    t CpeApp
    r) Id
    b AltCon
    con [Id]
    bs Bool
    ok
            wrap CoreTickish
    _ FloatingBind
    other                     = String -> SDoc -> FloatingBind
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "wrapTicks: unexpected float!"
                                                 (FloatingBind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr FloatingBind
    other)
            wrapBind :: CoreTickish -> CoreBind -> CoreBind
    wrapBind CoreTickish
    t (NonRec Id
    binder CpeApp
    rhs) = Id -> CpeApp -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    binder (CoreTickish -> CpeApp -> CpeApp
    mkTick CoreTickish
    t CpeApp
    rhs)
            wrapBind CoreTickish
    t (Rec [(Id, CpeApp)]
    pairs)         = [(Id, CpeApp)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec ((CpeApp -> CpeApp) -> [(Id, CpeApp)] -> [(Id, CpeApp)]
    forall (f :: * -> *) b c a.
    Functor f =>
    (b -> c) -> f (a, b) -> f (a, c)
    mapSnd (CoreTickish -> CpeApp -> CpeApp
    mkTick CoreTickish
    t) [(Id, CpeApp)]
    pairs)

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

    -- | Create a function that converts Bignum literals into their final CoreExpr
    mkConvertNumLiteral
       :: Platform
       -> HomeUnit
       -> (Name -> IO TyThing)
       -> IO (LitNumType -> Integer -> Maybe CoreExpr)
    mkConvertNumLiteral :: Platform
    -> HomeUnit
    -> (Name -> IO TyThing)
    -> IO (LitNumType -> Integer -> Maybe CpeApp)
    mkConvertNumLiteral Platform
    platform HomeUnit
    home_unit Name -> IO TyThing
    lookup_global = do
       let
          guardBignum :: IO Id -> IO Id
    guardBignum IO Id
    act
             | HomeUnit -> UnitId -> Bool
    isHomeUnitInstanceOf HomeUnit
    home_unit UnitId
    primUnitId
             = Id -> IO Id
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> IO Id) -> Id -> IO Id
    forall a b. (a -> b) -> a -> b
    $ String -> Id
    forall a. HasCallStack => String -> a
    panic String
    "Bignum literals are not supported in ghc-prim"
             | HomeUnit -> UnitId -> Bool
    isHomeUnitInstanceOf HomeUnit
    home_unit UnitId
    bignumUnitId
             = Id -> IO Id
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> IO Id) -> Id -> IO Id
    forall a b. (a -> b) -> a -> b
    $ String -> Id
    forall a. HasCallStack => String -> a
    panic String
    "Bignum literals are not supported in ghc-bignum"
             | Bool
    otherwise = IO Id
    act

          lookupBignumId :: Name -> IO Id
    lookupBignumId Name
    n      = IO Id -> IO Id
    guardBignum ((() :: Constraint) => TyThing -> Id
    TyThing -> Id
    tyThingId (TyThing -> Id) -> IO TyThing -> IO Id
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> IO TyThing
    lookup_global Name
    n)

       -- The lookup is done here but the failure (panic) is reported lazily when we
       -- try to access the `bigNatFromWordList` function.
       --
       -- If we ever get built-in ByteArray# literals, we could avoid the lookup by
       -- directly using the Integer/Natural wired-in constructors for big numbers.

       Id
    bignatFromWordListId <- Name -> IO Id
    lookupBignumId Name
    bignatFromWordListName

       let
          convertNumLit :: LitNumType -> Integer -> Maybe CpeApp
    convertNumLit LitNumType
    nt Integer
    i = case LitNumType
    nt of
             LitNumType
    LitNumBigNat  -> CpeApp -> Maybe CpeApp
    forall a. a -> Maybe a
    Just (Integer -> CpeApp
    convertBignatPrim Integer
    i)
             LitNumType
    _             -> Maybe CpeApp
    forall a. Maybe a
    Nothing

          convertBignatPrim :: Integer -> CpeApp
    convertBignatPrim Integer
    i =
             let
                -- ByteArray# literals aren't supported (yet). Were they supported,
                -- we would use them directly. We would need to handle
                -- wordSize/endianness conversion between host and target
                -- wordSize  = platformWordSize platform
                -- byteOrder = platformByteOrder platform

                -- For now we build a list of Words and we produce
                -- `bigNatFromWordList# list_of_words`

                words :: CpeApp
    words = Type -> [CpeApp] -> CpeApp
    mkListExpr Type
    wordTy ([CpeApp] -> [CpeApp]
    forall a. [a] -> [a]
    reverse ((Integer -> Maybe (CpeApp, Integer)) -> Integer -> [CpeApp]
    forall b a. (b -> Maybe (a, b)) -> b -> [a]
    unfoldr Integer -> Maybe (CpeApp, Integer)
    f Integer
    i))
                   where
                      f :: Integer -> Maybe (CpeApp, Integer)
    f Integer
    0 = Maybe (CpeApp, Integer)
    forall a. Maybe a
    Nothing
                      f Integer
    x = let low :: Integer
    low  = Integer
    x Integer -> Integer -> Integer
    forall a. Bits a => a -> a -> a
    .&. Integer
    mask
                                high :: Integer
    high = Integer
    x Integer -> Int -> Integer
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    bits
                            in (CpeApp, Integer) -> Maybe (CpeApp, Integer)
    forall a. a -> Maybe a
    Just (DataCon -> [CpeApp] -> CpeApp
    forall b. DataCon -> [Arg b] -> Arg b
    mkConApp DataCon
    wordDataCon [Literal -> CpeApp
    forall b. Literal -> Expr b
    Lit (Platform -> Integer -> Literal
    mkLitWord Platform
    platform Integer
    low)], Integer
    high)
                      bits :: Int
    bits = Platform -> Int
    platformWordSizeInBits Platform
    platform
                      mask :: Integer
    mask = Integer
    2 Integer -> Int -> Integer
    forall a b. (Num a, Integral b) => a -> b -> a
    ^ Int
    bits Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    - Integer
    1

             in CpeApp -> [CpeApp] -> CpeApp
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Id -> CpeApp
    forall b. Id -> Expr b
    Var Id
    bignatFromWordListId) [CpeApp
    words]

       (LitNumType -> Integer -> Maybe CpeApp)
    -> IO (LitNumType -> Integer -> Maybe CpeApp)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LitNumType -> Integer -> Maybe CpeApp
    convertNumLit