{-# LANGUAGE BangPatterns #-}
{-# 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.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 'DmdShell'.
--   * '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

freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet
freeVarsOfRhs :: forall (pass :: StgPass).
(XRhsClosure pass ~ DIdSet) =>
GenStgRhs pass -> DIdSet
freeVarsOfRhs (StgRhsCon CostCentreStack
_ DataCon
_ [StgArg]
args) = [Id] -> DIdSet
mkDVarSet [ Id
id | StgVarArg Id
id <- [StgArg]
args ]
freeVarsOfRhs (StgRhsClosure XRhsClosure pass
fvs CostCentreStack
_ UpdateFlag
_ [BinderP pass]
_ GenStgExpr pass
_) = DIdSet
XRhsClosure pass
fvs

-- | 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 !DmdShell {- ^ 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 :: DmdShell -> Skeleton -> Skeleton
rhsSk :: DmdShell -> Skeleton -> Skeleton
rhsSk DmdShell
_        Skeleton
NilSk = Skeleton
NilSk
rhsSk DmdShell
body_dmd Skeleton
skel  = DmdShell -> Skeleton -> Skeleton
RhsSk DmdShell
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{}     = Maybe Bool
forall a. Maybe a
Nothing
binderInfoOccursAsArg (BindsClosure Id
_ Bool
b) = Bool -> Maybe Bool
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
<+> Skeleton -> SDoc
forall a. Outputable a => a -> SDoc
ppr Skeleton
l
    , String -> SDoc
text String
"ALT"
    , String -> SDoc
text String
"  " SDoc -> SDoc -> SDoc
<+> Skeleton -> SDoc
forall a. Outputable a => a -> SDoc
ppr Skeleton
r
    , String -> SDoc
text String
"}"
    ]
  ppr (BothSk Skeleton
l Skeleton
r) = Skeleton -> SDoc
forall a. Outputable a => a -> SDoc
ppr Skeleton
l SDoc -> SDoc -> SDoc
$$ Skeleton -> SDoc
forall a. Outputable a => a -> SDoc
ppr Skeleton
r
  ppr (ClosureSk Id
f DIdSet
fvs Skeleton
body) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
f SDoc -> SDoc -> SDoc
<+> DIdSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr DIdSet
fvs SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
2 (Skeleton -> SDoc
forall a. Outputable a => a -> SDoc
ppr Skeleton
body)
  ppr (RhsSk DmdShell
body_dmd Skeleton
body) = [SDoc] -> SDoc
hcat
    [ String -> SDoc
text String
"λ["
    , Char -> SDoc
forall a. Outputable a => a -> SDoc
ppr Char
str
    , String -> SDoc
text String
", "
    , Char -> SDoc
forall a. Outputable a => a -> SDoc
ppr Char
use
    , String -> SDoc
text String
"]. "
    , Skeleton -> SDoc
forall a. Outputable a => a -> SDoc
ppr Skeleton
body
    ]
    where
      str :: Char
str
        | DmdShell -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd DmdShell
body_dmd = Char
'1'
        | Bool
otherwise = Char
'0'
      use :: Char
use
        | DmdShell -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isAbsDmd DmdShell
body_dmd = Char
'0'
        | DmdShell -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isUsedOnce DmdShell
body_dmd = Char
'1'
        | Bool
otherwise = Char
'ω'

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

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

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 [StgArg]
args [Type]
tys)
  = (Skeleton
NilSk, [StgArg] -> IdSet
mkArgOccs [StgArg]
args, DataCon -> [StgArg] -> [Type] -> LlStgExpr
forall (pass :: StgPass).
DataCon -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
con [StgArg]
args [Type]
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args = Id -> IdSet
unitVarSet Id
f
      | Bool
otherwise = [StgArg] -> IdSet
mkArgOccs [StgArg]
args
tagSkeletonExpr (StgLam NonEmpty (BinderP 'CodeGen)
_ StgExpr
_) = String -> SDoc -> (Skeleton, IdSet, LlStgExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"stgLiftLams" (String -> SDoc
text String
"StgLam")
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' BinderP 'LiftLams
BinderInfo
bndr' AltType
ty [GenStgAlt 'LiftLams]
[(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') = ((AltCon, [Id], CgStgExpr)
 -> (Skeleton, IdSet, (AltCon, [BinderInfo], LlStgExpr)))
-> [(AltCon, [Id], CgStgExpr)]
-> ([Skeleton], [IdSet], [(AltCon, [BinderInfo], LlStgExpr)])
forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
mapAndUnzip3 (AltCon, [Id], CgStgExpr)
-> (Skeleton, IdSet, (AltCon, [BinderInfo], LlStgExpr))
GenStgAlt 'CodeGen -> (Skeleton, IdSet, GenStgAlt 'LiftLams)
tagSkeletonAlt [(AltCon, [Id], CgStgExpr)]
[GenStgAlt 'CodeGen]
alts
    skel :: Skeleton
skel = Skeleton -> Skeleton -> Skeleton
bothSk Skeleton
scrut_skel ((Skeleton -> Skeleton -> Skeleton)
-> Skeleton -> [Skeleton] -> Skeleton
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 Tickish Id
t CgStgExpr
e)
  = (Skeleton
skel, IdSet
arg_occs, Tickish Id -> LlStgExpr -> LlStgExpr
forall (pass :: StgPass).
Tickish Id -> GenStgExpr pass -> GenStgExpr pass
StgTick Tickish Id
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
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape
mkLet Bool
_    = Skeleton -> 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 [(BinderP 'LiftLams, LlStgRhs)]
[(BinderInfo, 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 (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 (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 [StgArg]
args)
  = (Skeleton
NilSk, [StgArg] -> IdSet
mkArgOccs [StgArg]
args, CostCentreStack -> DataCon -> [StgArg] -> LlStgRhs
forall (pass :: StgPass).
CostCentreStack -> DataCon -> [StgArg] -> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
dc [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, XRhsClosure 'LiftLams
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'LiftLams]
-> LlStgExpr
-> LlStgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'CodeGen
XRhsClosure 'LiftLams
fvs CostCentreStack
ccs UpdateFlag
upd [BinderP 'LiftLams]
[BinderInfo]
bndrs' LlStgExpr
body')
  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 = DmdShell -> Skeleton -> Skeleton
rhsSk (Id -> DmdShell
rhsDmdShell 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 'DmdShell'.
rhsDmdShell :: Id -> DmdShell
rhsDmdShell :: Id -> DmdShell
rhsDmdShell Id
bndr
  | Bool
is_thunk = DmdShell -> DmdShell
forall s u. JointDmd s (Use u) -> JointDmd s (Use u)
oneifyDmd DmdShell
ds
  | Bool
otherwise = Int -> CleanDemand -> DmdShell
peelManyCalls (Id -> Int
idArity Id
bndr) CleanDemand
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...
    (DmdShell
ds, CleanDemand
cd) = Demand -> (DmdShell, CleanDemand)
toCleanDmd (Id -> Demand
idDemandInfo Id
bndr)

tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)
tagSkeletonAlt :: GenStgAlt 'CodeGen -> (Skeleton, IdSet, GenStgAlt 'LiftLams)
tagSkeletonAlt (AltCon
con, [BinderP 'CodeGen]
bndrs, CgStgExpr
rhs)
  = (Skeleton
alt_skel, IdSet
arg_occs, (AltCon
con, (Id -> BinderInfo) -> [Id] -> [BinderInfo]
forall a b. (a -> b) -> [a] -> [b]
map Id -> BinderInfo
BoringBinder [Id]
[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` [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
  :: 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
      platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      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
<+> DIdSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr DIdSet
abs_ids SDoc -> SDoc -> SDoc
$$
                   IntWithInf -> SDoc
forall a. Outputable a => a -> SDoc
ppr IntWithInf
allocs SDoc -> SDoc -> SDoc
$$
                   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
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
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
$$ [(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
_) = 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 (DynFlags -> Bool
liftLamsKnown DynFlags
dflags) 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 (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 = 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 = [Int] -> Int
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 (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 ->
        DynFlags -> [Id] -> Int
closureSize DynFlags
dflags
        ([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
_) = (BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderP 'LiftLams]
[BinderInfo]
bndrs

-- | The size in words of a function closure closing over the given 'Id's,
-- including the header.
closureSize :: DynFlags -> [Id] -> WordOff
closureSize :: DynFlags -> [Id] -> Int
closureSize DynFlags
dflags [Id]
ids = Int
words Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
sTD_HDR_SIZE DynFlags
dflags
  -- 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).
      = DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (Int, Int, [(NonVoid Id, Int)])
forall a.
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
StgToCmm.Layout.mkVirtHeapOffsets DynFlags
dflags 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.Closure.idPrimRep'@ 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
. Id -> ArgRep
StgToCmm.ArgRep.idArgRep

-- | @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 DmdShell
body_dmd 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
      -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body
      -- relative to its defining context.
      | DmdShell -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isAbsDmd DmdShell
body_dmd   = IntWithInf
0
      | IntWithInf
cg IntWithInf -> IntWithInf -> Bool
forall a. Ord a => a -> a -> Bool
<= IntWithInf
0             = if DmdShell -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd DmdShell
body_dmd then IntWithInf
cg else IntWithInf
0
      | DmdShell -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isUsedOnce DmdShell
body_dmd = IntWithInf
cg
      | Bool
otherwise           = IntWithInf
infinity
      where
        cg :: IntWithInf
cg = Skeleton -> IntWithInf
go Skeleton
body