    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE TypeFamilies #-}

    --
    -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
    --

    --------------------------------------------------------------
    -- Converting Core to STG Syntax
    --------------------------------------------------------------

    -- And, as we have the info in hand, we may convert some lets to
    -- let-no-escapes.

    module GHC.CoreToStg ( coreToStg ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Core
    import GHC.Core.Utils   ( exprType, findDefault, isJoinBind
                            , exprIsTickedString_maybe )
    import GHC.Core.Opt.Arity   ( manifestArity )
    import GHC.Stg.Syntax
    import GHC.Stg.Debug

    import GHC.Core.Type
    import GHC.Types.RepType
    import GHC.Core.TyCon
    import GHC.Types.Id.Make ( coercionTokenId )
    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Core.DataCon
    import GHC.Types.CostCentre
    import GHC.Types.Tickish
    import GHC.Types.Var.Env
    import GHC.Unit.Module
    import GHC.Types.Name   ( isExternalName, nameModule_maybe )
    import GHC.Types.Basic  ( Arity )
    import GHC.Builtin.Types ( unboxedUnitDataCon )
    import GHC.Types.Literal
    import GHC.Utils.Outputable
    import GHC.Utils.Monad
    import GHC.Data.FastString
    import GHC.Utils.Misc
    import GHC.Utils.Panic
    import GHC.Driver.Session
    import GHC.Platform.Ways
    import GHC.Driver.Ppr
    import GHC.Types.ForeignCall
    import GHC.Types.IPE
    import GHC.Types.Demand    ( isUsedOnceDmd )
    import GHC.Builtin.PrimOps ( PrimCall(..) )
    import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )

    import Control.Monad (ap)
    import Data.Maybe (fromMaybe)
    import Data.Tuple (swap)
    import qualified Data.Set as Set

    -- Note [Live vs free]
    -- ~~~~~~~~~~~~~~~~~~~
    --
    -- The two are not the same. Liveness is an operational property rather
    -- than a semantic one. A variable is live at a particular execution
    -- point if it can be referred to directly again. In particular, a dead
    -- variable's stack slot (if it has one):
    --
    --           - should be stubbed to avoid space leaks, and
    --           - may be reused for something else.
    --
    -- There ought to be a better way to say this. Here are some examples:
    --
    --         let v = [q] \[x] -> e
    --         in
    --         ...v...  (but no q's)
    --
    -- Just after the `in', v is live, but q is dead. If the whole of that
    -- let expression was enclosed in a case expression, thus:
    --
    --         case (let v = [q] \[x] -> e in ...v...) of
    --                 alts[...q...]
    --
    -- (ie `alts' mention `q'), then `q' is live even after the `in'; because
    -- we'll return later to the `alts' and need it.
    --
    -- Let-no-escapes make this a bit more interesting:
    --
    --         let-no-escape v = [q] \ [x] -> e
    --         in
    --         ...v...
    --
    -- Here, `q' is still live at the `in', because `v' is represented not by
    -- a closure but by the current stack state.  In other words, if `v' is
    -- live then so is `q'. Furthermore, if `e' mentions an enclosing
    -- let-no-escaped variable, then its free variables are also live if `v' is.

    -- Note [What are these SRTs all about?]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    --
    -- Consider the Core program,
    --
    --     fibs = go 1 1
    --       where go a b = let c = a + c
    --                      in c : go b c
    --     add x = map (\y -> x*y) fibs
    --
    -- In this case we have a CAF, 'fibs', which is quite large after evaluation and
    -- has only one possible user, 'add'. Consequently, we want to ensure that when
    -- all references to 'add' die we can garbage collect any bit of 'fibs' that we
    -- have evaluated.
    --
    -- However, how do we know whether there are any references to 'fibs' still
    -- around? Afterall, the only reference to it is buried in the code generated
    -- for 'add'. The answer is that we record the CAFs referred to by a definition
    -- in its info table, namely a part of it known as the Static Reference Table
    -- (SRT).
    --
    -- Since SRTs are so common, we use a special compact encoding for them in: we
    -- produce one table containing a list of CAFs in a module and then include a
    -- bitmap in each info table describing which entries of this table the closure
    -- references.
    --
    -- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki.

    -- Note [What is a non-escaping let]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    --
    -- NB: Nowadays this is recognized by the occurrence analyser by turning a
    -- "non-escaping let" into a join point. The following is then an operational
    -- account of join points.
    --
    -- Consider:
    --
    --     let x = fvs \ args -> e
    --     in
    --         if ... then x else
    --            if ... then x else ...
    --
    -- `x' is used twice (so we probably can't unfold it), but when it is
    -- entered, the stack is deeper than it was when the definition of `x'
    -- happened.  Specifically, if instead of allocating a closure for `x',
    -- we saved all `x's fvs on the stack, and remembered the stack depth at
    -- that moment, then whenever we enter `x' we can simply set the stack
    -- pointer(s) to these remembered (compile-time-fixed) values, and jump
    -- to the code for `x'.
    --
    -- All of this is provided x is:
    --   1. non-updatable;
    --   2. guaranteed to be entered before the stack retreats -- ie x is not
    --      buried in a heap-allocated closure, or passed as an argument to
    --      something;
    --   3. all the enters have exactly the right number of arguments,
    --      no more no less;
    --   4. all the enters are tail calls; that is, they return to the
    --      caller enclosing the definition of `x'.
    --
    -- Under these circumstances we say that `x' is non-escaping.
    --
    -- An example of when (4) does not hold:
    --
    --     let x = ...
    --     in case x of ...alts...
    --
    -- Here, `x' is certainly entered only when the stack is deeper than when
    -- `x' is defined, but here it must return to ...alts... So we can't just
    -- adjust the stack down to `x''s recalled points, because that would lost
    -- alts' context.
    --
    -- Things can get a little more complicated.  Consider:
    --
    --     let y = ...
    --     in let x = fvs \ args -> ...y...
    --     in ...x...
    --
    -- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
    -- non-escaping way in ...y..., then `y' is non-escaping.
    --
    -- `x' can even be recursive!  Eg:
    --
    --     letrec x = [y] \ [v] -> if v then x True else ...
    --     in
    --         ...(x b)...

    -- Note [Cost-centre initialization plan]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    --
    -- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
    -- and the fields were then fixed by a separate pass `stgMassageForProfiling`.
    -- We now initialize these correctly. The initialization works like this:
    --
    --   - For non-top level bindings always use `currentCCS`.
    --
    --   - For top-level bindings, check if the binding is a CAF
    --
    --     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF
    --                 and use it. Note that these new cost centres need to be
    --                 collected to be able to generate cost centre initialization
    --                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.
    --
    --                 If -fcaf-all is not enabled, use "all CAFs" cost centre.
    --
    --     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor
    --                 do we set CCCS from it; so we just slam in
    --                 dontCareCostCentre.

    -- Note [Coercion tokens]
    -- ~~~~~~~~~~~~~~~~~~~~~~
    -- In coreToStgArgs, we drop type arguments completely, but we replace
    -- coercions with a special coercionToken# placeholder. Why? Consider:
    --
    --   f :: forall a. Int ~# Bool -> a
    --   f = /\a. \(co :: Int ~# Bool) -> error "impossible"
    --
    -- If we erased the coercion argument completely, we’d end up with just
    -- f = error "impossible", but then f `seq` () would be ⊥!
    --
    -- This is an artificial example, but back in the day we *did* treat
    -- coercion lambdas like type lambdas, and we had bug reports as a
    -- result. So now we treat coercion lambdas like value lambdas, but we
    -- treat coercions themselves as zero-width arguments — coercionToken#
    -- has representation VoidRep — which gets the best of both worlds.
    --
    -- (For the gory details, see also the (unpublished) paper, “Practical
    -- aspects of evidence-based compilation in System FC.”)

    -- --------------------------------------------------------------
    -- Setting variable info: top-level, binds, RHSs
    -- --------------------------------------------------------------

    coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram
              -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
    coreToStg :: DynFlags
    -> Module
    -> ModLocation
    -> CoreProgram
    -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
    coreToStg DynFlags
    dflags Module
    this_mod ModLocation
    ml CoreProgram
    pgm
      = ([StgTopBinding]
    pgm'', InfoTableProvMap
    denv, CollectedCCs
    final_ccs)
      where
        (IdEnv HowBound
    _, ([CostCentre]
    local_ccs, [CostCentreStack]
    local_cc_stacks), [StgTopBinding]
    pgm')
          = DynFlags
    -> Module
    -> IdEnv HowBound
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
    coreTopBindsToStg DynFlags
    dflags Module
    this_mod forall a. VarEnv a
    emptyVarEnv CollectedCCs
    emptyCollectedCCs CoreProgram
    pgm

        -- See Note [Mapping Info Tables to Source Positions]
        (![StgTopBinding]
    pgm'', !InfoTableProvMap
    denv) =
            if GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_InfoTableMap DynFlags
    dflags
              then DynFlags
    -> ModLocation
    -> [StgTopBinding]
    -> ([StgTopBinding], InfoTableProvMap)
    collectDebugInformation DynFlags
    dflags ModLocation
    ml [StgTopBinding]
    pgm'
              else ([StgTopBinding]
    pgm', InfoTableProvMap
    emptyInfoTableProvMap)

        prof :: Bool
    prof = Way
    WayProf forall a. Ord a => a -> Set a -> Bool
    `Set.member` DynFlags -> Ways
    ways DynFlags
    dflags

        final_ccs :: CollectedCCs
    final_ccs
          | Bool
    prof Bool -> Bool -> Bool
    && GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_AutoSccsOnIndividualCafs DynFlags
    dflags
          = ([CostCentre]
    local_ccs,[CostCentreStack]
    local_cc_stacks)  -- don't need "all CAFs" CC
          | Bool
    prof
          = (CostCentre
    all_cafs_ccforall a. a -> [a] -> [a]
    :[CostCentre]
    local_ccs, CostCentreStack
    all_cafs_ccsforall a. a -> [a] -> [a]
    :[CostCentreStack]
    local_cc_stacks)
          | Bool
    otherwise
          = CollectedCCs
    emptyCollectedCCs

        (CostCentre
    all_cafs_cc, CostCentreStack
    all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
    getAllCAFsCC Module
    this_mod

    coreTopBindsToStg
        :: DynFlags
        -> Module
        -> IdEnv HowBound           -- environment for the bindings
        -> CollectedCCs
        -> CoreProgram
        -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])

    coreTopBindsToStg :: DynFlags
    -> Module
    -> IdEnv HowBound
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
    coreTopBindsToStg DynFlags
    _      Module
    _        IdEnv HowBound
    env CollectedCCs
    ccs []
      = (IdEnv HowBound
    env, CollectedCCs
    ccs, [])
    coreTopBindsToStg DynFlags
    dflags Module
    this_mod IdEnv HowBound
    env CollectedCCs
    ccs (CoreBind
    b:CoreProgram
    bs)
      | NonRec Id
    _ CoreArg
    rhs <- CoreBind
    b, forall b. Expr b -> Bool
    isTyCoArg CoreArg
    rhs
      = DynFlags
    -> Module
    -> IdEnv HowBound
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
    coreTopBindsToStg DynFlags
    dflags Module
    this_mod IdEnv HowBound
    env1 CollectedCCs
    ccs1 CoreProgram
    bs
      | Bool
    otherwise
      = (IdEnv HowBound
    env2, CollectedCCs
    ccs2, StgTopBinding
    b'forall a. a -> [a] -> [a]
    :[StgTopBinding]
    bs')
      where
        (IdEnv HowBound
    env1, CollectedCCs
    ccs1, StgTopBinding
    b' ) = DynFlags
    -> Module
    -> IdEnv HowBound
    -> CollectedCCs
    -> CoreBind
    -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
    coreTopBindToStg DynFlags
    dflags Module
    this_mod IdEnv HowBound
    env CollectedCCs
    ccs CoreBind
    b
        (IdEnv HowBound
    env2, CollectedCCs
    ccs2, [StgTopBinding]
    bs') = DynFlags
    -> Module
    -> IdEnv HowBound
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
    coreTopBindsToStg DynFlags
    dflags Module
    this_mod IdEnv HowBound
    env1 CollectedCCs
    ccs1 CoreProgram
    bs

    coreTopBindToStg
            :: DynFlags
            -> Module
            -> IdEnv HowBound
            -> CollectedCCs
            -> CoreBind
            -> (IdEnv HowBound, CollectedCCs, StgTopBinding)

    coreTopBindToStg :: DynFlags
    -> Module
    -> IdEnv HowBound
    -> CollectedCCs
    -> CoreBind
    -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
    coreTopBindToStg DynFlags
    _ Module
    _ IdEnv HowBound
    env CollectedCCs
    ccs (NonRec Id
    id CoreArg
    e)
      | Just ByteString
    str <- CoreArg -> Maybe ByteString
    exprIsTickedString_maybe CoreArg
    e
      -- top-level string literal
      -- See Note [Core top-level string literals] in GHC.Core
      = let
            env' :: IdEnv HowBound
    env' = forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv IdEnv HowBound
    env Id
    id HowBound
    how_bound
            how_bound :: HowBound
    how_bound = LetInfo -> JoinArity -> HowBound
    LetBound LetInfo
    TopLet JoinArity
    0
        in (IdEnv HowBound
    env', CollectedCCs
    ccs, forall (pass :: StgPass). Id -> ByteString -> GenStgTopBinding pass
    StgTopStringLit Id
    id ByteString
    str)

    coreTopBindToStg DynFlags
    dflags Module
    this_mod IdEnv HowBound
    env CollectedCCs
    ccs (NonRec Id
    id CoreArg
    rhs)
      = let
            env' :: IdEnv HowBound
    env'      = forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv IdEnv HowBound
    env Id
    id HowBound
    how_bound
            how_bound :: HowBound
    how_bound = LetInfo -> JoinArity -> HowBound
    LetBound LetInfo
    TopLet forall a b. (a -> b) -> a -> b
    $! CoreArg -> JoinArity
    manifestArity CoreArg
    rhs

            (StgRhs
    stg_rhs, CollectedCCs
    ccs') =
                forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
    initCts DynFlags
    dflags IdEnv HowBound
    env forall a b. (a -> b) -> a -> b
    $
                  DynFlags
    -> CollectedCCs
    -> Module
    -> (Id, CoreArg)
    -> CtsM (StgRhs, CollectedCCs)
    coreToTopStgRhs DynFlags
    dflags CollectedCCs
    ccs Module
    this_mod (Id
    id,CoreArg
    rhs)

            bind :: StgTopBinding
    bind = forall (pass :: StgPass).
    GenStgBinding pass -> GenStgTopBinding pass
    StgTopLifted forall a b. (a -> b) -> a -> b
    $ forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec Id
    id StgRhs
    stg_rhs
        in
          -- NB: previously the assertion printed 'rhs' and 'bind'
          --     as well as 'id', but that led to a black hole
          --     where printing the assertion error tripped the
          --     assertion again!
        (IdEnv HowBound
    env', CollectedCCs
    ccs', StgTopBinding
    bind)

    coreTopBindToStg DynFlags
    dflags Module
    this_mod IdEnv HowBound
    env CollectedCCs
    ccs (Rec [(Id, CoreArg)]
    pairs)
      = ASSERT( not (null pairs) )
        let
            binders :: [Id]
    binders = forall a b. (a -> b) -> [a] -> [b]
    map forall a b. (a, b) -> a
    fst [(Id, CoreArg)]
    pairs

            extra_env' :: [(Id, HowBound)]
    extra_env' = [ (Id
    b, LetInfo -> JoinArity -> HowBound
    LetBound LetInfo
    TopLet forall a b. (a -> b) -> a -> b
    $! CoreArg -> JoinArity
    manifestArity CoreArg
    rhs)
                         | (Id
    b, CoreArg
    rhs) <- [(Id, CoreArg)]
    pairs ]
            env' :: IdEnv HowBound
    env' = forall a. VarEnv a -> [(Id, a)] -> VarEnv a
    extendVarEnvList IdEnv HowBound
    env [(Id, HowBound)]
    extra_env'

            -- generate StgTopBindings and CAF cost centres created for CAFs
            (CollectedCCs
    ccs', [StgRhs]
    stg_rhss)
              = forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
    initCts DynFlags
    dflags IdEnv HowBound
    env' forall a b. (a -> b) -> a -> b
    $
                  forall (m :: * -> *) acc x y.
    Monad m =>
    (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
    mapAccumLM (\CollectedCCs
    ccs (Id, CoreArg)
    rhs -> forall a b. (a, b) -> (b, a)
    swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DynFlags
    -> CollectedCCs
    -> Module
    -> (Id, CoreArg)
    -> CtsM (StgRhs, CollectedCCs)
    coreToTopStgRhs DynFlags
    dflags CollectedCCs
    ccs Module
    this_mod (Id, CoreArg)
    rhs)
                             CollectedCCs
    ccs
                             [(Id, CoreArg)]
    pairs
            bind :: StgTopBinding
    bind = forall (pass :: StgPass).
    GenStgBinding pass -> GenStgTopBinding pass
    StgTopLifted forall a b. (a -> b) -> a -> b
    $ forall (pass :: StgPass).
    [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    StgRec (forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    binders [StgRhs]
    stg_rhss)
        in
        (IdEnv HowBound
    env', CollectedCCs
    ccs', StgTopBinding
    bind)

    coreToTopStgRhs
            :: DynFlags
            -> CollectedCCs
            -> Module
            -> (Id,CoreExpr)
            -> CtsM (StgRhs, CollectedCCs)

    coreToTopStgRhs :: DynFlags
    -> CollectedCCs
    -> Module
    -> (Id, CoreArg)
    -> CtsM (StgRhs, CollectedCCs)
    coreToTopStgRhs DynFlags
    dflags CollectedCCs
    ccs Module
    this_mod (Id
    bndr, CoreArg
    rhs)
      = do { PreStgRhs
    new_rhs <- HasDebugCallStack => CoreArg -> CtsM PreStgRhs
    coreToPreStgRhs CoreArg
    rhs

           ; let (StgRhs
    stg_rhs, CollectedCCs
    ccs') =
                   DynFlags
    -> Module
    -> CollectedCCs
    -> Id
    -> PreStgRhs
    -> (StgRhs, CollectedCCs)
    mkTopStgRhs DynFlags
    dflags Module
    this_mod CollectedCCs
    ccs Id
    bndr PreStgRhs
    new_rhs
                 stg_arity :: JoinArity
    stg_arity =
                   StgRhs -> JoinArity
    stgRhsArity StgRhs
    stg_rhs

           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
                     CollectedCCs
    ccs') }
      where
            -- It's vital that the arity on a top-level Id matches
            -- the arity of the generated STG binding, else an importing
            -- module will use the wrong calling convention
            --      (#2844 was an example where this happened)
            -- NB1: we can't move the assertion further out without
            --      blocking the "knot" tied in coreTopBindsToStg
            -- NB2: the arity check is only needed for Ids with External
            --      Names, because they are externally visible.  The CorePrep
            --      pass introduces "sat" things with Local Names and does
            --      not bother to set their Arity info, so don't fail for those
        arity_ok :: JoinArity -> Bool
    arity_ok JoinArity
    stg_arity
           | Name -> Bool
    isExternalName (Id -> Name
    idName Id
    bndr) = JoinArity
    id_arity forall a. Eq a => a -> a -> Bool
    == JoinArity
    stg_arity
           | Bool
    otherwise                    = Bool
    True
        id_arity :: JoinArity
    id_arity  = Id -> JoinArity
    idArity Id
    bndr
        mk_arity_msg :: JoinArity -> SDoc
    mk_arity_msg JoinArity
    stg_arity
            = [SDoc] -> SDoc
    vcat [forall a. Outputable a => a -> SDoc
    ppr Id
    bndr,
                    String -> SDoc
    text String
    "Id arity:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr JoinArity
    id_arity,
                    String -> SDoc
    text String
    "STG arity:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr JoinArity
    stg_arity]

    -- ---------------------------------------------------------------------------
    -- Expressions
    -- ---------------------------------------------------------------------------

    -- coreToStgExpr panics if the input expression is a value lambda. CorePrep
    -- ensures that value lambdas only exist as the RHS of bindings, which we
    -- handle with the function coreToPreStgRhs.

    coreToStgExpr
            :: HasDebugCallStack => CoreExpr
            -> CtsM StgExpr

    -- The second and third components can be derived in a simple bottom up pass, not
    -- dependent on any decisions about which variables will be let-no-escaped or
    -- not.  The first component, that is, the decorated expression, may then depend
    -- on these components, but it in turn is not scrutinised as the basis for any
    -- decisions.  Hence no black holes.

    -- No LitInteger's or LitNatural's should be left by the time this is called.
    -- CorePrep should have converted them all to a real core representation.
    coreToStgExpr :: HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr (Lit (LitNumber LitNumType
    LitNumInteger Integer
    _)) = forall a. String -> a
    panic String
    "coreToStgExpr: LitInteger"
    coreToStgExpr (Lit (LitNumber LitNumType
    LitNumNatural Integer
    _)) = forall a. String -> a
    panic String
    "coreToStgExpr: LitNatural"
    coreToStgExpr (Lit Literal
    l)                           = forall (m :: * -> *) a. Monad m => a -> m a
    return (forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    l)
    coreToStgExpr (Var Id
    v) = Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
    coreToStgApp Id
    v [] []
    coreToStgExpr (Coercion Coercion
    _)
      -- See Note [Coercion tokens]
      = Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
    coreToStgApp Id
    coercionTokenId [] []

    coreToStgExpr expr :: CoreArg
    expr@(App CoreArg
    _ CoreArg
    _)
      = case CoreArg
    app_head of
          Var Id
    f               -> Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
    coreToStgApp Id
    f [CoreArg]
    args [CoreTickish]
    ticks -- Regular application
          Lit l :: Literal
    l@LitRubbish{}  -> forall (m :: * -> *) a. Monad m => a -> m a
    return (forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    l) -- LitRubbish
          CoreArg
    _                   -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "coreToStgExpr - Invalid app head:" (forall a. Outputable a => a -> SDoc
    ppr CoreArg
    expr)
        where
          (CoreArg
    app_head, [CoreArg]
    args, [CoreTickish]
    ticks) = HasDebugCallStack => CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
    myCollectArgs CoreArg
    expr
    coreToStgExpr expr :: CoreArg
    expr@(Lam Id
    _ CoreArg
    _)
      = let
            ([Id]
    args, CoreArg
    body) = CoreArg -> ([Id], CoreArg)
    myCollectBinders CoreArg
    expr
        in
        case [Id] -> [Id]
    filterStgBinders [Id]
    args of

          [] -> HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    body

          [Id]
    _ -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "coretoStgExpr" forall a b. (a -> b) -> a -> b
    $
            String -> SDoc
    text String
    "Unexpected value lambda:" SDoc -> SDoc -> SDoc
    $$ forall a. Outputable a => a -> SDoc
    ppr CoreArg
    expr

    coreToStgExpr (Tick CoreTickish
    tick CoreArg
    expr)
      = do
           let !stg_tick :: StgTickish
    stg_tick = Type -> CoreTickish -> StgTickish
    coreToStgTick (CoreArg -> Type
    exprType CoreArg
    expr) CoreTickish
    tick
           !StgExpr
    expr2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    expr
           forall (m :: * -> *) a. Monad m => a -> m a
    return (forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    stg_tick StgExpr
    expr2)

    coreToStgExpr (Cast CoreArg
    expr Coercion
    _)
      = HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    expr

    -- Cases require a little more real work.

    {-
    coreToStgExpr (Case scrut _ _ [])
      = coreToStgExpr scrut
        -- 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 this may seg-fault if the scrutinee *does* return.  A
        -- belt-and-braces approach would be to move this case into the
        -- code generator, and put a return point anyway that calls a
        -- runtime system error function.

    coreToStgExpr e0@(Case scrut bndr _ [alt]) = do
      | isUnsafeEqualityProof scrut
      , isDeadBinder bndr -- We can only discard the case if the case-binder is dead
                          -- It usually is, but see #18227
      , (_,_,rhs) <- alt
      = coreToStgExpr rhs
        -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
    -}

    -- The normal case for case-expressions
    coreToStgExpr (Case CoreArg
    scrut Id
    bndr Type
    _ [Alt Id]
    alts)
      = do { StgExpr
    scrut2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    scrut
           ; [(AltCon, [Id], StgExpr)]
    alts2 <- forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [(Id
    bndr, HowBound
    LambdaBound)] (forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM Alt Id -> CtsM (AltCon, [Id], StgExpr)
    vars_alt [Alt Id]
    alts)
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase StgExpr
    scrut2 Id
    bndr (Id -> [Alt Id] -> AltType
    mkStgAltType Id
    bndr [Alt Id]
    alts) [(AltCon, [Id], StgExpr)]
    alts2) }
      where
        vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr)
        vars_alt :: Alt Id -> CtsM (AltCon, [Id], StgExpr)
    vars_alt (Alt AltCon
    con [Id]
    binders CoreArg
    rhs)
          | DataAlt DataCon
    c <- AltCon
    con, DataCon
    c forall a. Eq a => a -> a -> Bool
    == DataCon
    unboxedUnitDataCon
          = -- This case is a bit smelly.
            -- See Note [Nullary unboxed tuple] in GHC.Core.Type
            -- where a nullary tuple is mapped to (State# World#)
            ASSERT( null binders )
            do { StgExpr
    rhs2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    rhs
               ; forall (m :: * -> *) a. Monad m => a -> m a
    return (AltCon
    DEFAULT, [], StgExpr
    rhs2)  }
          | Bool
    otherwise
          = let     -- Remove type variables
                binders' :: [Id]
    binders' = [Id] -> [Id]
    filterStgBinders [Id]
    binders
            in
            forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [(Id
    b, HowBound
    LambdaBound) | Id
    b <- [Id]
    binders'] forall a b. (a -> b) -> a -> b
    $ do
            StgExpr
    rhs2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    rhs
            forall (m :: * -> *) a. Monad m => a -> m a
    return (AltCon
    con, [Id]
    binders', StgExpr
    rhs2)

    coreToStgExpr (Let CoreBind
    bind CoreArg
    body) = CoreBind -> CoreArg -> CtsM StgExpr
    coreToStgLet CoreBind
    bind CoreArg
    body
    coreToStgExpr CoreArg
    e               = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "coreToStgExpr" (forall a. Outputable a => a -> SDoc
    ppr CoreArg
    e)

    mkStgAltType :: Id -> [CoreAlt] -> AltType
    mkStgAltType :: Id -> [Alt Id] -> AltType
    mkStgAltType Id
    bndr [Alt Id]
    alts
      | Type -> Bool
    isUnboxedTupleType Type
    bndr_ty Bool -> Bool -> Bool
    || Type -> Bool
    isUnboxedSumType Type
    bndr_ty
      = JoinArity -> AltType
    MultiValAlt (forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length [PrimRep]
    prim_reps)  -- always use MultiValAlt for unboxed tuples

      | Bool
    otherwise
      = case [PrimRep]
    prim_reps of
          [PrimRep
    rep] | PrimRep -> Bool
    isGcPtrRep PrimRep
    rep ->
            case Type -> Maybe TyCon
    tyConAppTyCon_maybe (Type -> Type
    unwrapType Type
    bndr_ty) of
              Just TyCon
    tc
                | TyCon -> Bool
    isAbstractTyCon TyCon
    tc -> AltType
    look_for_better_tycon
                | TyCon -> Bool
    isAlgTyCon TyCon
    tc      -> TyCon -> AltType
    AlgAlt TyCon
    tc
                | Bool
    otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                        AltType
    PolyAlt
              Maybe TyCon
    Nothing                -> AltType
    PolyAlt
          [PrimRep
    non_gcd] -> PrimRep -> AltType
    PrimAlt PrimRep
    non_gcd
          [PrimRep]
    not_unary -> JoinArity -> AltType
    MultiValAlt (forall (t :: * -> *) a. Foldable t => t a -> JoinArity
    length [PrimRep]
    not_unary)
      where
       bndr_ty :: Type
    bndr_ty   = Id -> Type
    idType Id
    bndr
       prim_reps :: [PrimRep]
    prim_reps = HasDebugCallStack => Type -> [PrimRep]
    typePrimRep Type
    bndr_ty

       _is_poly_alt_tycon :: TyCon -> Bool
    _is_poly_alt_tycon TyCon
    tc
            =  TyCon -> Bool
    isFunTyCon TyCon
    tc
            Bool -> Bool -> Bool
    || TyCon -> Bool
    isPrimTyCon TyCon
    tc   -- "Any" is lifted but primitive
            Bool -> Bool -> Bool
    || TyCon -> Bool
    isFamilyTyCon TyCon
    tc -- Type family; e.g. Any, or arising from strict
                                -- function application where argument has a
                                -- type-family type

       -- Sometimes, the TyCon is a AbstractTyCon which may not have any
       -- constructors inside it.  Then we may get a better TyCon by
       -- grabbing the one from a constructor alternative
       -- if one exists.
       look_for_better_tycon :: AltType
    look_for_better_tycon
            | ((Alt (DataAlt DataCon
    con) [Id]
    _ CoreArg
    _) : [Alt Id]
    _) <- [Alt Id]
    data_alts =
                    TyCon -> AltType
    AlgAlt (DataCon -> TyCon
    dataConTyCon DataCon
    con)
            | Bool
    otherwise =
                    ASSERT(null data_alts)
                    AltType
    PolyAlt
            where
                    ([Alt Id]
    data_alts, Maybe CoreArg
    _deflt) = forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
    findDefault [Alt Id]
    alts

    -- ---------------------------------------------------------------------------
    -- Applications
    -- ---------------------------------------------------------------------------

    coreToStgApp :: Id            -- Function
                 -> [CoreArg]     -- Arguments
                 -> [CoreTickish] -- Debug ticks
                 -> CtsM StgExpr
    coreToStgApp :: Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
    coreToStgApp Id
    f [CoreArg]
    args [CoreTickish]
    ticks = do
        ([StgArg]
    args', [StgTickish]
    ticks') <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs [CoreArg]
    args
        HowBound
    how_bound <- Id -> CtsM HowBound
    lookupVarCts Id
    f

        let
            n_val_args :: JoinArity
    n_val_args       = forall b. [Arg b] -> JoinArity
    valArgCount [CoreArg]
    args

            -- Mostly, the arity info of a function is in the fn's IdInfo
            -- But new bindings introduced by CoreSat may not have no
            -- arity info; it would do us no good anyway.  For example:
            --      let f = \ab -> e in f
            -- No point in having correct arity info for f!
            -- Hence the hasArity stuff below.
            -- NB: f_arity is only consulted for LetBound things
            f_arity :: JoinArity
    f_arity   = Id -> HowBound -> JoinArity
    stgArity Id
    f HowBound
    how_bound
            saturated :: Bool
    saturated = JoinArity
    f_arity forall a. Ord a => a -> a -> Bool
    <= JoinArity
    n_val_args

            res_ty :: Type
    res_ty = CoreArg -> Type
    exprType (forall b. Expr b -> [Expr b] -> Expr b
    mkApps (forall b. Id -> Expr b
    Var Id
    f) [CoreArg]
    args)
            app :: StgExpr
    app = case Id -> IdDetails
    idDetails Id
    f of
                    DataConWorkId DataCon
    dc
                      | Bool
    saturated    -> forall (pass :: StgPass).
    DataCon -> XConApp pass -> [StgArg] -> [Type] -> GenStgExpr pass
    StgConApp DataCon
    dc ConstructorNumber
    NoNumber [StgArg]
    args'
                                          ([Type] -> [Type]
    dropRuntimeRepArgs (forall a. a -> Maybe a -> a
    fromMaybe [] (Type -> Maybe [Type]
    tyConAppArgs_maybe Type
    res_ty)))

                    -- Some primitive operator that might be implemented as a library call.
                    -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
                    -- we require that primop applications be saturated.
                    PrimOpId PrimOp
    op      -> ASSERT( saturated )
                                        forall (pass :: StgPass).
    StgOp -> [StgArg] -> Type -> GenStgExpr pass
    StgOpApp (PrimOp -> StgOp
    StgPrimOp PrimOp
    op) [StgArg]
    args' Type
    res_ty

                    -- A call to some primitive Cmm function.
                    FCallId (CCall (CCallSpec (StaticTarget SourceText
    _ CLabelString
    lbl (Just Unit
    pkgId) Bool
    True)
                                              CCallConv
    PrimCallConv Safety
    _))
                                     -> ASSERT( saturated )
                                        forall (pass :: StgPass).
    StgOp -> [StgArg] -> Type -> GenStgExpr pass
    StgOpApp (PrimCall -> StgOp
    StgPrimCallOp (CLabelString -> Unit -> PrimCall
    PrimCall CLabelString
    lbl Unit
    pkgId)) [StgArg]
    args' Type
    res_ty

                    -- A regular foreign call.
                    FCallId ForeignCall
    call     -> ASSERT( saturated )
                                        forall (pass :: StgPass).
    StgOp -> [StgArg] -> Type -> GenStgExpr pass
    StgOpApp (ForeignCall -> Type -> StgOp
    StgFCallOp ForeignCall
    call (Id -> Type
    idType Id
    f)) [StgArg]
    args' Type
    res_ty

                    TickBoxOpId {}   -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "coreToStg TickBox" forall a b. (a -> b) -> a -> b
    $ forall a. Outputable a => a -> SDoc
    ppr (Id
    f,[StgArg]
    args')
                    IdDetails
    _other           -> forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
    StgApp Id
    f [StgArg]
    args'

            add_tick :: StgTickish -> GenStgExpr pass -> GenStgExpr pass
    add_tick !StgTickish
    t !GenStgExpr pass
    e = forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    t GenStgExpr pass
    e
            tapp :: StgExpr
    tapp = forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    add_tick StgExpr
    app (forall a b. (a -> b) -> [a] -> [b]
    map (Type -> CoreTickish -> StgTickish
    coreToStgTick Type
    res_ty) [CoreTickish]
    ticks forall a. [a] -> [a] -> [a]
    ++ [StgTickish]
    ticks')

        -- Forcing these fixes a leak in the code generator, noticed while
        -- profiling for trac #4367
        StgExpr
    app seq :: forall a b. a -> b -> b
    `seq` forall (m :: * -> *) a. Monad m => a -> m a
    return StgExpr
    tapp

    -- ---------------------------------------------------------------------------
    -- Argument lists
    -- This is the guy that turns applications into A-normal form
    -- ---------------------------------------------------------------------------

    coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs []
      = forall (m :: * -> *) a. Monad m => a -> m a
    return ([], [])

    coreToStgArgs (Type Type
    _ : [CoreArg]
    args) = do     -- Type argument
        ([StgArg]
    args', [StgTickish]
    ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs [CoreArg]
    args
        forall (m :: * -> *) a. Monad m => a -> m a
    return ([StgArg]
    args', [StgTickish]
    ts)

    coreToStgArgs (Coercion Coercion
    _ : [CoreArg]
    args) -- Coercion argument; See Note [Coercion tokens]
      = do { ([StgArg]
    args', [StgTickish]
    ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs [CoreArg]
    args
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> StgArg
    StgVarArg Id
    coercionTokenId forall a. a -> [a] -> [a]
    : [StgArg]
    args', [StgTickish]
    ts) }

    coreToStgArgs (Tick CoreTickish
    t CoreArg
    e : [CoreArg]
    args)
      = ASSERT( not (tickishIsCode t) )
        do { ([StgArg]
    args', [StgTickish]
    ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs (CoreArg
    e forall a. a -> [a] -> [a]
    : [CoreArg]
    args)
           ; let !t' :: StgTickish
    t' = Type -> CoreTickish -> StgTickish
    coreToStgTick (CoreArg -> Type
    exprType CoreArg
    e) CoreTickish
    t
           ; forall (m :: * -> *) a. Monad m => a -> m a
    return ([StgArg]
    args', StgTickish
    t'forall a. a -> [a] -> [a]
    :[StgTickish]
    ts) }

    coreToStgArgs (CoreArg
    arg : [CoreArg]
    args) = do         -- Non-type argument
        ([StgArg]
    stg_args, [StgTickish]
    ticks) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs [CoreArg]
    args
        StgExpr
    arg' <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    arg
        let
            ([StgTickish]
    aticks, StgExpr
    arg'') = forall (p :: StgPass).
    (StgTickish -> Bool)
    -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
    stripStgTicksTop forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishFloatable StgExpr
    arg'
            stg_arg :: StgArg
    stg_arg = case StgExpr
    arg'' of
                           StgApp Id
    v []        -> Id -> StgArg
    StgVarArg Id
    v
                           StgConApp DataCon
    con XConApp 'Vanilla
    _ [] [Type]
    _ -> Id -> StgArg
    StgVarArg (DataCon -> Id
    dataConWorkId DataCon
    con)
                           StgLit Literal
    lit         -> Literal -> StgArg
    StgLitArg Literal
    lit
                           StgExpr
    _                  -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "coreToStgArgs" (forall a. Outputable a => a -> SDoc
    ppr CoreArg
    arg)

            -- WARNING: what if we have an argument like (v `cast` co)
            --          where 'co' changes the representation type?
            --          (This really only happens if co is unsafe.)
            -- Then all the getArgAmode stuff in CgBindery will set the
            -- cg_rep of the CgIdInfo based on the type of v, rather
            -- than the type of 'co'.
            -- This matters particularly when the function is a primop
            -- or foreign call.
            -- Wanted: a better solution than this hacky warning

        Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        let
            arg_rep :: [PrimRep]
    arg_rep = HasDebugCallStack => Type -> [PrimRep]
    typePrimRep (CoreArg -> Type
    exprType CoreArg
    arg)
            stg_arg_rep :: [PrimRep]
    stg_arg_rep = HasDebugCallStack => Type -> [PrimRep]
    typePrimRep (StgArg -> Type
    stgArgType StgArg
    stg_arg)
            bad_args :: Bool
    bad_args = Bool -> Bool
    not (Platform -> [PrimRep] -> [PrimRep] -> Bool
    primRepsCompatible Platform
    platform [PrimRep]
    arg_rep [PrimRep]
    stg_arg_rep)

        WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
         forall (m :: * -> *) a. Monad m => a -> m a
    return (StgArg
    stg_arg forall a. a -> [a] -> [a]
    : [StgArg]
    stg_args, [StgTickish]
    ticks forall a. [a] -> [a] -> [a]
    ++ [StgTickish]
    aticks)

    coreToStgTick :: Type -- type of the ticked expression
                  -> CoreTickish
                  -> StgTickish
    coreToStgTick :: Type -> CoreTickish -> StgTickish
    coreToStgTick Type
    _ty (HpcTick Module
    m JoinArity
    i)           = forall (pass :: TickishPass).
    Module -> JoinArity -> GenTickish pass
    HpcTick Module
    m JoinArity
    i
    coreToStgTick Type
    _ty (SourceNote RealSrcSpan
    span String
    nm)    = forall (pass :: TickishPass).
    RealSrcSpan -> String -> GenTickish pass
    SourceNote RealSrcSpan
    span String
    nm
    coreToStgTick Type
    _ty (ProfNote CostCentre
    cc Bool
    cnt Bool
    scope) = forall (pass :: TickishPass).
    CostCentre -> Bool -> Bool -> GenTickish pass
    ProfNote CostCentre
    cc Bool
    cnt Bool
    scope
    coreToStgTick !Type
    ty (Breakpoint XBreakpoint 'TickishPassCore
    _ JoinArity
    bid [XTickishId 'TickishPassCore]
    fvs)  = forall (pass :: TickishPass).
    XBreakpoint pass
    -> JoinArity -> [XTickishId pass] -> GenTickish pass
    Breakpoint Type
    ty JoinArity
    bid [XTickishId 'TickishPassCore]
    fvs

    -- ---------------------------------------------------------------------------
    -- The magic for lets:
    -- ---------------------------------------------------------------------------

    coreToStgLet
             :: CoreBind     -- bindings
             -> CoreExpr     -- body
             -> CtsM StgExpr -- new let

    coreToStgLet :: CoreBind -> CoreArg -> CtsM StgExpr
    coreToStgLet CoreBind
    bind CoreArg
    body
      | NonRec Id
    _ CoreArg
    rhs <- CoreBind
    bind, forall b. Expr b -> Bool
    isTyCoArg CoreArg
    rhs
      = HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    body

      | Bool
    otherwise
      = do { (StgBinding
    bind2, [(Id, HowBound)]
    env_ext) <- CoreBind -> CtsM (StgBinding, [(Id, HowBound)])
    vars_bind CoreBind
    bind

              -- Do the body
             ; StgExpr
    body2 <- forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [(Id, HowBound)]
    env_ext forall a b. (a -> b) -> a -> b
    $
                        HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    body

            -- Compute the new let-expression
            ; let new_let :: StgExpr
    new_let | CoreBind -> Bool
    isJoinBind CoreBind
    bind
                          = forall (pass :: StgPass).
    XLetNoEscape pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLetNoEscape NoExtFieldSilent
    noExtFieldSilent StgBinding
    bind2 StgExpr
    body2
                          | Bool
    otherwise
                          = forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet NoExtFieldSilent
    noExtFieldSilent StgBinding
    bind2 StgExpr
    body2

            ; forall (m :: * -> *) a. Monad m => a -> m a
    return StgExpr
    new_let }
      where
        mk_binding :: a -> CoreArg -> (a, HowBound)
    mk_binding a
    binder CoreArg
    rhs
            = (a
    binder, LetInfo -> JoinArity -> HowBound
    LetBound LetInfo
    NestedLet (CoreArg -> JoinArity
    manifestArity CoreArg
    rhs))

        vars_bind :: CoreBind
                  -> CtsM (StgBinding,
                           [(Id, HowBound)])  -- extension to environment

        vars_bind :: CoreBind -> CtsM (StgBinding, [(Id, HowBound)])
    vars_bind (NonRec Id
    binder CoreArg
    rhs) = do
            StgRhs
    rhs2 <- (Id, CoreArg) -> CtsM StgRhs
    coreToStgRhs (Id
    binder,CoreArg
    rhs)
            let
                env_ext_item :: (Id, HowBound)
    env_ext_item = forall {a}. a -> CoreArg -> (a, HowBound)
    mk_binding Id
    binder CoreArg
    rhs

            forall (m :: * -> *) a. Monad m => a -> m a
    return (forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec Id
    binder StgRhs
    rhs2, [(Id, HowBound)
    env_ext_item])

        vars_bind (Rec [(Id, CoreArg)]
    pairs)
          =    let
                    binders :: [Id]
    binders = forall a b. (a -> b) -> [a] -> [b]
    map forall a b. (a, b) -> a
    fst [(Id, CoreArg)]
    pairs
                    env_ext :: [(Id, HowBound)]
    env_ext = [ forall {a}. a -> CoreArg -> (a, HowBound)
    mk_binding Id
    b CoreArg
    rhs
                              | (Id
    b,CoreArg
    rhs) <- [(Id, CoreArg)]
    pairs ]
               in
               forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [(Id, HowBound)]
    env_ext forall a b. (a -> b) -> a -> b
    $ do
                  [StgRhs]
    rhss2 <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (Id, CoreArg) -> CtsM StgRhs
    coreToStgRhs [(Id, CoreArg)]
    pairs
                  forall (m :: * -> *) a. Monad m => a -> m a
    return (forall (pass :: StgPass).
    [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    StgRec ([Id]
    binders forall a b. [a] -> [b] -> [(a, b)]
    `zip` [StgRhs]
    rhss2), [(Id, HowBound)]
    env_ext)

    coreToStgRhs :: (Id,CoreExpr)
                 -> CtsM StgRhs

    coreToStgRhs :: (Id, CoreArg) -> CtsM StgRhs
    coreToStgRhs (Id
    bndr, CoreArg
    rhs) = do
        PreStgRhs
    new_rhs <- HasDebugCallStack => CoreArg -> CtsM PreStgRhs
    coreToPreStgRhs CoreArg
    rhs
        forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> PreStgRhs -> StgRhs
    mkStgRhs Id
    bndr PreStgRhs
    new_rhs)

    -- Represents the RHS of a binding for use with mk(Top)StgRhs.
    data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks

    -- Convert the RHS of a binding from Core to STG. This is a wrapper around
    -- coreToStgExpr that can handle value lambdas.
    coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
    coreToPreStgRhs :: HasDebugCallStack => CoreArg -> CtsM PreStgRhs
    coreToPreStgRhs (Cast CoreArg
    expr Coercion
    _) = HasDebugCallStack => CoreArg -> CtsM PreStgRhs
    coreToPreStgRhs CoreArg
    expr
    coreToPreStgRhs expr :: CoreArg
    expr@(Lam Id
    _ CoreArg
    _) =
        let
            ([Id]
    args, CoreArg
    body) = CoreArg -> ([Id], CoreArg)
    myCollectBinders CoreArg
    expr
            args' :: [Id]
    args'        = [Id] -> [Id]
    filterStgBinders [Id]
    args
        in
            forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [ (Id
    a, HowBound
    LambdaBound) | Id
    a <- [Id]
    args' ] forall a b. (a -> b) -> a -> b
    $ do
              StgExpr
    body' <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    body
              forall (m :: * -> *) a. Monad m => a -> m a
    return ([Id] -> StgExpr -> PreStgRhs
    PreStgRhs [Id]
    args' StgExpr
    body')
    coreToPreStgRhs CoreArg
    expr = [Id] -> StgExpr -> PreStgRhs
    PreStgRhs [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> HasDebugCallStack => CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    expr

    -- Generate a top-level RHS. Any new cost centres generated for CAFs will be
    -- appended to `CollectedCCs` argument.
    mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
                -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)

    mkTopStgRhs :: DynFlags
    -> Module
    -> CollectedCCs
    -> Id
    -> PreStgRhs
    -> (StgRhs, CollectedCCs)
    mkTopStgRhs DynFlags
    dflags Module
    this_mod CollectedCCs
    ccs Id
    bndr (PreStgRhs [Id]
    bndrs StgExpr
    rhs)
      | Bool -> Bool
    not (forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    bndrs)
      = -- The list of arguments is non-empty, so not CAF
        ( forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent
                        CostCentreStack
    dontCareCCS
                        UpdateFlag
    ReEntrant
                        [Id]
    bndrs StgExpr
    rhs
        , CollectedCCs
    ccs )

      -- After this point we know that `bndrs` is empty,
      -- so this is not a function binding
      | StgConApp DataCon
    con XConApp 'Vanilla
    mn [StgArg]
    args [Type]
    _ <- StgExpr
    unticked_rhs
      , -- Dynamic StgConApps are updatable
        Bool -> Bool
    not (DynFlags -> Module -> DataCon -> [StgArg] -> Bool
    isDllConApp DynFlags
    dflags Module
    this_mod DataCon
    con [StgArg]
    args)
      = -- CorePrep does this right, but just to make sure
        ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)
               , ppr bndr $$ ppr con $$ ppr args)
        ( forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    dontCareCCS DataCon
    con XConApp 'Vanilla
    mn [StgTickish]
    ticks [StgArg]
    args, CollectedCCs
    ccs )

      -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
      | GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_AutoSccsOnIndividualCafs DynFlags
    dflags
      = ( forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent
                        CostCentreStack
    caf_ccs
                        UpdateFlag
    upd_flag [] StgExpr
    rhs
        , CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
    collectCC CostCentre
    caf_cc CostCentreStack
    caf_ccs CollectedCCs
    ccs )

      | Bool
    otherwise
      = ( forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent
                        CostCentreStack
    all_cafs_ccs
                        UpdateFlag
    upd_flag [] StgExpr
    rhs
        , CollectedCCs
    ccs )

      where
        ([StgTickish]
    ticks, StgExpr
    unticked_rhs) = forall (p :: StgPass).
    (StgTickish -> Bool)
    -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
    stripStgTicksTop (Bool -> Bool
    not forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishIsCode) StgExpr
    rhs

        upd_flag :: UpdateFlag
    upd_flag | Demand -> Bool
    isUsedOnceDmd (Id -> Demand
    idDemandInfo Id
    bndr) = UpdateFlag
    SingleEntry
                 | Bool
    otherwise                         = UpdateFlag
    Updatable

        -- CAF cost centres generated for -fcaf-all
        caf_cc :: CostCentre
    caf_cc = Id -> Module -> CostCentre
    mkAutoCC Id
    bndr Module
    modl
        caf_ccs :: CostCentreStack
    caf_ccs = CostCentre -> CostCentreStack
    mkSingletonCCS CostCentre
    caf_cc
               -- careful: the binder might be :Main.main,
               -- which doesn't belong to module mod_name.
               -- bug #249, tests prof001, prof002
        modl :: Module
    modl | Just Module
    m <- Name -> Maybe Module
    nameModule_maybe (Id -> Name
    idName Id
    bndr) = Module
    m
             | Bool
    otherwise = Module
    this_mod

        -- default CAF cost centre
        (CostCentre
    _, CostCentreStack
    all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
    getAllCAFsCC Module
    this_mod

    -- Generate a non-top-level RHS. Cost-centre is always currentCCS,
    -- see Note [Cost-centre initialization plan].
    mkStgRhs :: Id -> PreStgRhs -> StgRhs
    mkStgRhs :: Id -> PreStgRhs -> StgRhs
    mkStgRhs Id
    bndr (PreStgRhs [Id]
    bndrs StgExpr
    rhs)
      | Bool -> Bool
    not (forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    bndrs)
      = forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent
                      CostCentreStack
    currentCCS
                      UpdateFlag
    ReEntrant
                      [Id]
    bndrs StgExpr
    rhs

      -- After this point we know that `bndrs` is empty,
      -- so this is not a function binding
      | Id -> Bool
    isJoinId Id
    bndr -- must be a nullary join point
      = ASSERT(idJoinArity bndr == 0)
        forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent
                      CostCentreStack
    currentCCS
                      UpdateFlag
    ReEntrant -- ignored for LNE
                      [] StgExpr
    rhs

      | StgConApp DataCon
    con XConApp 'Vanilla
    mn [StgArg]
    args [Type]
    _ <- StgExpr
    unticked_rhs
      = forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    currentCCS DataCon
    con XConApp 'Vanilla
    mn [StgTickish]
    ticks [StgArg]
    args

      | Bool
    otherwise
      = forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent
                      CostCentreStack
    currentCCS
                      UpdateFlag
    upd_flag [] StgExpr
    rhs
      where
        ([StgTickish]
    ticks, StgExpr
    unticked_rhs) = forall (p :: StgPass).
    (StgTickish -> Bool)
    -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
    stripStgTicksTop (Bool -> Bool
    not forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishIsCode) StgExpr
    rhs

        upd_flag :: UpdateFlag
    upd_flag | Demand -> Bool
    isUsedOnceDmd (Id -> Demand
    idDemandInfo Id
    bndr) = UpdateFlag
    SingleEntry
                 | Bool
    otherwise                         = UpdateFlag
    Updatable

      {-
        SDM: disabled.  Eval/Apply can't handle functions with arity zero very
        well; and making these into simple non-updatable thunks breaks other
        assumptions (namely that they will be entered only once).

        upd_flag | isPAP env rhs  = ReEntrant
                 | otherwise      = Updatable

    -- Detect thunks which will reduce immediately to PAPs, and make them
    -- non-updatable.  This has several advantages:
    --
    --         - the non-updatable thunk behaves exactly like the PAP,
    --
    --         - the thunk is more efficient to enter, because it is
    --           specialised to the task.
    --
    --         - we save one update frame, one stg_update_PAP, one update
    --           and lots of PAP_enters.
    --
    --         - in the case where the thunk is top-level, we save building
    --           a black hole and furthermore the thunk isn't considered to
    --           be a CAF any more, so it doesn't appear in any SRTs.
    --
    -- We do it here, because the arity information is accurate, and we need
    -- to do it before the SRT pass to save the SRT entries associated with
    -- any top-level PAPs.

    isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
                                  where
                                     arity = stgArity f (lookupBinding env f)
    isPAP env _               = False

    -}

    {- ToDo:
              upd = if isOnceDem dem
                        then (if isNotTop toplev
                                then SingleEntry    -- HA!  Paydirt for "dem"
                                else
                         (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
                         Updatable)
                    else Updatable
            -- For now we forbid SingleEntry CAFs; they tickle the
            -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
            -- and I don't understand why.  There's only one SE_CAF (well,
            -- only one that tickled a great gaping bug in an earlier attempt
            -- at ClosureInfo.getEntryConvention) in the whole of nofib,
            -- specifically Main.lvl6 in spectral/cryptarithm2.
            -- So no great loss.  KSW 2000-07.
    -}

    -- ---------------------------------------------------------------------------
    -- A monad for the core-to-STG pass
    -- ---------------------------------------------------------------------------

    -- There's a lot of stuff to pass around, so we use this CtsM
    -- ("core-to-STG monad") monad to help.  All the stuff here is only passed
    -- *down*.

    newtype CtsM a = CtsM
        { forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
    unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
                 -> IdEnv HowBound
                 -> a
        }
        deriving (forall a b. a -> CtsM b -> CtsM a
    forall a b. (a -> b) -> CtsM a -> CtsM b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    <$ :: forall a b. a -> CtsM b -> CtsM a
    $c<$ :: forall a b. a -> CtsM b -> CtsM a
    fmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
    $cfmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
    Functor)

    data HowBound
      = ImportBound         -- Used only as a response to lookupBinding; never
                            -- exists in the range of the (IdEnv HowBound)

      | LetBound            -- A let(rec) in this module
            LetInfo         -- Whether top level or nested
            Arity           -- Its arity (local Ids don't have arity info at this point)

      | LambdaBound         -- Used for both lambda and case
      deriving (HowBound -> HowBound -> Bool
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: HowBound -> HowBound -> Bool
    $c/= :: HowBound -> HowBound -> Bool
    == :: HowBound -> HowBound -> Bool
    $c== :: HowBound -> HowBound -> Bool
    Eq)

    data LetInfo
      = TopLet              -- top level things
      | NestedLet
      deriving (LetInfo -> LetInfo -> Bool
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: LetInfo -> LetInfo -> Bool
    $c/= :: LetInfo -> LetInfo -> Bool
    == :: LetInfo -> LetInfo -> Bool
    $c== :: LetInfo -> LetInfo -> Bool
    Eq)

    -- For a let(rec)-bound variable, x, we record LiveInfo, the set of
    -- variables that are live if x is live.  This LiveInfo comprises
    --         (a) dynamic live variables (ones with a non-top-level binding)
    --         (b) static live variables (CAFs or things that refer to CAFs)
    --
    -- For "normal" variables (a) is just x alone.  If x is a let-no-escaped
    -- variable then x is represented by a code pointer and a stack pointer
    -- (well, one for each stack).  So all of the variables needed in the
    -- execution of x are live if x is, and are therefore recorded in the
    -- LetBound constructor; x itself *is* included.
    --
    -- The set of dynamic live variables is guaranteed ot have no further
    -- let-no-escaped variables in it.

    -- The std monad functions:

    initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
    initCts :: forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
    initCts DynFlags
    dflags IdEnv HowBound
    env CtsM a
    m = forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
    unCtsM CtsM a
    m DynFlags
    dflags IdEnv HowBound
    env

    {-# INLINE thenCts #-}
    {-# INLINE returnCts #-}

    returnCts :: a -> CtsM a
    returnCts :: forall a. a -> CtsM a
    returnCts a
    e = forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
    CtsM forall a b. (a -> b) -> a -> b
    $ \DynFlags
    _ IdEnv HowBound
    _ -> a
    e

    thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
    thenCts :: forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
    thenCts CtsM a
    m a -> CtsM b
    k = forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
    CtsM forall a b. (a -> b) -> a -> b
    $ \DynFlags
    dflags IdEnv HowBound
    env
      -> forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
    unCtsM (a -> CtsM b
    k (forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
    unCtsM CtsM a
    m DynFlags
    dflags IdEnv HowBound
    env)) DynFlags
    dflags IdEnv HowBound
    env

    instance Applicative CtsM where
        pure :: forall a. a -> CtsM a
    pure = forall a. a -> CtsM a
    returnCts
        <*> :: forall a b. CtsM (a -> b) -> CtsM a -> CtsM b
    (<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad CtsM where
        >>= :: forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
    (>>=)  = forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
    thenCts

    instance HasDynFlags CtsM where
        getDynFlags :: CtsM DynFlags
    getDynFlags = forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
    CtsM forall a b. (a -> b) -> a -> b
    $ \DynFlags
    dflags IdEnv HowBound
    _ -> DynFlags
    dflags

    -- Functions specific to this monad:

    extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts :: forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [(Id, HowBound)]
    ids_w_howbound CtsM a
    expr
       =    forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
    CtsM forall a b. (a -> b) -> a -> b
    $   \DynFlags
    dflags IdEnv HowBound
    env
       -> forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
    unCtsM CtsM a
    expr DynFlags
    dflags (forall a. VarEnv a -> [(Id, a)] -> VarEnv a
    extendVarEnvList IdEnv HowBound
    env [(Id, HowBound)]
    ids_w_howbound)

    lookupVarCts :: Id -> CtsM HowBound
    lookupVarCts :: Id -> CtsM HowBound
    lookupVarCts Id
    v = forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
    CtsM forall a b. (a -> b) -> a -> b
    $ \DynFlags
    _ IdEnv HowBound
    env -> IdEnv HowBound -> Id -> HowBound
    lookupBinding IdEnv HowBound
    env Id
    v

    lookupBinding :: IdEnv HowBound -> Id -> HowBound
    lookupBinding :: IdEnv HowBound -> Id -> HowBound
    lookupBinding IdEnv HowBound
    env Id
    v = case forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv IdEnv HowBound
    env Id
    v of
                            Just HowBound
    xx -> HowBound
    xx
                            Maybe HowBound
    Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound

    getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
    getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
    getAllCAFsCC Module
    this_mod =
        let
          span :: SrcSpan
    span = CLabelString -> SrcSpan
    mkGeneralSrcSpan (String -> CLabelString
    mkFastString String
    "<entire-module>") -- XXX do better
          all_cafs_cc :: CostCentre
    all_cafs_cc  = Module -> SrcSpan -> CostCentre
    mkAllCafsCC Module
    this_mod SrcSpan
    span
          all_cafs_ccs :: CostCentreStack
    all_cafs_ccs = CostCentre -> CostCentreStack
    mkSingletonCCS CostCentre
    all_cafs_cc
        in
          (CostCentre
    all_cafs_cc, CostCentreStack
    all_cafs_ccs)

    -- Misc.

    filterStgBinders :: [Var] -> [Var]
    filterStgBinders :: [Id] -> [Id]
    filterStgBinders [Id]
    bndrs = forall a. (a -> Bool) -> [a] -> [a]
    filter Id -> Bool
    isId [Id]
    bndrs

    myCollectBinders :: Expr Var -> ([Var], Expr Var)
    myCollectBinders :: CoreArg -> ([Id], CoreArg)
    myCollectBinders CoreArg
    expr
      = forall {a}. [a] -> Expr a -> ([a], Expr a)
    go [] CoreArg
    expr
      where
        go :: [a] -> Expr a -> ([a], Expr a)
    go [a]
    bs (Lam a
    b Expr a
    e)          = [a] -> Expr a -> ([a], Expr a)
    go (a
    bforall a. a -> [a] -> [a]
    :[a]
    bs) Expr a
    e
        go [a]
    bs (Cast Expr a
    e Coercion
    _)         = [a] -> Expr a -> ([a], Expr a)
    go [a]
    bs Expr a
    e
        go [a]
    bs Expr a
    e                  = (forall a. [a] -> [a]
    reverse [a]
    bs, Expr a
    e)

    -- | If the argument expression is (potential chain of) 'App', return the head
    -- of the app chain, and collect ticks/args along the chain.
    myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])
    myCollectArgs :: HasDebugCallStack => CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
    myCollectArgs CoreArg
    expr
      = CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    expr [] []
      where
        go :: CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go h :: CoreArg
    h@(Var Id
    _v)       [CoreArg]
    as [CoreTickish]
    ts = (CoreArg
    h, [CoreArg]
    as, [CoreTickish]
    ts)
        go (App CoreArg
    f CoreArg
    a)        [CoreArg]
    as [CoreTickish]
    ts = CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    f (CoreArg
    aforall a. a -> [a] -> [a]
    :[CoreArg]
    as) [CoreTickish]
    ts
        go (Tick CoreTickish
    t CoreArg
    e)       [CoreArg]
    as [CoreTickish]
    ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as
                                           , ppr e $$ ppr as $$ ppr ts )
                                    -- See Note [Ticks in applications]
                                    CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    e [CoreArg]
    as (CoreTickish
    tforall a. a -> [a] -> [a]
    :[CoreTickish]
    ts) -- ticks can appear in type apps
        go (Cast CoreArg
    e Coercion
    _)       [CoreArg]
    as [CoreTickish]
    ts = CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    e [CoreArg]
    as [CoreTickish]
    ts
        go (Lam Id
    b CoreArg
    e)        [CoreArg]
    as [CoreTickish]
    ts
           | Id -> Bool
    isTyVar Id
    b            = CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    e [CoreArg]
    as [CoreTickish]
    ts -- Note [Collect args]
        go CoreArg
    e                [CoreArg]
    as [CoreTickish]
    ts = (CoreArg
    e, [CoreArg]
    as, [CoreTickish]
    ts)

    {- Note [Collect args]
    ~~~~~~~~~~~~~~~~~~~~~~
    This big-lambda case occurred following a rather obscure eta expansion.
    It all seems a bit yukky to me.

    Note [Ticks in applications]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We can get an application like
       (tick t f) True False
    via inlining in the CorePrep pass; see Note [Inlining in CorePrep]
    in GHC.CoreToStg.Prep.  The tick does not satisfy tickishIsCode;
    the inlining-in-CorePrep happens for cpExprIsTrivial which tests
    tickishIsCode.

    So we test the same thing here, pushing any non-code ticks to
    the top (they don't generate any code, after all).  This showed
    up in the fallout from fixing #19360.
    -}

    stgArity :: Id -> HowBound -> Arity
    stgArity :: Id -> HowBound -> JoinArity
    stgArity Id
    _ (LetBound LetInfo
    _ JoinArity
    arity) = JoinArity
    arity
    stgArity Id
    f HowBound
    ImportBound        = Id -> JoinArity
    idArity Id
    f
    stgArity Id
    _ HowBound
    LambdaBound        = JoinArity
    0