    {-# LANGUAGE CPP #-}

    -- | Implements a selective lambda lifter, running late in the optimisation
    -- pipeline.
    --
    -- If you are interested in the cost model that is employed to decide whether
    -- to lift a binding or not, look at "GHC.Stg.Lift.Analysis".
    -- "GHC.Stg.Lift.Monad" contains the transformation monad that hides away some
    -- plumbing of the transformation.
    module GHC.Stg.Lift
       (
        -- * Late lambda lifting in STG
        -- $note
       stgLiftLams
       )
    where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Types.Basic
    import GHC.Driver.Session
    import GHC.Types.Id
    import GHC.Stg.FVs ( annBindingFreeVars )
    import GHC.Stg.Lift.Analysis
    import GHC.Stg.Lift.Monad
    import GHC.Stg.Syntax
    import GHC.Utils.Outputable
    import GHC.Types.Unique.Supply
    import GHC.Utils.Misc
    import GHC.Utils.Panic
    import GHC.Types.Var.Set
    import Control.Monad ( when )
    import Data.Maybe ( isNothing )

    -- Note [Late lambda lifting in STG]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- $note
    -- See also the <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>
    -- and #9476.
    --
    -- The basic idea behind lambda lifting is to turn locally defined functions
    -- into top-level functions. Free variables are then passed as additional
    -- arguments at *call sites* instead of having a closure allocated for them at
    -- *definition site*. Example:
    --
    -- @
    --    let x = ...; y = ... in
    --    let f = {x y} \a -> a + x + y in
    --    let g = {f x} \b -> f b + x in
    --    g 5
    -- @
    --
    -- Lambda lifting @f@ would
    --
    --   1. Turn @f@'s free variables into formal parameters
    --   2. Update @f@'s call site within @g@ to @f x y b@
    --   3. Update @g@'s closure: Add @y@ as an additional free variable, while
    --      removing @f@, because @f@ no longer allocates and can be floated to
    --      top-level.
    --   4. Actually float the binding of @f@ to top-level, eliminating the @let@
    --      in the process.
    --
    -- This results in the following program (with free var annotations):
    --
    -- @
    --    f x y a = a + x + y;
    --    let x = ...; y = ... in
    --    let g = {x y} \b -> f x y b + x in
    --    g 5
    -- @
    --
    -- This optimisation is all about lifting only when it is beneficial to do so.
    -- The above seems like a worthwhile lift, judging from heap allocation:
    -- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while
    -- not changing the size of @g@'s closure.
    --
    -- You can probably sense that there's some kind of cost model at play here.
    -- And you are right! But we also employ a couple of other heuristics for the
    -- lifting decision which are outlined in "GHC.Stg.Lift.Analysis#when".
    --
    -- The transformation is done in "GHC.Stg.Lift", which calls out to
    -- 'GHC.Stg.Lift.Analysis.goodToLift' for its lifting decision.  It relies on
    -- "GHC.Stg.Lift.Monad", which abstracts some subtle STG invariants into a
    -- monadic substrate.
    --
    -- Suffice to say: We trade heap allocation for stack allocation.
    -- The additional arguments have to passed on the stack (or in registers,
    -- depending on architecture) every time we call the function to save a single
    -- heap allocation when entering the let binding. Nofib suggests a mean
    -- improvement of about 1% for this pass, so it seems like a worthwhile thing to
    -- do. Compile-times went up by 0.6%, so all in all a very modest change.
    --
    -- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'
    -- that is ultimately compiled to something like this
    -- (module desugaring/lowering to actual STG):
    --
    -- @
    --    propagate dt = ...;
    --    runExperiment ... =
    --      let xs = ... in
    --      let ys = ... in
    --      let go = {dt go} \xs ys -> case (xs, ys) of
    --            ([], []) -> []
    --            (x:xs', y:ys') -> propagate dt x y : go xs' ys'
    --      in go xs ys
    -- @
    --
    -- This will lambda lift @go@ to top-level, speeding up the resulting program
    -- by roughly one percent:
    --
    -- @
    --    propagate dt = ...;
    --    go dt xs ys = case (xs, ys) of
    --      ([], []) -> []
    --      (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'
    --    runExperiment ... =
    --      let xs = ... in
    --      let ys = ... in
    --      in go dt xs ys
    -- @

    -- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').
    --
    -- (Mostly) textbook instance of the lambda lifting transformation, selecting
    -- which bindings to lambda lift by consulting 'goodToLift'.
    stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
    stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [InStgTopBinding]
    stgLiftLams DynFlags
    dflags UniqSupply
    us = DynFlags -> UniqSupply -> LiftM () -> [InStgTopBinding]
    runLiftM DynFlags
    dflags UniqSupply
    us forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr InStgTopBinding -> LiftM () -> LiftM ()
    liftTopLvl (forall (f :: * -> *) a. Applicative f => a -> f a
    pure ())

    liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
    liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
    liftTopLvl (StgTopStringLit Id
    bndr ByteString
    lit) LiftM ()
    rest = forall a. Id -> (Id -> LiftM a) -> LiftM a
    withSubstBndr Id
    bndr forall a b. (a -> b) -> a -> b
    $ \Id
    bndr' -> do
      Id -> ByteString -> LiftM ()
    addTopStringLit Id
    bndr' ByteString
    lit
      LiftM ()
    rest
    liftTopLvl (StgTopLifted GenStgBinding 'Vanilla
    bind) LiftM ()
    rest = do
      let is_rec :: Bool
    is_rec = RecFlag -> Bool
    isRec forall a b. (a -> b) -> a -> b
    $ forall a b. (a, b) -> a
    fst forall a b. (a -> b) -> a -> b
    $ forall (pass :: StgPass).
    GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
    decomposeStgBinding GenStgBinding 'Vanilla
    bind
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    is_rec LiftM ()
    startBindingGroup
      let bind_w_fvs :: CgStgBinding
    bind_w_fvs = GenStgBinding 'Vanilla -> CgStgBinding
    annBindingFreeVars GenStgBinding 'Vanilla
    bind
      forall a.
    TopLevelFlag
    -> LlStgBinding
    -> Skeleton
    -> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
    -> LiftM a
    withLiftedBind TopLevelFlag
    TopLevel (CgStgBinding -> LlStgBinding
    tagSkeletonTopBind CgStgBinding
    bind_w_fvs) Skeleton
    NilSk forall a b. (a -> b) -> a -> b
    $ \Maybe (GenStgBinding 'Vanilla)
    mb_bind' -> do
        -- We signal lifting of a binding through returning Nothing.
        -- Should never happen for a top-level binding, though, since we are already
        -- at top-level.
        case Maybe (GenStgBinding 'Vanilla)
    mb_bind' of
          Maybe (GenStgBinding 'Vanilla)
    Nothing -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "StgLiftLams" (String -> SDoc
    text String
    "Lifted top-level binding")
          Just GenStgBinding 'Vanilla
    bind' -> GenStgBinding 'Vanilla -> LiftM ()
    addLiftedBinding GenStgBinding 'Vanilla
    bind'
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    is_rec LiftM ()
    endBindingGroup
        LiftM ()
    rest

    withLiftedBind
      :: TopLevelFlag
      -> LlStgBinding
      -> Skeleton
      -> (Maybe OutStgBinding -> LiftM a)
      -> LiftM a
    withLiftedBind :: forall a.
    TopLevelFlag
    -> LlStgBinding
    -> Skeleton
    -> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
    -> LiftM a
    withLiftedBind TopLevelFlag
    top_lvl LlStgBinding
    bind Skeleton
    scope Maybe (GenStgBinding 'Vanilla) -> LiftM a
    k
      = forall a.
    TopLevelFlag
    -> RecFlag
    -> [(BinderInfo, LlStgRhs)]
    -> Skeleton
    -> (Maybe [(Id, OutStgRhs)] -> LiftM a)
    -> LiftM a
    withLiftedBindPairs TopLevelFlag
    top_lvl RecFlag
    rec [(BinderP 'LiftLams, LlStgRhs)]
    pairs Skeleton
    scope (Maybe (GenStgBinding 'Vanilla) -> LiftM a
    k forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (forall (pass :: StgPass).
    RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    mkStgBinding RecFlag
    rec))
      where
        (RecFlag
    rec, [(BinderP 'LiftLams, LlStgRhs)]
    pairs) = forall (pass :: StgPass).
    GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
    decomposeStgBinding LlStgBinding
    bind

    withLiftedBindPairs
      :: TopLevelFlag
      -> RecFlag
      -> [(BinderInfo, LlStgRhs)]
      -> Skeleton
      -> (Maybe [(Id, OutStgRhs)] -> LiftM a)
      -> LiftM a
    withLiftedBindPairs :: forall a.
    TopLevelFlag
    -> RecFlag
    -> [(BinderInfo, LlStgRhs)]
    -> Skeleton
    -> (Maybe [(Id, OutStgRhs)] -> LiftM a)
    -> LiftM a
    withLiftedBindPairs TopLevelFlag
    top RecFlag
    rec [(BinderInfo, LlStgRhs)]
    pairs Skeleton
    scope Maybe [(Id, OutStgRhs)] -> LiftM a
    k = do
      let ([BinderInfo]
    infos, [LlStgRhs]
    rhss) = forall a b. [(a, b)] -> ([a], [b])
    unzip [(BinderInfo, LlStgRhs)]
    pairs
      let bndrs :: [Id]
    bndrs = forall a b. (a -> b) -> [a] -> [b]
    map BinderInfo -> Id
    binderInfoBndr [BinderInfo]
    infos
      DIdSet -> DIdSet
    expander <- LiftM (DIdSet -> DIdSet)
    liftedIdsExpander
      DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      case DynFlags
    -> TopLevelFlag
    -> RecFlag
    -> (DIdSet -> DIdSet)
    -> [(BinderInfo, LlStgRhs)]
    -> Skeleton
    -> Maybe DIdSet
    goodToLift DynFlags
    dflags TopLevelFlag
    top RecFlag
    rec DIdSet -> DIdSet
    expander [(BinderInfo, LlStgRhs)]
    pairs Skeleton
    scope of
        -- @abs_ids@ is the set of all variables that need to become parameters.
        Just DIdSet
    abs_ids -> forall (f :: * -> *) a.
    Traversable f =>
    DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a
    withLiftedBndrs DIdSet
    abs_ids [Id]
    bndrs forall a b. (a -> b) -> a -> b
    $ \[Id]
    bndrs' -> do
          -- Within this block, all binders in @bndrs@ will be noted as lifted, so
          -- that the return value of @liftedIdsExpander@ in this context will also
          -- expand the bindings in @bndrs@ to their free variables.
          -- Now we can recurse into the RHSs and see if we can lift any further
          -- bindings. We pass the set of expanded free variables (thus OutIds) on
          -- to @liftRhs@ so that it can add them as parameter binders.
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (RecFlag -> Bool
    isRec RecFlag
    rec) LiftM ()
    startBindingGroup
          [OutStgRhs]
    rhss' <- forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse (Maybe DIdSet -> LlStgRhs -> LiftM OutStgRhs
    liftRhs (forall a. a -> Maybe a
    Just DIdSet
    abs_ids)) [LlStgRhs]
    rhss
          let pairs' :: [(Id, OutStgRhs)]
    pairs' = forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    bndrs' [OutStgRhs]
    rhss'
          GenStgBinding 'Vanilla -> LiftM ()
    addLiftedBinding (forall (pass :: StgPass).
    RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    mkStgBinding RecFlag
    rec [(Id, OutStgRhs)]
    pairs')
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (RecFlag -> Bool
    isRec RecFlag
    rec) LiftM ()
    endBindingGroup
          Maybe [(Id, OutStgRhs)] -> LiftM a
    k forall a. Maybe a
    Nothing
        Maybe DIdSet
    Nothing -> forall (f :: * -> *) a.
    Traversable f =>
    f Id -> (f Id -> LiftM a) -> LiftM a
    withSubstBndrs [Id]
    bndrs forall a b. (a -> b) -> a -> b
    $ \[Id]
    bndrs' -> do
          -- Don't lift the current binding, but possibly some bindings in their
          -- RHSs.
          [OutStgRhs]
    rhss' <- forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse (Maybe DIdSet -> LlStgRhs -> LiftM OutStgRhs
    liftRhs forall a. Maybe a
    Nothing) [LlStgRhs]
    rhss
          let pairs' :: [(Id, OutStgRhs)]
    pairs' = forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    bndrs' [OutStgRhs]
    rhss'
          Maybe [(Id, OutStgRhs)] -> LiftM a
    k (forall a. a -> Maybe a
    Just [(Id, OutStgRhs)]
    pairs')

    liftRhs
      :: Maybe (DIdSet)
      -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@
      -- as lambda binders, discarding all free vars.
      -> LlStgRhs
      -> LiftM OutStgRhs
    liftRhs :: Maybe DIdSet -> LlStgRhs -> LiftM OutStgRhs
    liftRhs Maybe DIdSet
    mb_former_fvs rhs :: LlStgRhs
    rhs@(StgRhsCon CostCentreStack
    ccs DataCon
    con ConstructorNumber
    mn [StgTickish]
    ts [StgArg]
    args)
      = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)
        forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    ccs DataCon
    con ConstructorNumber
    mn [StgTickish]
    ts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse StgArg -> LiftM StgArg
    liftArgs [StgArg]
    args
    liftRhs Maybe DIdSet
    Nothing (StgRhsClosure XRhsClosure 'LiftLams
    _ CostCentreStack
    ccs UpdateFlag
    upd [BinderP 'LiftLams]
    infos GenStgExpr 'LiftLams
    body) =
      -- This RHS wasn't lifted.
      forall (f :: * -> *) a.
    Traversable f =>
    f Id -> (f Id -> LiftM a) -> LiftM a
    withSubstBndrs (forall a b. (a -> b) -> [a] -> [b]
    map BinderInfo -> Id
    binderInfoBndr [BinderP 'LiftLams]
    infos) forall a b. (a -> b) -> a -> b
    $ \[Id]
    bndrs' ->
        forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent CostCentreStack
    ccs UpdateFlag
    upd [Id]
    bndrs' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'LiftLams -> LiftM OutStgExpr
    liftExpr GenStgExpr 'LiftLams
    body
    liftRhs (Just DIdSet
    former_fvs) (StgRhsClosure XRhsClosure 'LiftLams
    _ CostCentreStack
    ccs UpdateFlag
    upd [BinderP 'LiftLams]
    infos GenStgExpr 'LiftLams
    body) =
      -- This RHS was lifted. Insert extra binders for @former_fvs@.
      forall (f :: * -> *) a.
    Traversable f =>
    f Id -> (f Id -> LiftM a) -> LiftM a
    withSubstBndrs (forall a b. (a -> b) -> [a] -> [b]
    map BinderInfo -> Id
    binderInfoBndr [BinderP 'LiftLams]
    infos) forall a b. (a -> b) -> a -> b
    $ \[Id]
    bndrs' -> do
        let bndrs'' :: [Id]
    bndrs'' = DIdSet -> [Id]
    dVarSetElems DIdSet
    former_fvs forall a. [a] -> [a] -> [a]
    ++ [Id]
    bndrs'
        forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent CostCentreStack
    ccs UpdateFlag
    upd [Id]
    bndrs'' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'LiftLams -> LiftM OutStgExpr
    liftExpr GenStgExpr 'LiftLams
    body

    liftArgs :: InStgArg -> LiftM OutStgArg
    liftArgs :: StgArg -> LiftM StgArg
    liftArgs a :: StgArg
    a@(StgLitArg Literal
    _) = forall (f :: * -> *) a. Applicative f => a -> f a
    pure StgArg
    a
    liftArgs (StgVarArg Id
    occ) = do
      ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )
      Id -> StgArg
    StgVarArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Id -> LiftM Id
    substOcc Id
    occ

    liftExpr :: LlStgExpr -> LiftM OutStgExpr
    liftExpr :: GenStgExpr 'LiftLams -> LiftM OutStgExpr
    liftExpr (StgLit Literal
    lit) = forall (f :: * -> *) a. Applicative f => a -> f a
    pure (forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    lit)
    liftExpr (StgTick StgTickish
    t GenStgExpr 'LiftLams
    e) = forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'LiftLams -> LiftM OutStgExpr
    liftExpr GenStgExpr 'LiftLams
    e
    liftExpr (StgApp Id
    f [StgArg]
    args) = do
      Id
    f' <- Id -> LiftM Id
    substOcc Id
    f
      [StgArg]
    args' <- forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse StgArg -> LiftM StgArg
    liftArgs [StgArg]
    args
      [Id]
    fvs' <- Id -> LiftM [Id]
    formerFreeVars Id
    f
      let top_lvl_args :: [StgArg]
    top_lvl_args = forall a b. (a -> b) -> [a] -> [b]
    map Id -> StgArg
    StgVarArg [Id]
    fvs' forall a. [a] -> [a] -> [a]
    ++ [StgArg]
    args'
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure (forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
    StgApp Id
    f' [StgArg]
    top_lvl_args)
    liftExpr (StgConApp DataCon
    con XConApp 'LiftLams
    mn [StgArg]
    args [Type]
    tys) = forall (pass :: StgPass).
    DataCon -> XConApp pass -> [StgArg] -> [Type] -> GenStgExpr pass
    StgConApp DataCon
    con XConApp 'LiftLams
    mn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse StgArg -> LiftM StgArg
    liftArgs [StgArg]
    args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> forall (f :: * -> *) a. Applicative f => a -> f a
    pure [Type]
    tys
    liftExpr (StgOpApp StgOp
    op [StgArg]
    args Type
    ty) = forall (pass :: StgPass).
    StgOp -> [StgArg] -> Type -> GenStgExpr pass
    StgOpApp StgOp
    op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse StgArg -> LiftM StgArg
    liftArgs [StgArg]
    args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    ty
    liftExpr (StgCase GenStgExpr 'LiftLams
    scrut BinderP 'LiftLams
    info AltType
    ty [GenStgAlt 'LiftLams]
    alts) = do
      OutStgExpr
    scrut' <- GenStgExpr 'LiftLams -> LiftM OutStgExpr
    liftExpr GenStgExpr 'LiftLams
    scrut
      forall a. Id -> (Id -> LiftM a) -> LiftM a
    withSubstBndr (BinderInfo -> Id
    binderInfoBndr BinderP 'LiftLams
    info) forall a b. (a -> b) -> a -> b
    $ \Id
    bndr' -> do
        [(AltCon, [Id], OutStgExpr)]
    alts' <- forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse GenStgAlt 'LiftLams -> LiftM OutStgAlt
    liftAlt [GenStgAlt 'LiftLams]
    alts
        forall (f :: * -> *) a. Applicative f => a -> f a
    pure (forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase OutStgExpr
    scrut' Id
    bndr' AltType
    ty [(AltCon, [Id], OutStgExpr)]
    alts')
    liftExpr (StgLet XLet 'LiftLams
    scope LlStgBinding
    bind GenStgExpr 'LiftLams
    body)
      = forall a.
    TopLevelFlag
    -> LlStgBinding
    -> Skeleton
    -> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
    -> LiftM a
    withLiftedBind TopLevelFlag
    NotTopLevel LlStgBinding
    bind XLet 'LiftLams
    scope forall a b. (a -> b) -> a -> b
    $ \Maybe (GenStgBinding 'Vanilla)
    mb_bind' -> do
          OutStgExpr
    body' <- GenStgExpr 'LiftLams -> LiftM OutStgExpr
    liftExpr GenStgExpr 'LiftLams
    body
          case Maybe (GenStgBinding 'Vanilla)
    mb_bind' of
            Maybe (GenStgBinding 'Vanilla)
    Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
    pure OutStgExpr
    body' -- withLiftedBindPairs decided to lift it and already added floats
            Just GenStgBinding 'Vanilla
    bind' -> forall (f :: * -> *) a. Applicative f => a -> f a
    pure (forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet NoExtFieldSilent
    noExtFieldSilent GenStgBinding 'Vanilla
    bind' OutStgExpr
    body')
    liftExpr (StgLetNoEscape XLetNoEscape 'LiftLams
    scope LlStgBinding
    bind GenStgExpr 'LiftLams
    body)
      = forall a.
    TopLevelFlag
    -> LlStgBinding
    -> Skeleton
    -> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
    -> LiftM a
    withLiftedBind TopLevelFlag
    NotTopLevel LlStgBinding
    bind XLetNoEscape 'LiftLams
    scope forall a b. (a -> b) -> a -> b
    $ \Maybe (GenStgBinding 'Vanilla)
    mb_bind' -> do
          OutStgExpr
    body' <- GenStgExpr 'LiftLams -> LiftM OutStgExpr
    liftExpr GenStgExpr 'LiftLams
    body
          case Maybe (GenStgBinding 'Vanilla)
    mb_bind' of
            Maybe (GenStgBinding 'Vanilla)
    Nothing -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "stgLiftLams" (String -> SDoc
    text String
    "Should never decide to lift LNEs")
            Just GenStgBinding 'Vanilla
    bind' -> forall (f :: * -> *) a. Applicative f => a -> f a
    pure (forall (pass :: StgPass).
    XLetNoEscape pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLetNoEscape NoExtFieldSilent
    noExtFieldSilent GenStgBinding 'Vanilla
    bind' OutStgExpr
    body')

    liftAlt :: LlStgAlt -> LiftM OutStgAlt
    liftAlt :: GenStgAlt 'LiftLams -> LiftM OutStgAlt
    liftAlt (AltCon
    con, [BinderP 'LiftLams]
    infos, GenStgExpr 'LiftLams
    rhs) = forall (f :: * -> *) a.
    Traversable f =>
    f Id -> (f Id -> LiftM a) -> LiftM a
    withSubstBndrs (forall a b. (a -> b) -> [a] -> [b]
    map BinderInfo -> Id
    binderInfoBndr [BinderP 'LiftLams]
    infos) forall a b. (a -> b) -> a -> b
    $ \[Id]
    bndrs' ->
      (,,) AltCon
    con [Id]
    bndrs' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'LiftLams -> LiftM OutStgExpr
    liftExpr GenStgExpr 'LiftLams
    rhs