    {-# 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.Driver.Session
    import GHC.Types.Id
    import GHC.Runtime.Heap.Layout ( WordOff )
    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

    type instance BinderP      'LiftLams = BinderInfo
    type instance XRhsClosure  'LiftLams = DIdSet
    type instance XLet         'LiftLams = Skeleton
    type instance XLetNoEscape 'LiftLams = Skeleton
    type instance XConApp      'LiftLams = ConstructorNumber

    -- | Captures details of the syntax tree relevant to the cost model, such as
    -- closures, multi-shot lambdas and case expressions.
    data Skeleton
      = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton
      | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton
      | AltSk !Skeleton !Skeleton
      | BothSk !Skeleton !Skeleton
      | NilSk

    bothSk :: Skeleton -> Skeleton -> Skeleton
    bothSk :: Skeleton -> Skeleton -> Skeleton
    bothSk Skeleton
    NilSk Skeleton
    b = Skeleton
    b
    bothSk Skeleton
    a Skeleton
    NilSk = Skeleton
    a
    bothSk Skeleton
    a Skeleton
    b     = Skeleton -> Skeleton -> Skeleton
    BothSk Skeleton
    a Skeleton
    b

    altSk :: Skeleton -> Skeleton -> Skeleton
    altSk :: Skeleton -> Skeleton -> Skeleton
    altSk Skeleton
    NilSk Skeleton
    b = Skeleton
    b
    altSk Skeleton
    a Skeleton
    NilSk = Skeleton
    a
    altSk Skeleton
    a Skeleton
    b     = Skeleton -> Skeleton -> Skeleton
    AltSk Skeleton
    a Skeleton
    b

    rhsSk :: Card -> Skeleton -> Skeleton
    rhsSk :: Card -> Skeleton -> Skeleton
    rhsSk Card
    _        Skeleton
    NilSk = Skeleton
    NilSk
    rhsSk Card
    body_dmd Skeleton
    skel  = Card -> Skeleton -> Skeleton
    RhsSk Card
    body_dmd Skeleton
    skel

    -- | The type used in binder positions in 'GenStgExpr's.
    data BinderInfo
      = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag
                               --   indicating whether it occurs as an argument
                               --   or in a nullary application
                               --   (see "GHC.Stg.Lift.Analysis#arg_occs").
      | BoringBinder !Id       -- ^ Every other kind of binder

    -- | Gets the bound 'Id' out a 'BinderInfo'.
    binderInfoBndr :: BinderInfo -> Id
    binderInfoBndr :: BinderInfo -> Id
    binderInfoBndr (BoringBinder Id
    bndr)   = Id
    bndr
    binderInfoBndr (BindsClosure Id
    bndr Bool
    _) = Id
    bndr

    -- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating
    -- occurrences as argument or in a nullary applications otherwise.
    binderInfoOccursAsArg :: BinderInfo -> Maybe Bool
    binderInfoOccursAsArg :: BinderInfo -> Maybe Bool
    binderInfoOccursAsArg BoringBinder{}     = forall a. Maybe a
    Nothing
    binderInfoOccursAsArg (BindsClosure Id
    _ Bool
    b) = forall a. a -> Maybe a
    Just Bool
    b

    instance Outputable Skeleton where
      ppr :: Skeleton -> SDoc
    ppr Skeleton
    NilSk = String -> SDoc
    text String
    ""
      ppr (AltSk Skeleton
    l Skeleton
    r) = [SDoc] -> SDoc
    vcat
        [ String -> SDoc
    text String
    "{ " SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr Skeleton
    l
        , String -> SDoc
    text String
    "ALT"
        , String -> SDoc
    text String
    "  " SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr Skeleton
    r
        , String -> SDoc
    text String
    "}"
        ]
      ppr (BothSk Skeleton
    l Skeleton
    r) = forall a. Outputable a => a -> SDoc
    ppr Skeleton
    l SDoc -> SDoc -> SDoc
    $$ forall a. Outputable a => a -> SDoc
    ppr Skeleton
    r
      ppr (ClosureSk Id
    f DIdSet
    fvs Skeleton
    body) = forall a. Outputable a => a -> SDoc
    ppr Id
    f SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr DIdSet
    fvs SDoc -> SDoc -> SDoc
    $$ Int -> SDoc -> SDoc
    nest Int
    2 (forall a. Outputable a => a -> SDoc
    ppr Skeleton
    body)
      ppr (RhsSk Card
    card Skeleton
    body) = [SDoc] -> SDoc
    hcat
        [ SDoc
    lambda
        , forall a. Outputable a => a -> SDoc
    ppr Card
    card
        , SDoc
    dot
        , forall a. Outputable a => a -> SDoc
    ppr Skeleton
    body
        ]

    instance Outputable BinderInfo where
      ppr :: BinderInfo -> SDoc
    ppr = forall a. Outputable a => a -> SDoc
    ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BinderInfo -> Id
    binderInfoBndr

    instance OutputableBndr BinderInfo where
      pprBndr :: BindingSite -> BinderInfo -> SDoc
    pprBndr BindingSite
    b = forall a. OutputableBndr a => BindingSite -> a -> SDoc
    pprBndr BindingSite
    b forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BinderInfo -> Id
    binderInfoBndr
      pprPrefixOcc :: BinderInfo -> SDoc
    pprPrefixOcc = forall a. OutputableBndr a => a -> SDoc
    pprPrefixOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BinderInfo -> Id
    binderInfoBndr
      pprInfixOcc :: BinderInfo -> SDoc
    pprInfixOcc = forall a. OutputableBndr a => a -> SDoc
    pprInfixOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BinderInfo -> Id
    binderInfoBndr
      bndrIsJoin_maybe :: BinderInfo -> Maybe Int
    bndrIsJoin_maybe = forall a. OutputableBndr a => a -> Maybe Int
    bndrIsJoin_maybe forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BinderInfo -> Id
    binderInfoBndr

    mkArgOccs :: [StgArg] -> IdSet
    mkArgOccs :: [StgArg] -> IdSet
    mkArgOccs = [Id] -> IdSet
    mkVarSet forall b c a. (b -> c) -> (a -> b) -> a -> c
    . 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) = forall a. a -> Maybe a
    Just Id
    occ
        stg_arg_var StgArg
    _               = 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, forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    lit)
    tagSkeletonExpr (StgConApp DataCon
    con XConApp 'CodeGen
    mn [StgArg]
    args [Type]
    tys)
      = (Skeleton
    NilSk, [StgArg] -> IdSet
    mkArgOccs [StgArg]
    args, forall (pass :: StgPass).
    DataCon -> XConApp pass -> [StgArg] -> [Type] -> GenStgExpr pass
    StgConApp DataCon
    con XConApp 'CodeGen
    mn [StgArg]
    args [Type]
    tys)
    tagSkeletonExpr (StgOpApp StgOp
    op [StgArg]
    args Type
    ty)
      = (Skeleton
    NilSk, [StgArg] -> IdSet
    mkArgOccs [StgArg]
    args, 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, 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".
          | 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, forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase LlStgExpr
    scrut' BinderInfo
    bndr' AltType
    ty [(AltCon, [BinderInfo], LlStgExpr)]
    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, [(AltCon, [BinderInfo], LlStgExpr)]
    alts') = forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
    mapAndUnzip3 GenStgAlt 'CodeGen -> (Skeleton, IdSet, LlStgAlt)
    tagSkeletonAlt [GenStgAlt 'CodeGen]
    alts
        skel :: Skeleton
    skel = Skeleton -> Skeleton -> Skeleton
    bothSk Skeleton
    scrut_skel (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_occsforall a. a -> [a] -> [a]
    :[IdSet]
    alt_arg_occss) IdSet -> Id -> IdSet
    `delVarSet` BinderP 'CodeGen
    bndr
        bndr' :: BinderInfo
    bndr' = Id -> BinderInfo
    BoringBinder BinderP 'CodeGen
    bndr
    tagSkeletonExpr (StgTick StgTickish
    t CgStgExpr
    e)
      = (Skeleton
    skel, IdSet
    arg_occs, 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 = forall (pass :: StgPass).
    XLetNoEscape pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLetNoEscape
    mkLet Bool
    _    = 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 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` 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 BinderP 'CodeGen
    bndr (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 = 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' = forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec (Id -> Bool -> BinderInfo
    BindsClosure 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, forall (pass :: StgPass).
    [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    StgRec [(BinderInfo, LlStgRhs)]
    pairs')
      where
        ([Id]
    bndrs, [GenStgRhs 'CodeGen]
    _) = forall a b. [(a, b)] -> ([a], [b])
    unzip [(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' = forall a b. (a -> b) -> [a] -> [b]
    map (forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry Id -> GenStgRhs 'CodeGen -> (Skeleton, IdSet, LlStgRhs)
    tagSkeletonRhs) [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
    pairs
        rhss_arg_occs :: [IdSet]
    rhss_arg_occs = forall a b. (a -> b) -> [a] -> [b]
    map 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_occsforall 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 = forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (Skeleton -> Skeleton -> Skeleton
    bothSk forall b c a. (b -> c) -> (a -> b) -> a -> c
    . 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') = forall a b. [(a, b)] -> ([a], [b])
    unzip (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 = 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 = 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)
      = (Skeleton
    NilSk, [StgArg] -> IdSet
    mkArgOccs [StgArg]
    args, forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    ccs DataCon
    dc ConstructorNumber
    mn [StgTickish]
    ts [StgArg]
    args)
    tagSkeletonRhs Id
    bndr (StgRhsClosure XRhsClosure 'CodeGen
    fvs CostCentreStack
    ccs UpdateFlag
    upd [BinderP 'CodeGen]
    bndrs CgStgExpr
    body)
      = (Skeleton
    rhs_skel, IdSet
    body_arg_occs, forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'CodeGen
    fvs CostCentreStack
    ccs UpdateFlag
    upd [BinderInfo]
    bndrs' LlStgExpr
    body')
      where
        bndrs' :: [BinderInfo]
    bndrs' = forall a b. (a -> b) -> [a] -> [b]
    map Id -> BinderInfo
    BoringBinder [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 = Int -> SubDemand -> Card
    peelManyCalls (Id -> Int
    idArity Id
    bndr) SubDemand
    cd
      where
        is_thunk :: Bool
    is_thunk = Id -> Int
    idArity Id
    bndr 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, LlStgAlt)
    tagSkeletonAlt (AltCon
    con, [BinderP 'CodeGen]
    bndrs, CgStgExpr
    rhs)
      = (Skeleton
    alt_skel, IdSet
    arg_occs, (AltCon
    con, forall a b. (a -> b) -> [a] -> [b]
    map Id -> BinderInfo
    BoringBinder [BinderP 'CodeGen]
    bndrs, LlStgExpr
    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` [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
      :: DynFlags
      -> 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 :: DynFlags
    -> TopLevelFlag
    -> RecFlag
    -> (DIdSet -> DIdSet)
    -> [(BinderInfo, LlStgRhs)]
    -> Skeleton
    -> Maybe DIdSet
    goodToLift DynFlags
    dflags 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  = DynFlags -> Profile
    targetProfile DynFlags
    dflags
          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)
            = forall a. String -> SDoc -> a -> a
    llTrace String
    "stgLiftLams:lifting"
                      (forall a. Outputable a => a -> SDoc
    ppr [Id]
    bndrs SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr DIdSet
    abs_ids SDoc -> SDoc -> SDoc
    $$
                       forall a. Outputable a => a -> SDoc
    ppr IntWithInf
    allocs SDoc -> SDoc -> SDoc
    $$
                       forall a. Outputable a => a -> SDoc
    ppr Skeleton
    scope) forall a b. (a -> b) -> a -> b
    $
              forall a. a -> Maybe a
    Just DIdSet
    abs_ids
            | Bool
    otherwise
            = forall a. Maybe a
    Nothing
          ppr_deciders :: [(String, Bool)] -> SDoc
    ppr_deciders = [SDoc] -> SDoc
    vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a -> b) -> [a] -> [b]
    map (String -> SDoc
    text forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a, b) -> a
    fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a. (a -> Bool) -> [a] -> [a]
    filter forall a b. (a, b) -> b
    snd
          fancy_or :: [(String, Bool)] -> Bool
    fancy_or [(String, Bool)]
    deciders
            = forall a. String -> SDoc -> a -> a
    llTrace String
    "stgLiftLams:goodToLift" (forall a. Outputable a => a -> SDoc
    ppr [Id]
    bndrs SDoc -> SDoc -> SDoc
    $$ [(String, Bool)] -> SDoc
    ppr_deciders [(String, Bool)]
    deciders) forall a b. (a -> b) -> a -> b
    $
              forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any forall a b. (a, b) -> b
    snd [(String, Bool)]
    deciders

          bndrs :: [Id]
    bndrs = forall a b. (a -> b) -> [a] -> [b]
    map (BinderInfo -> Id
    binderInfoBndr forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a, b) -> a
    fst) [(BinderInfo, LlStgRhs)]
    pairs
          bndrs_set :: IdSet
    bndrs_set = [Id] -> IdSet
    mkVarSet [Id]
    bndrs
          rhss :: [LlStgRhs]
    rhss = forall a b. (a -> b) -> [a] -> [b]
    map 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 (forall a b. (a -> b) -> [a] -> [b]
    map 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any 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
    _) = 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 = forall (t :: * -> *). Foldable t => t Bool -> Bool
    or (forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (BinderInfo -> Maybe Bool
    binderInfoOccursAsArg forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a, b) -> a
    fst) [(BinderInfo, LlStgRhs)]
    pairs)

          -- These don't allocate anyway.
          is_join_point :: Bool
    is_join_point = 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 = 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 forall a. Ord a => a -> a -> Bool
    > Int
    0
          abstracts_known_local_fun :: Bool
    abstracts_known_local_fun
            = Bool -> Bool
    not (DynFlags -> Bool
    liftLamsKnown DynFlags
    dflags) Bool -> Bool -> 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
            = forall (t :: * -> *) a. Foldable t => t a -> Int
    length
            forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Id] -> [NonVoid Id]
    StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm
            forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (DIdSet -> [Id]
    dVarSetElems DIdSet
    abs_ids forall a. [a] -> [a] -> [a]
    ++)
            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 = DynFlags -> Maybe Int
    liftLamsRecArgs DynFlags
    dflags
            | Bool
    otherwise      = DynFlags -> Maybe Int
    liftLamsNonRecArgs DynFlags
    dflags
          -- 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 = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum (forall a b. (a -> b) -> [a] -> [b]
    map LlStgRhs -> Int
    n_args [LlStgRhs]
    rhss) 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 forall a. Ord a => a -> a -> Bool
    > IntWithInf
    0
          allocs :: IntWithInf
    allocs = IntWithInf
    clo_growth forall a. Num a => a -> a -> a
    + Int -> IntWithInf
    mkIntWithInf (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 = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum forall a b. (a -> b) -> a -> b
    $ forall a b c. (a -> b -> c) -> b -> a -> c
    flip forall a b. (a -> b) -> [a] -> [b]
    map [LlStgRhs]
    rhss forall a b. (a -> b) -> a -> b
    $ \LlStgRhs
    rhs ->
            Profile -> [Id] -> Int
    closureSize Profile
    profile
            forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DIdSet -> [Id]
    dVarSetElems
            forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DIdSet -> DIdSet
    expander
            forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b c. (a -> b -> c) -> b -> a -> c
    flip DIdSet -> IdSet -> DIdSet
    dVarSetMinusVarSet IdSet
    bndrs_set
            forall a b. (a -> b) -> a -> b
    $ 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
    _) = forall a b. (a -> b) -> [a] -> [b]
    map BinderInfo -> Id
    binderInfoBndr [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 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).
          = forall a.
    Profile
    -> ClosureHeader
    -> [NonVoid (PrimRep, a)]
    -> (Int, Int, [(NonVoid a, Int)])
    StgToCmm.Layout.mkVirtHeapOffsets Profile
    profile ClosureHeader
    StgToCmm.Layout.StdHeader
          forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [NonVoid Id] -> [NonVoid (PrimRep, Id)]
    StgToCmm.Closure.addIdReps
          forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Id] -> [NonVoid Id]
    StgToCmm.Closure.nonVoidIds
          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.Closure.idPrimRep'@ will crash.
    idClosureFootprint:: Platform -> Id -> WordOff
    idClosureFootprint :: Platform -> Id -> Int
    idClosureFootprint Platform
    platform
      = Platform -> ArgRep -> Int
    StgToCmm.ArgRep.argRepSizeW Platform
    platform
      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 forall a. Num a => a -> a -> a
    + Skeleton -> IntWithInf
    go Skeleton
    b
        go (AltSk Skeleton
    a Skeleton
    b) = 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 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 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 = forall a. (Id -> a -> a) -> a -> DIdSet -> a
    nonDetStrictFoldDVarSet (\Id
    id Int
    size -> Id -> Int
    sizer Id
    id forall a. Num a => a -> a -> a
    + Int
    size) Int
    0 DIdSet
    newbies 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 forall a. Ord a => a -> a -> Bool
    <= IntWithInf
    0      = if Card -> Bool
    isStrict Card
    n then IntWithInf
    cg else IntWithInf
    0
          | Card -> Bool
    isUsedOnce Card
    n = IntWithInf
    cg
          | Bool
    otherwise    = IntWithInf
    infinity
          where
            cg :: IntWithInf
    cg = Skeleton -> IntWithInf
    go Skeleton
    body