    {-# LANGUAGE DataKinds #-}

    {-# 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 ( CoreToStgOpts (..), coreToStg ) where

    import GHC.Prelude

    import GHC.Core
    import GHC.Core.Utils
    import GHC.Core.Opt.Arity   ( manifestArity )
    import GHC.Core.Type
    import GHC.Core.TyCon
    import GHC.Core.DataCon

    import GHC.Stg.Syntax
    import GHC.Stg.Debug
    import GHC.Stg.Utils

    import GHC.Types.RepType
    import GHC.Types.Id.Make ( coercionTokenId )
    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.CostCentre
    import GHC.Types.Tickish
    import GHC.Types.Var.Env
    import GHC.Types.Name   ( isExternalName, nameModule_maybe )
    import GHC.Types.Basic  ( Arity, TypeOrConstraint(..) )
    import GHC.Types.Literal
    import GHC.Types.ForeignCall
    import GHC.Types.IPE
    import GHC.Types.Demand    ( isAtMostOnceDmd )
    import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )

    import GHC.Unit.Module
    import GHC.Data.FastString
    import GHC.Platform        ( Platform )
    import GHC.Platform.Ways
    import GHC.Builtin.PrimOps

    import GHC.Utils.Outputable
    import GHC.Utils.Monad
    import GHC.Utils.Misc (HasDebugCallStack)
    import GHC.Utils.Panic

    import Control.Monad (ap)

    -- 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 :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram
              -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
    coreToStg :: CoreToStgOpts
    -> Module
    -> ModLocation
    -> CoreProgram
    -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
    coreToStg opts :: CoreToStgOpts
    opts@CoreToStgOpts
      { coreToStg_ways :: CoreToStgOpts -> Ways
    coreToStg_ways = Ways
    ways
      , coreToStg_AutoSccsOnIndividualCafs :: CoreToStgOpts -> Bool
    coreToStg_AutoSccsOnIndividualCafs = Bool
    opt_AutoSccsOnIndividualCafs
      , coreToStg_InfoTableMap :: CoreToStgOpts -> Bool
    coreToStg_InfoTableMap = Bool
    opt_InfoTableMap
      , coreToStg_stgDebugOpts :: CoreToStgOpts -> StgDebugOpts
    coreToStg_stgDebugOpts = StgDebugOpts
    stgDebugOpts
      } 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')
          = CoreToStgOpts
    -> Module
    -> IdEnv HowBound
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
    coreTopBindsToStg CoreToStgOpts
    opts Module
    this_mod IdEnv HowBound
    forall a. VarEnv a
    emptyVarEnv CollectedCCs
    emptyCollectedCCs CoreProgram
    pgm

        -- See Note [Mapping Info Tables to Source Positions]
        (![StgTopBinding]
    pgm'', !InfoTableProvMap
    denv)
          | Bool
    opt_InfoTableMap
          = StgDebugOpts
    -> ModLocation
    -> [StgTopBinding]
    -> ([StgTopBinding], InfoTableProvMap)
    collectDebugInformation StgDebugOpts
    stgDebugOpts ModLocation
    ml [StgTopBinding]
    pgm'
          | Bool
    otherwise = ([StgTopBinding]
    pgm', InfoTableProvMap
    emptyInfoTableProvMap)

        prof :: Bool
    prof = Ways -> Way -> Bool
    hasWay Ways
    ways Way
    WayProf

        final_ccs :: CollectedCCs
    final_ccs
          | Bool
    prof Bool -> Bool -> Bool
    && Bool
    opt_AutoSccsOnIndividualCafs
          = ([CostCentre]
    local_ccs,[CostCentreStack]
    local_cc_stacks)  -- don't need "all CAFs" CC
          | Bool
    prof
          = (CostCentre
    all_cafs_ccCostCentre -> [CostCentre] -> [CostCentre]
    forall a. a -> [a] -> [a]
    :[CostCentre]
    local_ccs, CostCentreStack
    all_cafs_ccsCostCentreStack -> [CostCentreStack] -> [CostCentreStack]
    forall 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
        :: CoreToStgOpts
        -> Module
        -> IdEnv HowBound           -- environment for the bindings
        -> CollectedCCs
        -> CoreProgram
        -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])

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

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

    coreTopBindToStg :: CoreToStgOpts
    -> Module
    -> IdEnv HowBound
    -> CollectedCCs
    -> CoreBind
    -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
    coreTopBindToStg CoreToStgOpts
    _ 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' = IdEnv HowBound -> Id -> HowBound -> IdEnv HowBound
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv IdEnv HowBound
    env Id
    id HowBound
    how_bound
            how_bound :: HowBound
    how_bound = LetInfo -> Int -> HowBound
    LetBound LetInfo
    TopLet Int
    0
        in (IdEnv HowBound
    env', CollectedCCs
    ccs, Id -> ByteString -> StgTopBinding
    forall (pass :: StgPass). Id -> ByteString -> GenStgTopBinding pass
    StgTopStringLit Id
    id ByteString
    str)

    coreTopBindToStg opts :: CoreToStgOpts
    opts@CoreToStgOpts
      { coreToStg_platform :: CoreToStgOpts -> Platform
    coreToStg_platform = Platform
    platform
      } Module
    this_mod IdEnv HowBound
    env CollectedCCs
    ccs (NonRec Id
    id CoreArg
    rhs)
      = let
            env' :: IdEnv HowBound
    env'      = IdEnv HowBound -> Id -> HowBound -> IdEnv HowBound
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv IdEnv HowBound
    env Id
    id HowBound
    how_bound
            how_bound :: HowBound
    how_bound = LetInfo -> Int -> HowBound
    LetBound LetInfo
    TopLet (Int -> HowBound) -> Int -> HowBound
    forall a b. (a -> b) -> a -> b
    $! CoreArg -> Int
    manifestArity CoreArg
    rhs

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

            bind :: StgTopBinding
    bind = GenStgBinding 'Vanilla -> StgTopBinding
    forall (pass :: StgPass).
    GenStgBinding pass -> GenStgTopBinding pass
    StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
    -> GenStgBinding 'Vanilla -> StgTopBinding
    forall a b. (a -> b) -> a -> b
    $ BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
    forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec Id
    BinderP 'Vanilla
    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 opts :: CoreToStgOpts
    opts@CoreToStgOpts
      { coreToStg_platform :: CoreToStgOpts -> Platform
    coreToStg_platform = Platform
    platform
      } Module
    this_mod IdEnv HowBound
    env CollectedCCs
    ccs (Rec [(Id, CoreArg)]
    pairs)
      = Bool
    -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
    -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
    forall a. HasCallStack => Bool -> a -> a
    assert (Bool -> Bool
    not ([(Id, CoreArg)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(Id, CoreArg)]
    pairs)) ((IdEnv HowBound, CollectedCCs, StgTopBinding)
     -> (IdEnv HowBound, CollectedCCs, StgTopBinding))
    -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
    -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
    forall a b. (a -> b) -> a -> b
    $
        let
            extra_env' :: [(Id, HowBound)]
    extra_env' = [ (Id
    b, LetInfo -> Int -> HowBound
    LetBound LetInfo
    TopLet (Int -> HowBound) -> Int -> HowBound
    forall a b. (a -> b) -> a -> b
    $! CoreArg -> Int
    manifestArity CoreArg
    rhs)
                         | (Id
    b, CoreArg
    rhs) <- [(Id, CoreArg)]
    pairs ]
            env' :: IdEnv HowBound
    env' = IdEnv HowBound -> [(Id, HowBound)] -> IdEnv HowBound
    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', [(Id, StgRhs)]
    stg_rhss)
              = Platform
    -> IdEnv HowBound
    -> CtsM (CollectedCCs, [(Id, StgRhs)])
    -> (CollectedCCs, [(Id, StgRhs)])
    forall a. Platform -> IdEnv HowBound -> CtsM a -> a
    initCts Platform
    platform IdEnv HowBound
    env' (CtsM (CollectedCCs, [(Id, StgRhs)])
     -> (CollectedCCs, [(Id, StgRhs)]))
    -> CtsM (CollectedCCs, [(Id, StgRhs)])
    -> (CollectedCCs, [(Id, StgRhs)])
    forall a b. (a -> b) -> a -> b
    $ (CollectedCCs
     -> (Id, CoreArg) -> CtsM (CollectedCCs, (Id, StgRhs)))
    -> CollectedCCs
    -> [(Id, CoreArg)]
    -> CtsM (CollectedCCs, [(Id, StgRhs)])
    forall (m :: * -> *) (t :: * -> *) acc x y.
    (Monad m, Traversable t) =>
    (acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
    mapAccumLM (CoreToStgOpts
    -> Module
    -> CollectedCCs
    -> (Id, CoreArg)
    -> CtsM (CollectedCCs, (Id, StgRhs))
    coreToTopStgRhs CoreToStgOpts
    opts Module
    this_mod) CollectedCCs
    ccs [(Id, CoreArg)]
    pairs
            bind :: StgTopBinding
    bind = GenStgBinding 'Vanilla -> StgTopBinding
    forall (pass :: StgPass).
    GenStgBinding pass -> GenStgTopBinding pass
    StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
    -> GenStgBinding 'Vanilla -> StgTopBinding
    forall a b. (a -> b) -> a -> b
    $ [(BinderP 'Vanilla, StgRhs)] -> GenStgBinding 'Vanilla
    forall (pass :: StgPass).
    [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    StgRec [(Id, StgRhs)]
    [(BinderP 'Vanilla, StgRhs)]
    stg_rhss
        in
        (IdEnv HowBound
    env', CollectedCCs
    ccs', StgTopBinding
    bind)

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

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

           ; let (stg_rhs, ccs') =
                   mkTopStgRhs opts this_mod ccs bndr new_rhs
                 stg_arity =
                   StgRhs -> Int
    stgRhsArity StgRhs
    stg_rhs

           ; pure (ccs', (bndr, assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs)) }
      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 :: Int -> Bool
    arity_ok Int
    stg_arity
           | Name -> Bool
    isExternalName (Id -> Name
    idName Id
    bndr) = Int
    id_arity Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    stg_arity
           | Bool
    otherwise                    = Bool
    True
        id_arity :: Int
    id_arity  = Id -> Int
    idArity Id
    bndr
        mk_arity_msg :: Int -> SDoc
    mk_arity_msg Int
    stg_arity
            = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    bndr,
                    String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Id arity:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    id_arity,
                    String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "STG arity:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    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 bignum literal 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
    LitNumBigNat Integer
    _))  = String -> CtsM StgExpr
    forall a. HasCallStack => String -> a
    panic String
    "coreToStgExpr: LitNumBigNat"
    coreToStgExpr (Lit Literal
    l)                           = StgExpr -> CtsM StgExpr
    forall a. a -> CtsM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Literal -> StgExpr
    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 Literal
    l | Literal -> Bool
    isLitRubbish Literal
    l             -- If there is LitRubbish at the head,
                                             --    discard the arguments
                                             --    Recompute representation, because in
                                             --    '(RUBBISH[rep] x) :: (T :: TYPE rep2)'
                                             --    rep might not be equal to rep2
                -> StgExpr -> CtsM StgExpr
    forall a. a -> CtsM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Literal -> StgExpr
    forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit (Literal -> StgExpr) -> Literal -> StgExpr
    forall a b. (a -> b) -> a -> b
    $ TypeOrConstraint -> RuntimeRepType -> Literal
    LitRubbish TypeOrConstraint
    TypeLike (RuntimeRepType -> Literal) -> RuntimeRepType -> Literal
    forall a b. (a -> b) -> a -> b
    $ HasDebugCallStack => RuntimeRepType -> RuntimeRepType
    RuntimeRepType -> RuntimeRepType
    getRuntimeRep (HasDebugCallStack => CoreArg -> RuntimeRepType
    CoreArg -> RuntimeRepType
    exprType CoreArg
    expr))

          CoreArg
    _     -> String -> SDoc -> CtsM StgExpr
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "coreToStgExpr - Invalid app head:" (CoreArg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreArg
    expr)
        where
          (CoreArg
    app_head, [CoreArg]
    args, [CoreTickish]
    ticks) = HasDebugCallStack => CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
    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
    CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    body

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

    coreToStgExpr (Tick CoreTickish
    tick CoreArg
    expr)
      = do
           let !stg_tick :: StgTickish
    stg_tick = RuntimeRepType -> CoreTickish -> StgTickish
    coreToStgTick (HasDebugCallStack => CoreArg -> RuntimeRepType
    CoreArg -> RuntimeRepType
    exprType CoreArg
    expr) CoreTickish
    tick
           !expr2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    expr
           return (StgTick stg_tick expr2)

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

    -- Cases require a little more real work.
    coreToStgExpr (Case CoreArg
    scrut Id
    bndr RuntimeRepType
    _ [Alt Id]
    alts)
      | [Alt Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Alt Id]
    alts
      -- 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.
      = HasDebugCallStack => CoreArg -> CtsM StgExpr
    CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    scrut

      | Just CoreArg
    rhs <- CoreArg -> Id -> [Alt Id] -> Maybe CoreArg
    isUnsafeEqualityCase CoreArg
    scrut Id
    bndr [Alt Id]
    alts
      -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
      = HasDebugCallStack => CoreArg -> CtsM StgExpr
    CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    rhs

      | Bool
    otherwise
      = do { scrut2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    scrut
           ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
           ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }
      where
        vars_alt :: CoreAlt -> CtsM StgAlt
        vars_alt :: Alt Id -> CtsM StgAlt
    vars_alt (Alt AltCon
    con [Id]
    binders CoreArg
    rhs)
          = let     -- Remove type variables
                binders' :: [Id]
    binders' = [Id] -> [Id]
    filterStgBinders [Id]
    binders
            in
            [(Id, HowBound)] -> CtsM StgAlt -> CtsM StgAlt
    forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [(Id
    b, HowBound
    LambdaBound) | Id
    b <- [Id]
    binders'] (CtsM StgAlt -> CtsM StgAlt) -> CtsM StgAlt -> CtsM StgAlt
    forall a b. (a -> b) -> a -> b
    $ do
            rhs2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    rhs
            return $! GenStgAlt{ alt_con   = con
                               , alt_bndrs = binders'
                               , alt_rhs   = rhs2
                               }

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

    mkStgAltType :: Id -> [CoreAlt] -> AltType
    mkStgAltType :: Id -> [Alt Id] -> AltType
    mkStgAltType Id
    bndr [Alt Id]
    alts
      | RuntimeRepType -> Bool
    isUnboxedTupleType RuntimeRepType
    bndr_ty Bool -> Bool -> Bool
    || RuntimeRepType -> Bool
    isUnboxedSumType RuntimeRepType
    bndr_ty
      = Int -> AltType
    MultiValAlt ([PrimRep] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    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 RuntimeRepType -> Maybe TyCon
    tyConAppTyCon_maybe (RuntimeRepType -> RuntimeRepType
    unwrapType RuntimeRepType
    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          -> Bool -> SDoc -> AltType -> AltType
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (TyCon -> Bool
    _is_poly_alt_tycon TyCon
    tc) (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc) AltType
    PolyAlt
              Maybe TyCon
    Nothing                -> AltType
    PolyAlt
          [PrimRep
    non_gcd] -> PrimRep -> AltType
    PrimAlt PrimRep
    non_gcd
          [PrimRep]
    not_unary -> Int -> AltType
    MultiValAlt ([PrimRep] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [PrimRep]
    not_unary)
      where
       bndr_ty :: RuntimeRepType
    bndr_ty   = Id -> RuntimeRepType
    idType Id
    bndr
       prim_reps :: [PrimRep]
    prim_reps = HasDebugCallStack => RuntimeRepType -> [PrimRep]
    RuntimeRepType -> [PrimRep]
    typePrimRep RuntimeRepType
    bndr_ty

       _is_poly_alt_tycon :: TyCon -> Bool
    _is_poly_alt_tycon TyCon
    tc
            =  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 =
                    Bool -> AltType -> AltType
    forall a. HasCallStack => Bool -> a -> a
    assert ([Alt Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Alt Id]
    data_alts)
                    AltType
    PolyAlt
            where
                    ([Alt Id]
    data_alts, Maybe CoreArg
    _deflt) = [Alt Id] -> ([Alt Id], Maybe CoreArg)
    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
        (args', ticks') <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs [CoreArg]
    args
        how_bound <- lookupVarCts f

        let
            n_val_args       = [CoreArg] -> Int
    forall b. [Arg b] -> Int
    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   = Id -> HowBound -> Int
    stgArity Id
    f HowBound
    how_bound
            saturated = Int
    f_arity Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    n_val_args

            res_ty = HasDebugCallStack => CoreArg -> RuntimeRepType
    CoreArg -> RuntimeRepType
    exprType (CoreArg -> [CoreArg] -> CoreArg
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Id -> CoreArg
    forall b. Id -> Expr b
    Var Id
    f) [CoreArg]
    args)
            app = case Id -> IdDetails
    idDetails Id
    f of
                    DataConWorkId DataCon
    dc
                      | Bool
    saturated    -> if DataCon -> Bool
    isUnboxedSumDataCon DataCon
    dc then
                                          DataCon -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> StgExpr
    forall (pass :: StgPass).
    DataCon
    -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
    StgConApp DataCon
    dc ConstructorNumber
    NoNumber [StgArg]
    args' ([CoreArg] -> [[PrimRep]]
    sumPrimReps [CoreArg]
    args)
                                        else
                                          DataCon -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> StgExpr
    forall (pass :: StgPass).
    DataCon
    -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
    StgConApp DataCon
    dc ConstructorNumber
    NoNumber [StgArg]
    args' []

                    -- 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 ConcreteTyVars
    _    -> -- assertPpr saturated (ppr f <+> ppr args) $
                                        StgOp -> [StgArg] -> RuntimeRepType -> StgExpr
    forall (pass :: StgPass).
    StgOp -> [StgArg] -> RuntimeRepType -> GenStgExpr pass
    StgOpApp (PrimOp -> StgOp
    StgPrimOp PrimOp
    op) [StgArg]
    args' RuntimeRepType
    res_ty

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

                    -- A regular foreign call.
                    FCallId ForeignCall
    call     -> Bool -> StgExpr -> StgExpr
    forall a. HasCallStack => Bool -> a -> a
    assert Bool
    saturated (StgExpr -> StgExpr) -> StgExpr -> StgExpr
    forall a b. (a -> b) -> a -> b
    $
                                        StgOp -> [StgArg] -> RuntimeRepType -> StgExpr
    forall (pass :: StgPass).
    StgOp -> [StgArg] -> RuntimeRepType -> GenStgExpr pass
    StgOpApp (ForeignCall -> RuntimeRepType -> StgOp
    StgFCallOp ForeignCall
    call (Id -> RuntimeRepType
    idType Id
    f)) [StgArg]
    args' RuntimeRepType
    res_ty

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

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

        -- Forcing these fixes a leak in the code generator, noticed while
        -- profiling for #4367
        app `seq` return tapp

    -- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's
    -- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0
    -- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0]
    -- and we return the list [[LiftedRep], [IntRep]].
    -- See Note [Representations in StgConApp] in GHC.Stg.Unarise.
    sumPrimReps :: [CoreArg] -> [[PrimRep]]
    sumPrimReps :: [CoreArg] -> [[PrimRep]]
    sumPrimReps (Type RuntimeRepType
    ty : [CoreArg]
    args) | RuntimeRepType -> Bool
    isRuntimeRepKindedTy RuntimeRepType
    ty
      = HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep]
    SDoc -> RuntimeRepType -> [PrimRep]
    runtimeRepPrimRep (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "sumPrimReps") RuntimeRepType
    ty [PrimRep] -> [[PrimRep]] -> [[PrimRep]]
    forall a. a -> [a] -> [a]
    : [CoreArg] -> [[PrimRep]]
    sumPrimReps [CoreArg]
    args
    sumPrimReps [CoreArg]
    _ = []
    -- ---------------------------------------------------------------------------
    -- Argument lists
    -- This is the guy that turns applications into A-normal form
    -- ---------------------------------------------------------------------------

    getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg
    -- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.
    -- CoreArgs may not immediately look trivial, e.g., `case e of {}` or
    -- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.
    -- Good thing we can just call `trivial_expr_fold` here.
    getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg
    getStgArgFromTrivialArg CoreArg
    e = (Id -> StgArg)
    -> (Literal -> StgArg) -> StgArg -> StgArg -> CoreArg -> StgArg
    forall r. (Id -> r) -> (Literal -> r) -> r -> r -> CoreArg -> r
    trivial_expr_fold Id -> StgArg
    StgVarArg Literal -> StgArg
    StgLitArg StgArg
    panic StgArg
    panic CoreArg
    e
      where
        panic :: StgArg
    panic = String -> SDoc -> StgArg
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "getStgArgFromTrivialArg" (CoreArg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreArg
    e)

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

    coreToStgArgs (Type RuntimeRepType
    _ : [CoreArg]
    args) = do     -- Type argument
        (args', ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs [CoreArg]
    args
        return (args', ts)

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

    coreToStgArgs (CoreArg
    arg : [CoreArg]
    args) = do         -- Non-type argument
        (stg_args, ticks) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
    coreToStgArgs [CoreArg]
    args
        -- We know that `arg` must be trivial, but it may contain Ticks.
        -- Example from test case `decodeMyStack`:
        --   $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])
        -- Note that unfortunately the Tick is not at the top.
        -- So we'll traverse the expression twice:
        --   * Once with `stripTicksT` (which collects *all* ticks from the expression)
        --   * and another time with `getStgArgFromTrivialArg`.
        -- Since the argument is trivial, the only place the Tick can occur is
        -- somehow wrapping a variable (give or take type args, as above).
        platform <- getPlatform
        let arg_ty = HasDebugCallStack => CoreArg -> RuntimeRepType
    CoreArg -> RuntimeRepType
    exprType CoreArg
    arg
            ticks' = (CoreTickish -> StgTickish) -> [CoreTickish] -> [StgTickish]
    forall a b. (a -> b) -> [a] -> [b]
    map (RuntimeRepType -> CoreTickish -> StgTickish
    coreToStgTick RuntimeRepType
    arg_ty) ((CoreTickish -> Bool) -> CoreArg -> [CoreTickish]
    forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
    stripTicksT (Bool -> Bool
    not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishIsCode) CoreArg
    arg)
            arg' = HasDebugCallStack => CoreArg -> StgArg
    CoreArg -> StgArg
    getStgArgFromTrivialArg CoreArg
    arg
            arg_rep = HasDebugCallStack => RuntimeRepType -> [PrimRep]
    RuntimeRepType -> [PrimRep]
    typePrimRep RuntimeRepType
    arg_ty
            stg_arg_rep = StgArg -> [PrimRep]
    stgArgRep StgArg
    arg'
            bad_args = Bool -> Bool
    not (Platform -> [PrimRep] -> [PrimRep] -> Bool
    primRepsCompatible Platform
    platform [PrimRep]
    arg_rep [PrimRep]
    stg_arg_rep)

        massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)
        warnPprTraceM bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg)

        return (arg' : stg_args, ticks' ++ ticks)

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

    -- ---------------------------------------------------------------------------
    -- 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, CoreArg -> Bool
    forall b. Expr b -> Bool
    isTyCoArg CoreArg
    rhs
      = HasDebugCallStack => CoreArg -> CtsM StgExpr
    CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    body

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

              -- Do the body
             ; body2 <- extendVarEnvCts env_ext $
                        coreToStgExpr body

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

            ; return new_let }
      where
        mk_binding :: a -> CoreArg -> (a, HowBound)
    mk_binding a
    binder CoreArg
    rhs
            = (a
    binder, LetInfo -> Int -> HowBound
    LetBound LetInfo
    NestedLet (CoreArg -> Int
    manifestArity CoreArg
    rhs))

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

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

            return (StgNonRec binder rhs2, [env_ext_item])

        vars_bind (Rec [(Id, CoreArg)]
    pairs)
          =    let
                    binders :: [Id]
    binders = ((Id, CoreArg) -> Id) -> [(Id, CoreArg)] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map (Id, CoreArg) -> Id
    forall a b. (a, b) -> a
    fst [(Id, CoreArg)]
    pairs
                    env_ext :: [(Id, HowBound)]
    env_ext = [ Id -> CoreArg -> (Id, HowBound)
    forall {a}. a -> CoreArg -> (a, HowBound)
    mk_binding Id
    b CoreArg
    rhs
                              | (Id
    b,CoreArg
    rhs) <- [(Id, CoreArg)]
    pairs ]
               in
               [(Id, HowBound)]
    -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
    -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
    forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [(Id, HowBound)]
    env_ext (CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
     -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)]))
    -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
    -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
    forall a b. (a -> b) -> a -> b
    $ do
                  rhss2 <- ((Id, CoreArg) -> CtsM StgRhs) -> [(Id, CoreArg)] -> CtsM [StgRhs]
    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 (Id, CoreArg) -> CtsM StgRhs
    coreToStgRhs [(Id, CoreArg)]
    pairs
                  return (StgRec (binders `zip` rhss2), env_ext)

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

    coreToStgRhs :: (Id, CoreArg) -> CtsM StgRhs
    coreToStgRhs (Id
    bndr, CoreArg
    rhs) = do
        new_rhs <- HasDebugCallStack => CoreArg -> CtsM PreStgRhs
    CoreArg -> CtsM PreStgRhs
    coreToPreStgRhs CoreArg
    rhs
        return (mkStgRhs bndr new_rhs)

    -- Represents the RHS of a binding for use with mk(Top)StgRhs.
    data PreStgRhs = PreStgRhs [Id] StgExpr Type -- 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 CoreArg
    expr
      = [(Id, HowBound)] -> CtsM PreStgRhs -> CtsM PreStgRhs
    forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
    extendVarEnvCts [ (Id
    a, HowBound
    LambdaBound) | Id
    a <- [Id]
    args' ] (CtsM PreStgRhs -> CtsM PreStgRhs)
    -> CtsM PreStgRhs -> CtsM PreStgRhs
    forall a b. (a -> b) -> a -> b
    $
        do { body' <- HasDebugCallStack => CoreArg -> CtsM StgExpr
    CoreArg -> CtsM StgExpr
    coreToStgExpr CoreArg
    body
           ; return (PreStgRhs args' body' (exprType body)) }
      where
       ([Id]
    args, CoreArg
    body) = CoreArg -> ([Id], CoreArg)
    myCollectBinders CoreArg
    expr
       args' :: [Id]
    args'        = [Id] -> [Id]
    filterStgBinders [Id]
    args

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

    mkTopStgRhs :: CoreToStgOpts
    -> Module
    -> CollectedCCs
    -> Id
    -> PreStgRhs
    -> (StgRhs, CollectedCCs)
    mkTopStgRhs CoreToStgOpts
      { coreToStg_platform :: CoreToStgOpts -> Platform
    coreToStg_platform = Platform
    platform
      , coreToStg_ExternalDynamicRefs :: CoreToStgOpts -> Bool
    coreToStg_ExternalDynamicRefs = Bool
    opt_ExternalDynamicRefs
      , coreToStg_AutoSccsOnIndividualCafs :: CoreToStgOpts -> Bool
    coreToStg_AutoSccsOnIndividualCafs = Bool
    opt_AutoSccsOnIndividualCafs
      } Module
    this_mod CollectedCCs
    ccs Id
    bndr (PreStgRhs [Id]
    bndrs StgExpr
    rhs RuntimeRepType
    typ)
      | Bool -> Bool
    not ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    bndrs)
      = -- The list of arguments is non-empty, so not CAF
        ( XRhsClosure 'Vanilla
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'Vanilla]
    -> StgExpr
    -> RuntimeRepType
    -> StgRhs
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> RuntimeRepType
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    NoExtFieldSilent
    noExtFieldSilent
                        CostCentreStack
    dontCareCCS
                        UpdateFlag
    ReEntrant
                        [Id]
    [BinderP 'Vanilla]
    bndrs StgExpr
    rhs RuntimeRepType
    typ
        , CollectedCCs
    ccs )

      -- After this point we know that `bndrs` is empty,
      -- so this is not a function binding
      | StgConApp DataCon
    con ConstructorNumber
    mn [StgArg]
    args [[PrimRep]]
    _ <- StgExpr
    unticked_rhs
      , -- Dynamic StgConApps are updatable
        Bool -> Bool
    not (Platform -> Bool -> Module -> DataCon -> [StgArg] -> Bool
    isDllConApp Platform
    platform Bool
    opt_ExternalDynamicRefs Module
    this_mod DataCon
    con [StgArg]
    args)
      = -- CorePrep does this right, but just to make sure
        Bool -> SDoc -> (StgRhs, CollectedCCs) -> (StgRhs, CollectedCCs)
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Bool -> Bool
    not (DataCon -> Bool
    isUnboxedTupleDataCon DataCon
    con Bool -> Bool -> Bool
    || DataCon -> Bool
    isUnboxedSumDataCon DataCon
    con))
                  (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    bndr SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    con SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ [StgArg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [StgArg]
    args)
        ( CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> RuntimeRepType
    -> StgRhs
    forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> RuntimeRepType
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    dontCareCCS DataCon
    con ConstructorNumber
    mn [StgTickish]
    ticks [StgArg]
    args RuntimeRepType
    typ, CollectedCCs
    ccs )

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

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

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

        upd_flag :: UpdateFlag
    upd_flag | Demand -> Bool
    isAtMostOnceDmd (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 RuntimeRepType
    typ)
      | Bool -> Bool
    not ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    bndrs)
      = XRhsClosure 'Vanilla
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'Vanilla]
    -> StgExpr
    -> RuntimeRepType
    -> StgRhs
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> RuntimeRepType
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    NoExtFieldSilent
    noExtFieldSilent
                      CostCentreStack
    currentCCS
                      UpdateFlag
    ReEntrant
                      [Id]
    [BinderP 'Vanilla]
    bndrs StgExpr
    rhs RuntimeRepType
    typ

      -- 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
      = -- It might have /type/ arguments (T18328),
        -- so its JoinArity might be >0
        XRhsClosure 'Vanilla
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'Vanilla]
    -> StgExpr
    -> RuntimeRepType
    -> StgRhs
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> RuntimeRepType
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    NoExtFieldSilent
    noExtFieldSilent
                      CostCentreStack
    currentCCS
                      UpdateFlag
    ReEntrant -- ignored for LNE
                      [] StgExpr
    rhs RuntimeRepType
    typ

      | StgConApp DataCon
    con ConstructorNumber
    mn [StgArg]
    args [[PrimRep]]
    _ <- StgExpr
    unticked_rhs
      = CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> RuntimeRepType
    -> StgRhs
    forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> RuntimeRepType
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    currentCCS DataCon
    con ConstructorNumber
    mn [StgTickish]
    ticks [StgArg]
    args RuntimeRepType
    typ

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

        upd_flag :: UpdateFlag
    upd_flag | Demand -> Bool
    isAtMostOnceDmd (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 -> Platform -> IdEnv HowBound -> a
    unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs
                 -> IdEnv HowBound
                 -> a
        }
        deriving ((forall a b. (a -> b) -> CtsM a -> CtsM b)
    -> (forall a b. a -> CtsM b -> CtsM a) -> Functor CtsM
    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
    $cfmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
    fmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
    $c<$ :: forall a b. a -> CtsM b -> CtsM a
    <$ :: forall a b. a -> CtsM b -> CtsM a
    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
    (HowBound -> HowBound -> Bool)
    -> (HowBound -> HowBound -> Bool) -> Eq HowBound
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: HowBound -> HowBound -> Bool
    == :: HowBound -> HowBound -> Bool
    $c/= :: HowBound -> HowBound -> Bool
    /= :: HowBound -> HowBound -> Bool
    Eq)

    data LetInfo
      = TopLet              -- top level things
      | NestedLet
      deriving (LetInfo -> LetInfo -> Bool
    (LetInfo -> LetInfo -> Bool)
    -> (LetInfo -> LetInfo -> Bool) -> Eq LetInfo
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: LetInfo -> LetInfo -> Bool
    == :: LetInfo -> LetInfo -> Bool
    $c/= :: LetInfo -> LetInfo -> Bool
    /= :: 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 :: Platform -> IdEnv HowBound -> CtsM a -> a
    initCts :: forall a. Platform -> IdEnv HowBound -> CtsM a -> a
    initCts Platform
    platform IdEnv HowBound
    env CtsM a
    m = CtsM a -> Platform -> IdEnv HowBound -> a
    forall a. CtsM a -> Platform -> IdEnv HowBound -> a
    unCtsM CtsM a
    m Platform
    platform IdEnv HowBound
    env

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

    returnCts :: a -> CtsM a
    returnCts :: forall a. a -> CtsM a
    returnCts a
    e = (Platform -> IdEnv HowBound -> a) -> CtsM a
    forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
    CtsM ((Platform -> IdEnv HowBound -> a) -> CtsM a)
    -> (Platform -> IdEnv HowBound -> a) -> CtsM a
    forall a b. (a -> b) -> a -> b
    $ \Platform
    _ 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 = (Platform -> IdEnv HowBound -> b) -> CtsM b
    forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
    CtsM ((Platform -> IdEnv HowBound -> b) -> CtsM b)
    -> (Platform -> IdEnv HowBound -> b) -> CtsM b
    forall a b. (a -> b) -> a -> b
    $ \Platform
    platform IdEnv HowBound
    env
      -> CtsM b -> Platform -> IdEnv HowBound -> b
    forall a. CtsM a -> Platform -> IdEnv HowBound -> a
    unCtsM (a -> CtsM b
    k (CtsM a -> Platform -> IdEnv HowBound -> a
    forall a. CtsM a -> Platform -> IdEnv HowBound -> a
    unCtsM CtsM a
    m Platform
    platform IdEnv HowBound
    env)) Platform
    platform IdEnv HowBound
    env

    instance Applicative CtsM where
        pure :: forall a. a -> CtsM a
    pure = a -> CtsM a
    forall a. a -> CtsM a
    returnCts
        <*> :: forall a b. CtsM (a -> b) -> CtsM a -> CtsM 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
    (>>=)  = CtsM a -> (a -> CtsM b) -> CtsM b
    forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
    thenCts

    getPlatform :: CtsM Platform
    getPlatform :: CtsM Platform
    getPlatform = (Platform -> IdEnv HowBound -> Platform) -> CtsM Platform
    forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
    CtsM Platform -> IdEnv HowBound -> Platform
    forall a b. a -> b -> a
    const

    -- 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
       =    (Platform -> IdEnv HowBound -> a) -> CtsM a
    forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
    CtsM ((Platform -> IdEnv HowBound -> a) -> CtsM a)
    -> (Platform -> IdEnv HowBound -> a) -> CtsM a
    forall a b. (a -> b) -> a -> b
    $   \Platform
    platform IdEnv HowBound
    env
       -> CtsM a -> Platform -> IdEnv HowBound -> a
    forall a. CtsM a -> Platform -> IdEnv HowBound -> a
    unCtsM CtsM a
    expr Platform
    platform (IdEnv HowBound -> [(Id, HowBound)] -> IdEnv HowBound
    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 = (Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound
    forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
    CtsM ((Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound)
    -> (Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound
    forall a b. (a -> b) -> a -> b
    $ \Platform
    _ 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 IdEnv HowBound -> Id -> Maybe HowBound
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv IdEnv HowBound
    env Id
    v of
                            Just HowBound
    xx -> HowBound
    xx
                            Maybe HowBound
    Nothing -> Bool -> SDoc -> HowBound -> HowBound
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Id -> Bool
    isGlobalId Id
    v) (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v) HowBound
    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 = (Id -> Bool) -> [Id] -> [Id]
    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
      = [Id] -> CoreArg -> ([Id], CoreArg)
    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
    ba -> [a] -> [a]
    forall 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                  = ([a] -> [a]
    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.
    -- INVARIANT: If the app head is trivial, return the atomic Var/Lit that was
    -- wrapped in casts, empty case, ticks, etc.
    -- So keep in sync with 'exprIsTrivial'.
    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
    aCoreArg -> [CoreArg] -> [CoreArg]
    forall a. a -> [a] -> [a]
    :[CoreArg]
    as) [CoreTickish]
    ts
        go (Tick CoreTickish
    t CoreArg
    e)       [CoreArg]
    as [CoreTickish]
    ts = Bool
    -> SDoc
    -> (CoreArg, [CoreArg], [CoreTickish])
    -> (CoreArg, [CoreArg], [CoreTickish])
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Bool -> Bool
    not (CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishIsCode CoreTickish
    t) Bool -> Bool -> Bool
    || (CoreArg -> Bool) -> [CoreArg] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all CoreArg -> Bool
    forall b. Expr b -> Bool
    isTypeArg [CoreArg]
    as)
                                              (CoreArg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreArg
    e SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ [CoreArg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [CoreArg]
    as SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ [CoreTickish] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [CoreTickish]
    ts) ((CoreArg, [CoreArg], [CoreTickish])
     -> (CoreArg, [CoreArg], [CoreTickish]))
    -> (CoreArg, [CoreArg], [CoreTickish])
    -> (CoreArg, [CoreArg], [CoreTickish])
    forall a b. (a -> b) -> a -> b
    $
                                    -- See Note [Ticks in applications]
                                    CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    e [CoreArg]
    as (CoreTickish
    tCoreTickish -> [CoreTickish] -> [CoreTickish]
    forall 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 (Case CoreArg
    e Id
    b RuntimeRepType
    _ [Alt Id]
    alts) [CoreArg]
    as [CoreTickish]
    ts  -- Just like in exprIsTrivial!
                                    -- Otherwise we fall over in case we encounter
                                    -- `(case f a of {}) b` in the future.
           | [Alt Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Alt Id]
    alts
           = Bool
    -> SDoc
    -> (CoreArg, [CoreArg], [CoreTickish])
    -> (CoreArg, [CoreArg], [CoreTickish])
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr ([CoreArg] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [CoreArg]
    as) (CoreArg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreArg
    e SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ [CoreArg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [CoreArg]
    as SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ CoreArg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CoreArg
    expr) ((CoreArg, [CoreArg], [CoreTickish])
     -> (CoreArg, [CoreArg], [CoreTickish]))
    -> (CoreArg, [CoreArg], [CoreTickish])
    -> (CoreArg, [CoreArg], [CoreTickish])
    forall a b. (a -> b) -> a -> b
    $
                       CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    e [] [CoreTickish]
    ts -- NB: Empty case discards arguments
           | Just CoreArg
    rhs <- CoreArg -> Id -> [Alt Id] -> Maybe CoreArg
    isUnsafeEqualityCase CoreArg
    e Id
    b [Alt Id]
    alts
           = CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    rhs [CoreArg]
    as [CoreTickish]
    ts         -- Discards unsafeCoerce in App heads
        go (Lam Id
    b CoreArg
    e)        [CoreArg]
    as [CoreTickish]
    ts
           | Id -> Bool
    isTyVar Id
    b            = CoreArg
    -> [CoreArg]
    -> [CoreTickish]
    -> (CoreArg, [CoreArg], [CoreTickish])
    go CoreArg
    e (Int -> [CoreArg] -> [CoreArg]
    forall a. Int -> [a] -> [a]
    drop Int
    1 [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 -> Int
    stgArity Id
    _ (LetBound LetInfo
    _ Int
    arity) = Int
    arity
    stgArity Id
    f HowBound
    ImportBound        = Id -> Int
    idArity Id
    f
    stgArity Id
    _ HowBound
    LambdaBound        = Int
    0

    data CoreToStgOpts = CoreToStgOpts
      { CoreToStgOpts -> Platform
    coreToStg_platform :: Platform
      , CoreToStgOpts -> Ways
    coreToStg_ways :: Ways
      , CoreToStgOpts -> Bool
    coreToStg_AutoSccsOnIndividualCafs :: Bool
      , CoreToStgOpts -> Bool
    coreToStg_InfoTableMap :: Bool
      , CoreToStgOpts -> Bool
    coreToStg_ExternalDynamicRefs :: Bool
      , CoreToStgOpts -> StgDebugOpts
    coreToStg_stgDebugOpts :: StgDebugOpts
      }