{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
module GHC.Stg.Lift.Analysis (
Skeleton(..), BinderInfo(..), binderInfoBndr,
LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,
goodToLift,
closureGrowth
) 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 )
llTrace :: String -> SDoc -> a -> a
llTrace :: forall a. String -> SDoc -> a -> a
llTrace String
_ SDoc
_ a
c = a
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
data Skeleton
= ClosureSk !Id !DIdSet !Skeleton
| RhsSk !Card !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
data BinderInfo
= BindsClosure !Id !Bool
| BoringBinder !Id
binderInfoBndr :: BinderInfo -> Id
binderInfoBndr :: BinderInfo -> Id
binderInfoBndr (BoringBinder Id
bndr) = Id
bndr
binderInfoBndr (BindsClosure Id
bndr Bool
_) = Id
bndr
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
tagSkeletonTopBind :: CgStgBinding -> LlStgBinding
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
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
| 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
-> CgStgExpr
-> CgStgBinding
-> (Skeleton, IdSet, LlStgExpr)
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
-> Skeleton
-> IdSet
-> CgStgBinding
-> (Skeleton, IdSet, Skeleton, LlStgBinding)
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
| 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
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
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
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'
([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
bind_skel :: Skeleton
bind_skel
| Bool
is_lne = Skeleton
skel_rhs
| 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
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
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
goodToLift
:: DynFlags
-> TopLevelFlag
-> RecFlag
-> (DIdSet -> DIdSet)
-> [(BinderInfo, LlStgRhs)]
-> Skeleton
-> Maybe DIdSet
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)
, (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
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)
abs_ids :: DIdSet
abs_ids = DIdSet -> DIdSet
expander (DIdSet -> [Id] -> DIdSet
delDVarSetList DIdSet
fvs [Id]
bndrs)
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
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)
is_join_point :: Bool
is_join_point = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isJoinId [Id]
bndrs
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)
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)
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
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
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
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)
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
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))
where
(Int
words, Int
_, [(NonVoid Id, Int)]
_)
= forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
StgToCmm.Layout.mkVirtHeapOffsets Profile
profile ClosureHeader
StgToCmm.Layout.StdHeader
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
idClosureFootprint:: Platform -> Id -> WordOff
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
:: (DIdSet -> DIdSet)
-> (Id -> Int)
-> IdSet
-> DIdSet
-> Skeleton
-> IntWithInf
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)
| Int
n_occs forall a. Eq a => a -> a -> Bool
== Int
0 = IntWithInf
0
| 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)
clo_fvs' :: DIdSet
clo_fvs' = DIdSet -> DIdSet
expander DIdSet
clo_fvs
newbies :: DIdSet
newbies = DIdSet
abs_ids DIdSet -> DIdSet -> DIdSet
`minusDVarSet` DIdSet
clo_fvs'
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
go (RhsSk Card
n Skeleton
body)
| 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