    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE DataKinds #-}

    -- | Provides the heuristics for when it's beneficial to lambda lift bindings.
    -- Most significantly, this employs a cost model to estimate impact on heap
    -- allocations, by looking at an STG expression's 'Skeleton'.
    module GHC.Stg.Lift.Analysis (
        -- * #when# When to lift
        -- $when

        -- * #clogro# Estimating closure growth
        -- $clogro

        -- * AST annotation
        Skeleton(..), BinderInfo(..), binderInfoBndr,
        LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,
        -- * Lifting decision
        goodToLift,
        closureGrowth -- Exported just for the docs
      ) where

    import GHC.Prelude

    import GHC.Platform
    import GHC.Platform.Profile

    import GHC.Types.Basic
    import GHC.Types.Demand
    import GHC.Types.Id

    import GHC.Runtime.Heap.Layout ( WordOff )

    import GHC.Stg.Lift.Config
    import GHC.Stg.Lift.Types
    import GHC.Stg.Syntax

    import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep
    import qualified GHC.StgToCmm.Closure as StgToCmm.Closure
    import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout
    import GHC.Utils.Outputable
    import GHC.Utils.Misc
    import GHC.Types.Var.Set

    import Data.Maybe ( mapMaybe )

    -- Note [When to lift]
    -- ~~~~~~~~~~~~~~~~~~~
    -- $when
    -- The analysis proceeds in two steps:
    --
    --   1. It tags the syntax tree with analysis information in the form of
    --      'BinderInfo' at each binder and 'Skeleton's at each let-binding
    --      by 'tagSkeletonTopBind' and friends.
    --   2. The resulting syntax tree is treated by the "GHC.Stg.Lift"
    --      module, calling out to 'goodToLift' to decide if a binding is worthwhile
    --      to lift.
    --      'goodToLift' consults argument occurrence information in 'BinderInfo'
    --      and estimates 'closureGrowth', for which it needs the 'Skeleton'.
    --
    -- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift',
    -- which employs a number of heuristics to identify and exclude lambda lifting
    -- opportunities deemed non-beneficial:
    --
    --  [Top-level bindings] can't be lifted.
    --  [Thunks] and data constructors shouldn't be lifted in order not to destroy
    --    sharing.
    --  [Argument occurrences] #arg_occs# of binders prohibit them to be lifted.
    --    Doing the lift would re-introduce the very allocation at call sites that
    --    we tried to get rid off in the first place. We capture analysis
    --    information in 'BinderInfo'. Note that we also consider a nullary
    --    application as argument occurrence, because it would turn into an n-ary
    --    partial application created by a generic apply function. This occurs in
    --    CPS-heavy code like the CS benchmark.
    --  [Join points] should not be lifted, simply because there's no reduction in
    --    allocation to be had.
    --  [Abstracting over join points] destroys join points, because they end up as
    --    arguments to the lifted function.
    --  [Abstracting over known local functions] turns a known call into an unknown
    --    call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off
    --    with @-fstg-lift-lams-known@.
    --  [Calling convention] Don't lift when the resulting function would have a
    --    higher arity than available argument registers for the calling convention.
    --    Can be influenced with @-fstg-lift-(non)rec-args(-any)@.
    --  [Closure growth] introduced when former free variables have to be available
    --    at call sites may actually lead to an increase in overall allocations
    --  resulting from a lift. Estimating closure growth is described in
    --  "GHC.Stg.Lift.Analysis#clogro" and is what most of this module is ultimately
    --  concerned with.
    --
    -- There's a <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page> with
    -- some more background and history.

    -- Note [Estimating closure growth]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- $clogro
    -- We estimate closure growth by abstracting the syntax tree into a 'Skeleton',
    -- capturing only syntactic details relevant to 'closureGrowth', such as
    --
    --   * 'ClosureSk', representing closure allocation.
    --   * 'RhsSk', representing a RHS of a binding and how many times it's called
    --     by an appropriate 'Card'.
    --   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element.
    --
    -- This abstraction is mostly so that the main analysis function 'closureGrowth'
    -- can stay simple and focused. Also, skeletons tend to be much smaller than
    -- the syntax tree they abstract, so it makes sense to construct them once and
    -- and operate on them instead of the actual syntax tree.
    --
    -- A more detailed treatment of computing closure growth, including examples,
    -- can be found in the paper referenced from the
    -- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.

    llTrace :: String -> SDoc -> a -> a
    llTrace :: forall a. String -> SDoc -> a -> a
    llTrace String
    _ SDoc
    _ a
    c = a
    c
    -- llTrace a b c = pprTrace a b c

    mkArgOccs :: [StgArg] -> IdSet
    mkArgOccs :: [StgArg] -> IdSet
    mkArgOccs = [Id] -> IdSet
    mkVarSet ([Id] -> IdSet) -> ([StgArg] -> [Id]) -> [StgArg] -> IdSet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (StgArg -> Maybe Id) -> [StgArg] -> [Id]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe StgArg -> Maybe Id
    stg_arg_var
      where
        stg_arg_var :: StgArg -> Maybe Id
    stg_arg_var (StgVarArg Id
    occ) = Id -> Maybe Id
    forall a. a -> Maybe a
    Just Id
    occ
        stg_arg_var StgArg
    _               = Maybe Id
    forall a. Maybe a
    Nothing

    -- | Tags every binder with its 'BinderInfo' and let bindings with their
    -- 'Skeleton's.
    tagSkeletonTopBind :: CgStgBinding -> LlStgBinding
    -- NilSk is OK when tagging top-level bindings. Also, top-level things are never
    -- lambda-lifted, so no need to track their argument occurrences. They can also
    -- never be let-no-escapes (thus we pass False).
    tagSkeletonTopBind :: CgStgBinding -> LlStgBinding
    tagSkeletonTopBind CgStgBinding
    bind = LlStgBinding
    bind'
      where
        (Skeleton
    _, IdSet
    _, Skeleton
    _, LlStgBinding
    bind') = Bool
    -> Skeleton
    -> IdSet
    -> CgStgBinding
    -> (Skeleton, IdSet, Skeleton, LlStgBinding)
    tagSkeletonBinding Bool
    False Skeleton
    NilSk IdSet
    emptyVarSet CgStgBinding
    bind

    -- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with
    -- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder
    -- occurrences in argument and nullary application position
    -- (cf. "GHC.Stg.Lift.Analysis#arg_occs").
    tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonExpr (StgLit Literal
    lit)
      = (Skeleton
    NilSk, IdSet
    emptyVarSet, Literal -> LlStgExpr
    forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    lit)
    tagSkeletonExpr (StgConApp DataCon
    con ConstructorNumber
    mn [StgArg]
    args [[PrimRep]]
    tys)
      = (Skeleton
    NilSk, [StgArg] -> IdSet
    mkArgOccs [StgArg]
    args, DataCon
    -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> LlStgExpr
    forall (pass :: StgPass).
    DataCon
    -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
    StgConApp DataCon
    con ConstructorNumber
    mn [StgArg]
    args [[PrimRep]]
    tys)
    tagSkeletonExpr (StgOpApp StgOp
    op [StgArg]
    args Type
    ty)
      = (Skeleton
    NilSk, [StgArg] -> IdSet
    mkArgOccs [StgArg]
    args, StgOp -> [StgArg] -> Type -> LlStgExpr
    forall (pass :: StgPass).
    StgOp -> [StgArg] -> Type -> GenStgExpr pass
    StgOpApp StgOp
    op [StgArg]
    args Type
    ty)
    tagSkeletonExpr (StgApp Id
    f [StgArg]
    args)
      = (Skeleton
    NilSk, IdSet
    arg_occs, Id -> [StgArg] -> LlStgExpr
    forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
    StgApp Id
    f [StgArg]
    args)
      where
        arg_occs :: IdSet
    arg_occs
          -- This checks for nullary applications, which we treat the same as
          -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs".
          | [StgArg] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [StgArg]
    args = Id -> IdSet
    unitVarSet Id
    f
          | Bool
    otherwise = [StgArg] -> IdSet
    mkArgOccs [StgArg]
    args
    tagSkeletonExpr (StgCase CgStgExpr
    scrut BinderP 'CodeGen
    bndr AltType
    ty [GenStgAlt 'CodeGen]
    alts)
      = (Skeleton
    skel, IdSet
    arg_occs, LlStgExpr
    -> BinderP 'LiftLams
    -> AltType
    -> [GenStgAlt 'LiftLams]
    -> LlStgExpr
    forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase LlStgExpr
    scrut' BinderInfo
    BinderP 'LiftLams
    bndr' AltType
    ty [GenStgAlt 'LiftLams]
    alts')
      where
        (Skeleton
    scrut_skel, IdSet
    scrut_arg_occs, LlStgExpr
    scrut') = CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonExpr CgStgExpr
    scrut
        ([Skeleton]
    alt_skels, [IdSet]
    alt_arg_occss, [GenStgAlt 'LiftLams]
    alts') = (GenStgAlt 'CodeGen -> (Skeleton, IdSet, GenStgAlt 'LiftLams))
    -> [GenStgAlt 'CodeGen]
    -> ([Skeleton], [IdSet], [GenStgAlt 'LiftLams])
    forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
    mapAndUnzip3 GenStgAlt 'CodeGen -> (Skeleton, IdSet, GenStgAlt 'LiftLams)
    tagSkeletonAlt [GenStgAlt 'CodeGen]
    alts
        skel :: Skeleton
    skel = Skeleton -> Skeleton -> Skeleton
    bothSk Skeleton
    scrut_skel ((Skeleton -> Skeleton -> Skeleton)
    -> Skeleton -> [Skeleton] -> Skeleton
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Skeleton -> Skeleton -> Skeleton
    altSk Skeleton
    NilSk [Skeleton]
    alt_skels)
        arg_occs :: IdSet
    arg_occs = [IdSet] -> IdSet
    unionVarSets (IdSet
    scrut_arg_occsIdSet -> [IdSet] -> [IdSet]
    forall a. a -> [a] -> [a]
    :[IdSet]
    alt_arg_occss) IdSet -> Id -> IdSet
    `delVarSet` Id
    BinderP 'CodeGen
    bndr
        bndr' :: BinderInfo
    bndr' = Id -> BinderInfo
    BoringBinder Id
    BinderP 'CodeGen
    bndr
    tagSkeletonExpr (StgTick StgTickish
    t CgStgExpr
    e)
      = (Skeleton
    skel, IdSet
    arg_occs, StgTickish -> LlStgExpr -> LlStgExpr
    forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    t LlStgExpr
    e')
      where
        (Skeleton
    skel, IdSet
    arg_occs, LlStgExpr
    e') = CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonExpr CgStgExpr
    e
    tagSkeletonExpr (StgLet XLet 'CodeGen
    _ CgStgBinding
    bind CgStgExpr
    body) = Bool -> CgStgExpr -> CgStgBinding -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonLet Bool
    False CgStgExpr
    body CgStgBinding
    bind
    tagSkeletonExpr (StgLetNoEscape XLetNoEscape 'CodeGen
    _ CgStgBinding
    bind CgStgExpr
    body) = Bool -> CgStgExpr -> CgStgBinding -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonLet Bool
    True CgStgExpr
    body CgStgBinding
    bind

    mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
    mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
    mkLet Bool
    True = Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
    XLetNoEscape 'LiftLams -> LlStgBinding -> LlStgExpr -> LlStgExpr
    forall (pass :: StgPass).
    XLetNoEscape pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLetNoEscape
    mkLet Bool
    _    = Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
    XLet 'LiftLams -> LlStgBinding -> LlStgExpr -> LlStgExpr
    forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet

    tagSkeletonLet
      :: Bool
      -- ^ Is the binding a let-no-escape?
      -> CgStgExpr
      -- ^ Let body
      -> CgStgBinding
      -- ^ Binding group
      -> (Skeleton, IdSet, LlStgExpr)
      -- ^ RHS skeletons, argument occurrences and annotated binding
    tagSkeletonLet :: Bool -> CgStgExpr -> CgStgBinding -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonLet Bool
    is_lne CgStgExpr
    body CgStgBinding
    bind
      = (Skeleton
    let_skel, IdSet
    arg_occs, Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
    mkLet Bool
    is_lne Skeleton
    scope LlStgBinding
    bind' LlStgExpr
    body')
      where
        (Skeleton
    body_skel, IdSet
    body_arg_occs, LlStgExpr
    body') = CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonExpr CgStgExpr
    body
        (Skeleton
    let_skel, IdSet
    arg_occs, Skeleton
    scope, LlStgBinding
    bind')
          = Bool
    -> Skeleton
    -> IdSet
    -> CgStgBinding
    -> (Skeleton, IdSet, Skeleton, LlStgBinding)
    tagSkeletonBinding Bool
    is_lne Skeleton
    body_skel IdSet
    body_arg_occs CgStgBinding
    bind

    tagSkeletonBinding
      :: Bool
      -- ^ Is the binding a let-no-escape?
      -> Skeleton
      -- ^ Let body skeleton
      -> IdSet
      -- ^ Argument occurrences in the body
      -> CgStgBinding
      -- ^ Binding group
      -> (Skeleton, IdSet, Skeleton, LlStgBinding)
      -- ^ Let skeleton, argument occurrences, scope skeleton of binding and
      --   the annotated binding
    tagSkeletonBinding :: Bool
    -> Skeleton
    -> IdSet
    -> CgStgBinding
    -> (Skeleton, IdSet, Skeleton, LlStgBinding)
    tagSkeletonBinding Bool
    is_lne Skeleton
    body_skel IdSet
    body_arg_occs (StgNonRec BinderP 'CodeGen
    bndr GenStgRhs 'CodeGen
    rhs)
      = (Skeleton
    let_skel, IdSet
    arg_occs, Skeleton
    scope, LlStgBinding
    bind')
      where
        (Skeleton
    rhs_skel, IdSet
    rhs_arg_occs, LlStgRhs
    rhs') = Id -> GenStgRhs 'CodeGen -> (Skeleton, IdSet, LlStgRhs)
    tagSkeletonRhs Id
    BinderP 'CodeGen
    bndr GenStgRhs 'CodeGen
    rhs
        arg_occs :: IdSet
    arg_occs = (IdSet
    body_arg_occs IdSet -> IdSet -> IdSet
    `unionVarSet` IdSet
    rhs_arg_occs) IdSet -> Id -> IdSet
    `delVarSet` Id
    BinderP 'CodeGen
    bndr
        bind_skel :: Skeleton
    bind_skel
          | Bool
    is_lne    = Skeleton
    rhs_skel -- no closure is allocated for let-no-escapes
          | Bool
    otherwise = Id -> DIdSet -> Skeleton -> Skeleton
    ClosureSk Id
    BinderP 'CodeGen
    bndr (GenStgRhs 'CodeGen -> DIdSet
    forall (pass :: StgPass).
    (XRhsClosure pass ~ DIdSet) =>
    GenStgRhs pass -> DIdSet
    freeVarsOfRhs GenStgRhs 'CodeGen
    rhs) Skeleton
    rhs_skel
        let_skel :: Skeleton
    let_skel = Skeleton -> Skeleton -> Skeleton
    bothSk Skeleton
    body_skel Skeleton
    bind_skel
        occurs_as_arg :: Bool
    occurs_as_arg = Id
    BinderP 'CodeGen
    bndr Id -> IdSet -> Bool
    `elemVarSet` IdSet
    body_arg_occs
        -- Compared to the recursive case, this exploits the fact that @bndr@ is
        -- never free in @rhs@.
        scope :: Skeleton
    scope = Skeleton
    body_skel
        bind' :: LlStgBinding
    bind' = BinderP 'LiftLams -> LlStgRhs -> LlStgBinding
    forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec (Id -> Bool -> BinderInfo
    BindsClosure Id
    BinderP 'CodeGen
    bndr Bool
    occurs_as_arg) LlStgRhs
    rhs'
    tagSkeletonBinding Bool
    is_lne Skeleton
    body_skel IdSet
    body_arg_occs (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
    pairs)
      = (Skeleton
    let_skel, IdSet
    arg_occs, Skeleton
    scope, [(BinderP 'LiftLams, LlStgRhs)] -> LlStgBinding
    forall (pass :: StgPass).
    [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    StgRec [(BinderInfo, LlStgRhs)]
    [(BinderP 'LiftLams, LlStgRhs)]
    pairs')
      where
        ([Id]
    bndrs, [GenStgRhs 'CodeGen]
    _) = [(Id, GenStgRhs 'CodeGen)] -> ([Id], [GenStgRhs 'CodeGen])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Id, GenStgRhs 'CodeGen)]
    [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
    pairs
        -- Local recursive STG bindings also regard the defined binders as free
        -- vars. We want to delete those for our cost model, as these are known
        -- calls anyway when we add them to the same top-level recursive group as
        -- the top-level binding currently being analysed.
        skel_occs_rhss' :: [(Skeleton, IdSet, LlStgRhs)]
    skel_occs_rhss' = ((Id, GenStgRhs 'CodeGen) -> (Skeleton, IdSet, LlStgRhs))
    -> [(Id, GenStgRhs 'CodeGen)] -> [(Skeleton, IdSet, LlStgRhs)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Id -> GenStgRhs 'CodeGen -> (Skeleton, IdSet, LlStgRhs))
    -> (Id, GenStgRhs 'CodeGen) -> (Skeleton, IdSet, LlStgRhs)
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry Id -> GenStgRhs 'CodeGen -> (Skeleton, IdSet, LlStgRhs)
    tagSkeletonRhs) [(Id, GenStgRhs 'CodeGen)]
    [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
    pairs
        rhss_arg_occs :: [IdSet]
    rhss_arg_occs = ((Skeleton, IdSet, LlStgRhs) -> IdSet)
    -> [(Skeleton, IdSet, LlStgRhs)] -> [IdSet]
    forall a b. (a -> b) -> [a] -> [b]
    map (Skeleton, IdSet, LlStgRhs) -> IdSet
    forall a b c. (a, b, c) -> b
    sndOf3 [(Skeleton, IdSet, LlStgRhs)]
    skel_occs_rhss'
        scope_occs :: IdSet
    scope_occs = [IdSet] -> IdSet
    unionVarSets (IdSet
    body_arg_occsIdSet -> [IdSet] -> [IdSet]
    forall a. a -> [a] -> [a]
    :[IdSet]
    rhss_arg_occs)
        arg_occs :: IdSet
    arg_occs = IdSet
    scope_occs IdSet -> [Id] -> IdSet
    `delVarSetList` [Id]
    bndrs
        -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment,
        -- but we also need the un-wrapped skeletons for calculating the @scope@
        -- of the group, as the outer closures don't contribute to closure growth
        -- when we lift this specific binding.
        scope :: Skeleton
    scope = ((Skeleton, IdSet, LlStgRhs) -> Skeleton -> Skeleton)
    -> Skeleton -> [(Skeleton, IdSet, LlStgRhs)] -> Skeleton
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (Skeleton -> Skeleton -> Skeleton
    bothSk (Skeleton -> Skeleton -> Skeleton)
    -> ((Skeleton, IdSet, LlStgRhs) -> Skeleton)
    -> (Skeleton, IdSet, LlStgRhs)
    -> Skeleton
    -> Skeleton
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Skeleton, IdSet, LlStgRhs) -> Skeleton
    forall a b c. (a, b, c) -> a
    fstOf3) Skeleton
    body_skel [(Skeleton, IdSet, LlStgRhs)]
    skel_occs_rhss'
        -- Now we can build the actual Skeleton for the expression just by
        -- iterating over each bind pair.
        ([Skeleton]
    bind_skels, [(BinderInfo, LlStgRhs)]
    pairs') = [(Skeleton, (BinderInfo, LlStgRhs))]
    -> ([Skeleton], [(BinderInfo, LlStgRhs)])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ((Id
     -> (Skeleton, IdSet, LlStgRhs)
     -> (Skeleton, (BinderInfo, LlStgRhs)))
    -> [Id]
    -> [(Skeleton, IdSet, LlStgRhs)]
    -> [(Skeleton, (BinderInfo, LlStgRhs))]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Id
    -> (Skeleton, IdSet, LlStgRhs)
    -> (Skeleton, (BinderInfo, LlStgRhs))
    single_bind [Id]
    bndrs [(Skeleton, IdSet, LlStgRhs)]
    skel_occs_rhss')
        let_skel :: Skeleton
    let_skel = (Skeleton -> Skeleton -> Skeleton)
    -> Skeleton -> [Skeleton] -> Skeleton
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Skeleton -> Skeleton -> Skeleton
    bothSk Skeleton
    body_skel [Skeleton]
    bind_skels
        single_bind :: Id
    -> (Skeleton, IdSet, LlStgRhs)
    -> (Skeleton, (BinderInfo, LlStgRhs))
    single_bind Id
    bndr (Skeleton
    skel_rhs, IdSet
    _, LlStgRhs
    rhs') = (Skeleton
    bind_skel, (BinderInfo
    bndr', LlStgRhs
    rhs'))
          where
            -- Here, we finally add the closure around each @skel_rhs@.
            bind_skel :: Skeleton
    bind_skel
              | Bool
    is_lne    = Skeleton
    skel_rhs -- no closure is allocated for let-no-escapes
              | Bool
    otherwise = Id -> DIdSet -> Skeleton -> Skeleton
    ClosureSk Id
    bndr DIdSet
    fvs Skeleton
    skel_rhs
            fvs :: DIdSet
    fvs = LlStgRhs -> DIdSet
    forall (pass :: StgPass).
    (XRhsClosure pass ~ DIdSet) =>
    GenStgRhs pass -> DIdSet
    freeVarsOfRhs LlStgRhs
    rhs' DIdSet -> IdSet -> DIdSet
    `dVarSetMinusVarSet` [Id] -> IdSet
    mkVarSet [Id]
    bndrs
            bndr' :: BinderInfo
    bndr' = Id -> Bool -> BinderInfo
    BindsClosure Id
    bndr (Id
    bndr Id -> IdSet -> Bool
    `elemVarSet` IdSet
    scope_occs)

    tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
    tagSkeletonRhs :: Id -> GenStgRhs 'CodeGen -> (Skeleton, IdSet, LlStgRhs)
    tagSkeletonRhs Id
    _ (StgRhsCon CostCentreStack
    ccs DataCon
    dc ConstructorNumber
    mn [StgTickish]
    ts [StgArg]
    args Type
    typ)
      = (Skeleton
    NilSk, [StgArg] -> IdSet
    mkArgOccs [StgArg]
    args, CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> Type
    -> LlStgRhs
    forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> Type
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    ccs DataCon
    dc ConstructorNumber
    mn [StgTickish]
    ts [StgArg]
    args Type
    typ)
    tagSkeletonRhs Id
    bndr (StgRhsClosure XRhsClosure 'CodeGen
    fvs CostCentreStack
    ccs UpdateFlag
    upd [BinderP 'CodeGen]
    bndrs CgStgExpr
    body Type
    typ)
      = (Skeleton
    rhs_skel, IdSet
    body_arg_occs, XRhsClosure 'LiftLams
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'LiftLams]
    -> LlStgExpr
    -> Type
    -> LlStgRhs
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> Type
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'LiftLams
    XRhsClosure 'CodeGen
    fvs CostCentreStack
    ccs UpdateFlag
    upd [BinderInfo]
    [BinderP 'LiftLams]
    bndrs' LlStgExpr
    body' Type
    typ)
      where
        bndrs' :: [BinderInfo]
    bndrs' = (Id -> BinderInfo) -> [Id] -> [BinderInfo]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> BinderInfo
    BoringBinder [Id]
    [BinderP 'CodeGen]
    bndrs
        (Skeleton
    body_skel, IdSet
    body_arg_occs, LlStgExpr
    body') = CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonExpr CgStgExpr
    body
        rhs_skel :: Skeleton
    rhs_skel = Card -> Skeleton -> Skeleton
    rhsSk (Id -> Card
    rhsCard Id
    bndr) Skeleton
    body_skel

    -- | How many times will the lambda body of the RHS bound to the given
    -- identifier be evaluated, relative to its defining context? This function
    -- computes the answer in form of a 'Card'.
    rhsCard :: Id -> Card
    rhsCard :: Id -> Card
    rhsCard Id
    bndr
      | Bool
    is_thunk  = Card -> Card
    oneifyCard Card
    n
      | Bool
    otherwise = Card
    n Card -> Card -> Card
    `multCard` ((Card, SubDemand) -> Card
    forall a b. (a, b) -> a
    fst ((Card, SubDemand) -> Card) -> (Card, SubDemand) -> Card
    forall a b. (a -> b) -> a -> b
    $ Int -> SubDemand -> (Card, SubDemand)
    peelManyCalls (Id -> Int
    idArity Id
    bndr) SubDemand
    cd)
      where
        is_thunk :: Bool
    is_thunk = Id -> Int
    idArity Id
    bndr Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0
        -- Let's pray idDemandInfo is still OK after unarise...
        Card
    n :* SubDemand
    cd = Id -> Demand
    idDemandInfo Id
    bndr

    tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)
    tagSkeletonAlt :: GenStgAlt 'CodeGen -> (Skeleton, IdSet, GenStgAlt 'LiftLams)
    tagSkeletonAlt old :: GenStgAlt 'CodeGen
    old@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
    alt_con=AltCon
    _, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
    alt_bndrs=[BinderP 'CodeGen]
    bndrs, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
    alt_rhs=CgStgExpr
    rhs}
      = (Skeleton
    alt_skel, IdSet
    arg_occs, GenStgAlt 'CodeGen
    old {alt_bndrs=fmap BoringBinder bndrs, alt_rhs=rhs'})
      where
        (Skeleton
    alt_skel, IdSet
    alt_arg_occs, LlStgExpr
    rhs') = CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
    tagSkeletonExpr CgStgExpr
    rhs
        arg_occs :: IdSet
    arg_occs = IdSet
    alt_arg_occs IdSet -> [Id] -> IdSet
    `delVarSetList` [Id]
    [BinderP 'CodeGen]
    bndrs

    -- | Combines several heuristics to decide whether to lambda-lift a given
    -- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details.
    goodToLift
      :: StgLiftConfig
      -> TopLevelFlag
      -> RecFlag
      -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into
                            -- 'OutId's. See 'GHC.Stg.Lift.Monad.liftedIdsExpander'.
      -> [(BinderInfo, LlStgRhs)]
      -> Skeleton
      -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to
                            -- lift and @abs_ids@ are the variables it would
                            -- abstract over
    goodToLift :: StgLiftConfig
    -> TopLevelFlag
    -> RecFlag
    -> (DIdSet -> DIdSet)
    -> [(BinderInfo, LlStgRhs)]
    -> Skeleton
    -> Maybe DIdSet
    goodToLift StgLiftConfig
    cfg TopLevelFlag
    top_lvl RecFlag
    rec_flag DIdSet -> DIdSet
    expander [(BinderInfo, LlStgRhs)]
    pairs Skeleton
    scope = [(String, Bool)] -> Maybe DIdSet
    decide
      [ (String
    "top-level", TopLevelFlag -> Bool
    isTopLevel TopLevelFlag
    top_lvl) -- keep in sync with Note [When to lift]
      , (String
    "memoized", Bool
    any_memoized)
      , (String
    "argument occurrences", Bool
    arg_occs)
      , (String
    "join point", Bool
    is_join_point)
      , (String
    "abstracts join points", Bool
    abstracts_join_ids)
      , (String
    "abstracts known local function", Bool
    abstracts_known_local_fun)
      , (String
    "args spill on stack", Bool
    args_spill_on_stack)
      , (String
    "increases allocation", Bool
    inc_allocs)
      ] where
          profile :: Profile
    profile  = StgLiftConfig -> Profile
    c_targetProfile StgLiftConfig
    cfg
          platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
          decide :: [(String, Bool)] -> Maybe DIdSet
    decide [(String, Bool)]
    deciders
            | Bool -> Bool
    not ([(String, Bool)] -> Bool
    fancy_or [(String, Bool)]
    deciders)
            = String -> SDoc -> Maybe DIdSet -> Maybe DIdSet
    forall a. String -> SDoc -> a -> a
    llTrace String
    "stgLiftLams:lifting"
                      ([Id] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Id]
    bndrs SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> DIdSet -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DIdSet
    abs_ids SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                       IntWithInf -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr IntWithInf
    allocs SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                       Skeleton -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Skeleton
    scope) (Maybe DIdSet -> Maybe DIdSet) -> Maybe DIdSet -> Maybe DIdSet
    forall a b. (a -> b) -> a -> b
    $
              DIdSet -> Maybe DIdSet
    forall a. a -> Maybe a
    Just DIdSet
    abs_ids
            | Bool
    otherwise
            = Maybe DIdSet
    forall a. Maybe a
    Nothing
          ppr_deciders :: [(String, Bool)] -> SDoc
    ppr_deciders = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ([SDoc] -> SDoc)
    -> ([(String, Bool)] -> [SDoc]) -> [(String, Bool)] -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((String, Bool) -> SDoc) -> [(String, Bool)] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (String -> SDoc)
    -> ((String, Bool) -> String) -> (String, Bool) -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String, Bool) -> String
    forall a b. (a, b) -> a
    fst) ([(String, Bool)] -> [SDoc])
    -> ([(String, Bool)] -> [(String, Bool)])
    -> [(String, Bool)]
    -> [SDoc]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((String, Bool) -> Bool) -> [(String, Bool)] -> [(String, Bool)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (String, Bool) -> Bool
    forall a b. (a, b) -> b
    snd
          fancy_or :: [(String, Bool)] -> Bool
    fancy_or [(String, Bool)]
    deciders
            = String -> SDoc -> Bool -> Bool
    forall a. String -> SDoc -> a -> a
    llTrace String
    "stgLiftLams:goodToLift" ([Id] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Id]
    bndrs SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ [(String, Bool)] -> SDoc
    ppr_deciders [(String, Bool)]
    deciders) (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $
              ((String, Bool) -> Bool) -> [(String, Bool)] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (String, Bool) -> Bool
    forall a b. (a, b) -> b
    snd [(String, Bool)]
    deciders

          bndrs :: [Id]
    bndrs = ((BinderInfo, LlStgRhs) -> Id) -> [(BinderInfo, LlStgRhs)] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map (BinderInfo -> Id
    binderInfoBndr (BinderInfo -> Id)
    -> ((BinderInfo, LlStgRhs) -> BinderInfo)
    -> (BinderInfo, LlStgRhs)
    -> Id
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (BinderInfo, LlStgRhs) -> BinderInfo
    forall a b. (a, b) -> a
    fst) [(BinderInfo, LlStgRhs)]
    pairs
          bndrs_set :: IdSet
    bndrs_set = [Id] -> IdSet
    mkVarSet [Id]
    bndrs
          rhss :: [LlStgRhs]
    rhss = ((BinderInfo, LlStgRhs) -> LlStgRhs)
    -> [(BinderInfo, LlStgRhs)] -> [LlStgRhs]
    forall a b. (a -> b) -> [a] -> [b]
    map (BinderInfo, LlStgRhs) -> LlStgRhs
    forall a b. (a, b) -> b
    snd [(BinderInfo, LlStgRhs)]
    pairs

          -- First objective: Calculate @abs_ids@, e.g. the former free variables
          -- the lifted binding would abstract over. We have to merge the free
          -- variables of all RHS to get the set of variables that will have to be
          -- passed through parameters.
          fvs :: DIdSet
    fvs = [DIdSet] -> DIdSet
    unionDVarSets ((LlStgRhs -> DIdSet) -> [LlStgRhs] -> [DIdSet]
    forall a b. (a -> b) -> [a] -> [b]
    map LlStgRhs -> DIdSet
    forall (pass :: StgPass).
    (XRhsClosure pass ~ DIdSet) =>
    GenStgRhs pass -> DIdSet
    freeVarsOfRhs [LlStgRhs]
    rhss)
          -- To lift the binding to top-level, we want to delete the lifted binders
          -- themselves from the free var set. Local let bindings track recursive
          -- occurrences in their free variable set. We neither want to apply our
          -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters
          -- when lifted, as these are known calls. We call the resulting set the
          -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's.
          -- We will save the set in 'LiftM.e_expansions' for each of the variables
          -- if we perform the lift.
          abs_ids :: DIdSet
    abs_ids = DIdSet -> DIdSet
    expander (DIdSet -> [Id] -> DIdSet
    delDVarSetList DIdSet
    fvs [Id]
    bndrs)

          -- We don't lift updatable thunks or constructors
          any_memoized :: Bool
    any_memoized = (LlStgRhs -> Bool) -> [LlStgRhs] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any LlStgRhs -> Bool
    forall {pass :: StgPass}. GenStgRhs pass -> Bool
    is_memoized_rhs [LlStgRhs]
    rhss
          is_memoized_rhs :: GenStgRhs pass -> Bool
    is_memoized_rhs StgRhsCon{} = Bool
    True
          is_memoized_rhs (StgRhsClosure XRhsClosure pass
    _ CostCentreStack
    _ UpdateFlag
    upd [BinderP pass]
    _ GenStgExpr pass
    _ Type
    _) = UpdateFlag -> Bool
    isUpdatable UpdateFlag
    upd

          -- Don't lift binders occurring as arguments. This would result in complex
          -- argument expressions which would have to be given a name, reintroducing
          -- the very allocation at each call site that we wanted to get rid off in
          -- the first place.
          arg_occs :: Bool
    arg_occs = [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or (((BinderInfo, LlStgRhs) -> Maybe Bool)
    -> [(BinderInfo, LlStgRhs)] -> [Bool]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (BinderInfo -> Maybe Bool
    binderInfoOccursAsArg (BinderInfo -> Maybe Bool)
    -> ((BinderInfo, LlStgRhs) -> BinderInfo)
    -> (BinderInfo, LlStgRhs)
    -> Maybe Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (BinderInfo, LlStgRhs) -> BinderInfo
    forall a b. (a, b) -> a
    fst) [(BinderInfo, LlStgRhs)]
    pairs)

          -- These don't allocate anyway.
          is_join_point :: Bool
    is_join_point = (Id -> Bool) -> [Id] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any Id -> Bool
    isJoinId [Id]
    bndrs

          -- Abstracting over join points/let-no-escapes spoils them.
          abstracts_join_ids :: Bool
    abstracts_join_ids = (Id -> Bool) -> [Id] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any Id -> Bool
    isJoinId (DIdSet -> [Id]
    dVarSetElems DIdSet
    abs_ids)

          -- Abstracting over known local functions that aren't floated themselves
          -- turns a known, fast call into an unknown, slow call:
          --
          --    let f x = ...
          --        g y = ... f x ... -- this was a known call
          --    in g 4
          --
          -- After lifting @g@, but not @f@:
          --
          --    l_g f y = ... f y ... -- this is now an unknown call
          --    let f x = ...
          --    in l_g f 4
          --
          -- We can abuse the results of arity analysis for this:
          -- idArity f > 0 ==> known
          known_fun :: Id -> Bool
    known_fun Id
    id = Id -> Int
    idArity Id
    id Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0
          abstracts_known_local_fun :: Bool
    abstracts_known_local_fun
            = Bool -> Bool
    not (StgLiftConfig -> Bool
    c_liftLamsKnown StgLiftConfig
    cfg) Bool -> Bool -> Bool
    && (Id -> Bool) -> [Id] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any Id -> Bool
    known_fun (DIdSet -> [Id]
    dVarSetElems DIdSet
    abs_ids)

          -- Number of arguments of a RHS in the current binding group if we decide
          -- to lift it
          n_args :: LlStgRhs -> Int
    n_args
            = [NonVoid Id] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length
            ([NonVoid Id] -> Int)
    -> (LlStgRhs -> [NonVoid Id]) -> LlStgRhs -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Id] -> [NonVoid Id]
    StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm
            ([Id] -> [NonVoid Id])
    -> (LlStgRhs -> [Id]) -> LlStgRhs -> [NonVoid Id]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (DIdSet -> [Id]
    dVarSetElems DIdSet
    abs_ids [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++)
            ([Id] -> [Id]) -> (LlStgRhs -> [Id]) -> LlStgRhs -> [Id]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LlStgRhs -> [Id]
    rhsLambdaBndrs
          max_n_args :: Maybe Int
    max_n_args
            | RecFlag -> Bool
    isRec RecFlag
    rec_flag = StgLiftConfig -> Maybe Int
    c_liftLamsRecArgs StgLiftConfig
    cfg
            | Bool
    otherwise      = StgLiftConfig -> Maybe Int
    c_liftLamsNonRecArgs StgLiftConfig
    cfg
          -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess
          -- args are passed on the stack, which means slow memory accesses
          args_spill_on_stack :: Bool
    args_spill_on_stack
            | Just Int
    n <- Maybe Int
    max_n_args = [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum ((LlStgRhs -> Int) -> [LlStgRhs] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map LlStgRhs -> Int
    n_args [LlStgRhs]
    rhss) Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    n
            | Bool
    otherwise = Bool
    False

          -- We only perform the lift if allocations didn't increase.
          -- Note that @clo_growth@ will be 'infinity' if there was positive growth
          -- under a multi-shot lambda.
          -- Also, abstracting over LNEs is unacceptable. LNEs might return
          -- unlifted tuples, which idClosureFootprint can't cope with.
          inc_allocs :: Bool
    inc_allocs = Bool
    abstracts_join_ids Bool -> Bool -> Bool
    || IntWithInf
    allocs IntWithInf -> IntWithInf -> Bool
    forall a. Ord a => a -> a -> Bool
    > IntWithInf
    0
          allocs :: IntWithInf
    allocs = IntWithInf
    clo_growth IntWithInf -> IntWithInf -> IntWithInf
    forall a. Num a => a -> a -> a
    + Int -> IntWithInf
    mkIntWithInf (Int -> Int
    forall a. Num a => a -> a
    negate Int
    closuresSize)
          -- We calculate and then add up the size of each binding's closure.
          -- GHC does not currently share closure environments, and we either lift
          -- the entire recursive binding group or none of it.
          closuresSize :: Int
    closuresSize = [Int] -> Int
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ([Int] -> Int) -> [Int] -> Int
    forall a b. (a -> b) -> a -> b
    $ ((LlStgRhs -> Int) -> [LlStgRhs] -> [Int])
    -> [LlStgRhs] -> (LlStgRhs -> Int) -> [Int]
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (LlStgRhs -> Int) -> [LlStgRhs] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map [LlStgRhs]
    rhss ((LlStgRhs -> Int) -> [Int]) -> (LlStgRhs -> Int) -> [Int]
    forall a b. (a -> b) -> a -> b
    $ \LlStgRhs
    rhs ->
            Profile -> [Id] -> Int
    closureSize Profile
    profile
            ([Id] -> Int) -> (DIdSet -> [Id]) -> DIdSet -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DIdSet -> [Id]
    dVarSetElems
            (DIdSet -> [Id]) -> (DIdSet -> DIdSet) -> DIdSet -> [Id]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DIdSet -> DIdSet
    expander
            (DIdSet -> DIdSet) -> (DIdSet -> DIdSet) -> DIdSet -> DIdSet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (DIdSet -> IdSet -> DIdSet) -> IdSet -> DIdSet -> DIdSet
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip DIdSet -> IdSet -> DIdSet
    dVarSetMinusVarSet IdSet
    bndrs_set
            (DIdSet -> Int) -> DIdSet -> Int
    forall a b. (a -> b) -> a -> b
    $ LlStgRhs -> DIdSet
    forall (pass :: StgPass).
    (XRhsClosure pass ~ DIdSet) =>
    GenStgRhs pass -> DIdSet
    freeVarsOfRhs LlStgRhs
    rhs
          clo_growth :: IntWithInf
    clo_growth = (DIdSet -> DIdSet)
    -> (Id -> Int) -> IdSet -> DIdSet -> Skeleton -> IntWithInf
    closureGrowth DIdSet -> DIdSet
    expander (Platform -> Id -> Int
    idClosureFootprint Platform
    platform) IdSet
    bndrs_set DIdSet
    abs_ids Skeleton
    scope

    rhsLambdaBndrs :: LlStgRhs -> [Id]
    rhsLambdaBndrs :: LlStgRhs -> [Id]
    rhsLambdaBndrs StgRhsCon{} = []
    rhsLambdaBndrs (StgRhsClosure XRhsClosure 'LiftLams
    _ CostCentreStack
    _ UpdateFlag
    _ [BinderP 'LiftLams]
    bndrs LlStgExpr
    _ Type
    _) = (BinderInfo -> Id) -> [BinderInfo] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map BinderInfo -> Id
    binderInfoBndr [BinderInfo]
    [BinderP 'LiftLams]
    bndrs

    -- | The size in words of a function closure closing over the given 'Id's,
    -- including the header.
    closureSize :: Profile -> [Id] -> WordOff
    closureSize :: Profile -> [Id] -> Int
    closureSize Profile
    profile [Id]
    ids = Int
    words Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + PlatformConstants -> Int
    pc_STD_HDR_SIZE (Platform -> PlatformConstants
    platformConstants (Profile -> Platform
    profilePlatform Profile
    profile))
      -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't
      -- optimise differently when profiling is enabled.
      where
        (Int
    words, Int
    _, [(NonVoid Id, Int)]
    _)
          -- Functions have a StdHeader (as opposed to ThunkHeader).
          = Profile
    -> ClosureHeader
    -> [NonVoid (PrimRep, Id)]
    -> (Int, Int, [(NonVoid Id, Int)])
    forall a.
    Profile
    -> ClosureHeader
    -> [NonVoid (PrimRep, a)]
    -> (Int, Int, [(NonVoid a, Int)])
    StgToCmm.Layout.mkVirtHeapOffsets Profile
    profile ClosureHeader
    StgToCmm.Layout.StdHeader
          ([NonVoid (PrimRep, Id)] -> (Int, Int, [(NonVoid Id, Int)]))
    -> ([Id] -> [NonVoid (PrimRep, Id)])
    -> [Id]
    -> (Int, Int, [(NonVoid Id, Int)])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [NonVoid Id] -> [NonVoid (PrimRep, Id)]
    StgToCmm.Closure.addIdReps
          ([NonVoid Id] -> [NonVoid (PrimRep, Id)])
    -> ([Id] -> [NonVoid Id]) -> [Id] -> [NonVoid (PrimRep, Id)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Id] -> [NonVoid Id]
    StgToCmm.Closure.nonVoidIds
          ([Id] -> (Int, Int, [(NonVoid Id, Int)]))
    -> [Id] -> (Int, Int, [(NonVoid Id, Int)])
    forall a b. (a -> b) -> a -> b
    $ [Id]
    ids

    -- | The number of words a single 'Id' adds to a closure's size.
    -- Note that this can't handle unboxed tuples (which may still be present in
    -- let-no-escapes, even after Unarise), in which case
    -- @'GHC.StgToCmm.ArgRep.idArgRep'@ will crash.
    idClosureFootprint:: Platform -> Id -> WordOff
    idClosureFootprint :: Platform -> Id -> Int
    idClosureFootprint Platform
    platform
      = Platform -> ArgRep -> Int
    StgToCmm.ArgRep.argRepSizeW Platform
    platform
      (ArgRep -> Int) -> (Id -> ArgRep) -> Id -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Id -> ArgRep
    StgToCmm.ArgRep.idArgRep Platform
    platform

    -- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
    -- as a result of lifting @f@ to top-level. If there was any growing closure
    -- under a multi-shot lambda, the result will be 'infinity'.
    -- Also see "GHC.Stg.Lift.Analysis#clogro".
    closureGrowth
      :: (DIdSet -> DIdSet)
      -- ^ Expands outer free ids that were lifted to their free vars
      -> (Id -> Int)
      -- ^ Computes the closure footprint of an identifier
      -> IdSet
      -- ^ Binding group for which lifting is to be decided
      -> DIdSet
      -- ^ Free vars of the whole binding group prior to lifting it. These must be
      --   available at call sites if we decide to lift the binding group.
      -> Skeleton
      -- ^ Abstraction of the scope of the function
      -> IntWithInf
      -- ^ Closure growth. 'infinity' indicates there was growth under a
      --   (multi-shot) lambda.
    closureGrowth :: (DIdSet -> DIdSet)
    -> (Id -> Int) -> IdSet -> DIdSet -> Skeleton -> IntWithInf
    closureGrowth DIdSet -> DIdSet
    expander Id -> Int
    sizer IdSet
    group DIdSet
    abs_ids = Skeleton -> IntWithInf
    go
      where
        go :: Skeleton -> IntWithInf
    go Skeleton
    NilSk = IntWithInf
    0
        go (BothSk Skeleton
    a Skeleton
    b) = Skeleton -> IntWithInf
    go Skeleton
    a IntWithInf -> IntWithInf -> IntWithInf
    forall a. Num a => a -> a -> a
    + Skeleton -> IntWithInf
    go Skeleton
    b
        go (AltSk Skeleton
    a Skeleton
    b) = IntWithInf -> IntWithInf -> IntWithInf
    forall a. Ord a => a -> a -> a
    max (Skeleton -> IntWithInf
    go Skeleton
    a) (Skeleton -> IntWithInf
    go Skeleton
    b)
        go (ClosureSk Id
    _ DIdSet
    clo_fvs Skeleton
    rhs)
          -- If no binder of the @group@ occurs free in the closure, the lifting
          -- won't have any effect on it and we can omit the recursive call.
          | Int
    n_occs Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 = IntWithInf
    0
          -- Otherwise, we account the cost of allocating the closure and add it to
          -- the closure growth of its RHS.
          | Bool
    otherwise   = Int -> IntWithInf
    mkIntWithInf Int
    cost IntWithInf -> IntWithInf -> IntWithInf
    forall a. Num a => a -> a -> a
    + Skeleton -> IntWithInf
    go Skeleton
    rhs
          where
            n_occs :: Int
    n_occs = DIdSet -> Int
    sizeDVarSet (DIdSet
    clo_fvs' DIdSet -> IdSet -> DIdSet
    `dVarSetIntersectVarSet` IdSet
    group)
            -- What we close over considering prior lifting decisions
            clo_fvs' :: DIdSet
    clo_fvs' = DIdSet -> DIdSet
    expander DIdSet
    clo_fvs
            -- Variables that would additionally occur free in the closure body if
            -- we lift @f@
            newbies :: DIdSet
    newbies = DIdSet
    abs_ids DIdSet -> DIdSet -> DIdSet
    `minusDVarSet` DIdSet
    clo_fvs'
            -- Lifting @f@ removes @f@ from the closure but adds all @newbies@
            cost :: Int
    cost = (Id -> Int -> Int) -> Int -> DIdSet -> Int
    forall a. (Id -> a -> a) -> a -> DIdSet -> a
    nonDetStrictFoldDVarSet (\Id
    id Int
    size -> Id -> Int
    sizer Id
    id Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    size) Int
    0 DIdSet
    newbies Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    n_occs
            -- Using a non-deterministic fold is OK here because addition is commutative.
        go (RhsSk Card
    n Skeleton
    body)
          -- The conservative assumption would be that
          --   1. Every RHS with positive growth would be called multiple times,
          --      modulo thunks.
          --   2. Every RHS with negative growth wouldn't be called at all.
          --
          -- In the first case, we'd have to return 'infinity', while in the
          -- second case, we'd have to return 0. But we can do far better
          -- considering information from the demand analyser, which provides us
          -- with conservative estimates on minimum and maximum evaluation
          -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of
          -- 'rhsCard' and accurately captures the cardinality of the RHSs body
          -- relative to its defining context.
          | Card -> Bool
    isAbs Card
    n        = IntWithInf
    0
          | IntWithInf
    cg IntWithInf -> IntWithInf -> Bool
    forall a. Ord a => a -> a -> Bool
    <= IntWithInf
    0        = if Card -> Bool
    isStrict Card
    n then IntWithInf
    cg else IntWithInf
    0
          | Card -> Bool
    isAtMostOnce Card
    n = IntWithInf
    cg
          | Bool
    otherwise      = IntWithInf
    infinity
          where
            cg :: IntWithInf
    cg = Skeleton -> IntWithInf
    go Skeleton
    body