{-# 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.Types.Id
import GHC.Runtime.Heap.Layout ( WordOff )
import GHC.Stg.Lift.Config
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
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{}     = 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 Card
card Skeleton
body) = [SDoc] -> SDoc
hcat
    [ SDoc
lambda
    , Card -> SDoc
forall a. Outputable a => a -> SDoc
ppr Card
card
    , SDoc
dot
    , Skeleton -> SDoc
forall a. Outputable a => a -> SDoc
ppr Skeleton
body
    ]
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
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, Literal -> LlStgExpr
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
lit)
tagSkeletonExpr (StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [Type]
tys)
  = (Skeleton
NilSk, [StgArg] -> IdSet
mkArgOccs [StgArg]
args, DataCon -> ConstructorNumber -> [StgArg] -> [Type] -> LlStgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
con ConstructorNumber
mn [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
      
      
      | [StgArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args = Id -> IdSet
unitVarSet Id
f
      | Bool
otherwise = [StgArg] -> IdSet
mkArgOccs [StgArg]
args
tagSkeletonExpr (StgCase CgStgExpr
scrut BinderP 'CodeGen
bndr AltType
ty [GenStgAlt 'CodeGen]
alts)
  = (Skeleton
skel, IdSet
arg_occs, LlStgExpr
-> BinderP 'LiftLams
-> AltType
-> [GenStgAlt 'LiftLams]
-> LlStgExpr
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase LlStgExpr
scrut' BinderP 'LiftLams
BinderInfo
bndr' AltType
ty [GenStgAlt 'LiftLams]
alts')
  where
    (Skeleton
scrut_skel, IdSet
scrut_arg_occs, LlStgExpr
scrut') = CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
tagSkeletonExpr CgStgExpr
scrut
    ([Skeleton]
alt_skels, [IdSet]
alt_arg_occss, [GenStgAlt 'LiftLams]
alts') = (GenStgAlt 'CodeGen -> (Skeleton, IdSet, GenStgAlt 'LiftLams))
-> [GenStgAlt 'CodeGen]
-> ([Skeleton], [IdSet], [GenStgAlt 'LiftLams])
forall a b c d. (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
mapAndUnzip3 GenStgAlt 'CodeGen -> (Skeleton, IdSet, GenStgAlt 'LiftLams)
tagSkeletonAlt [GenStgAlt 'CodeGen]
alts
    skel :: Skeleton
skel = Skeleton -> Skeleton -> Skeleton
bothSk Skeleton
scrut_skel ((Skeleton -> Skeleton -> Skeleton)
-> Skeleton -> [Skeleton] -> Skeleton
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Skeleton -> Skeleton -> Skeleton
altSk Skeleton
NilSk [Skeleton]
alt_skels)
    arg_occs :: IdSet
arg_occs = [IdSet] -> IdSet
unionVarSets (IdSet
scrut_arg_occsIdSet -> [IdSet] -> [IdSet]
forall a. a -> [a] -> [a]
:[IdSet]
alt_arg_occss) IdSet -> Id -> IdSet
`delVarSet` Id
BinderP 'CodeGen
bndr
    bndr' :: BinderInfo
bndr' = Id -> BinderInfo
BoringBinder Id
BinderP 'CodeGen
bndr
tagSkeletonExpr (StgTick StgTickish
t CgStgExpr
e)
  = (Skeleton
skel, IdSet
arg_occs, StgTickish -> LlStgExpr -> LlStgExpr
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
t LlStgExpr
e')
  where
    (Skeleton
skel, IdSet
arg_occs, LlStgExpr
e') = CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
tagSkeletonExpr CgStgExpr
e
tagSkeletonExpr (StgLet XLet 'CodeGen
_ CgStgBinding
bind CgStgExpr
body) = Bool -> CgStgExpr -> CgStgBinding -> (Skeleton, IdSet, LlStgExpr)
tagSkeletonLet Bool
False CgStgExpr
body CgStgBinding
bind
tagSkeletonExpr (StgLetNoEscape XLetNoEscape 'CodeGen
_ CgStgBinding
bind CgStgExpr
body) = Bool -> CgStgExpr -> CgStgBinding -> (Skeleton, IdSet, LlStgExpr)
tagSkeletonLet Bool
True CgStgExpr
body CgStgBinding
bind
mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
mkLet Bool
True = XLetNoEscape 'LiftLams -> LlStgBinding -> LlStgExpr -> LlStgExpr
Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape
mkLet Bool
_    = XLet 'LiftLams -> LlStgBinding -> LlStgExpr -> LlStgExpr
Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
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 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 
      | 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
    
    
    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
    
    
    
    
    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
    
    
    
    
    scope :: Skeleton
scope = ((Skeleton, IdSet, LlStgRhs) -> Skeleton -> Skeleton)
-> Skeleton -> [(Skeleton, IdSet, LlStgRhs)] -> Skeleton
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Skeleton -> Skeleton -> Skeleton
bothSk (Skeleton -> Skeleton -> Skeleton)
-> ((Skeleton, IdSet, LlStgRhs) -> Skeleton)
-> (Skeleton, IdSet, LlStgRhs)
-> Skeleton
-> Skeleton
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Skeleton, IdSet, LlStgRhs) -> Skeleton
forall a b c. (a, b, c) -> a
fstOf3) Skeleton
body_skel [(Skeleton, IdSet, LlStgRhs)]
skel_occs_rhss'
    
    
    ([Skeleton]
bind_skels, [(BinderInfo, LlStgRhs)]
pairs') = [(Skeleton, (BinderInfo, LlStgRhs))]
-> ([Skeleton], [(BinderInfo, LlStgRhs)])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Id
 -> (Skeleton, IdSet, LlStgRhs)
 -> (Skeleton, (BinderInfo, LlStgRhs)))
-> [Id]
-> [(Skeleton, IdSet, LlStgRhs)]
-> [(Skeleton, (BinderInfo, LlStgRhs))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id
-> (Skeleton, IdSet, LlStgRhs)
-> (Skeleton, (BinderInfo, LlStgRhs))
single_bind [Id]
bndrs [(Skeleton, IdSet, LlStgRhs)]
skel_occs_rhss')
    let_skel :: Skeleton
let_skel = (Skeleton -> Skeleton -> Skeleton)
-> Skeleton -> [Skeleton] -> Skeleton
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Skeleton -> Skeleton -> Skeleton
bothSk Skeleton
body_skel [Skeleton]
bind_skels
    single_bind :: Id
-> (Skeleton, IdSet, LlStgRhs)
-> (Skeleton, (BinderInfo, LlStgRhs))
single_bind Id
bndr (Skeleton
skel_rhs, IdSet
_, LlStgRhs
rhs') = (Skeleton
bind_skel, (BinderInfo
bndr', LlStgRhs
rhs'))
      where
        
        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 = LlStgRhs -> DIdSet
forall (pass :: StgPass).
(XRhsClosure pass ~ DIdSet) =>
GenStgRhs pass -> DIdSet
freeVarsOfRhs LlStgRhs
rhs' DIdSet -> IdSet -> DIdSet
`dVarSetMinusVarSet` [Id] -> IdSet
mkVarSet [Id]
bndrs
        bndr' :: BinderInfo
bndr' = Id -> Bool -> BinderInfo
BindsClosure Id
bndr (Id
bndr Id -> IdSet -> Bool
`elemVarSet` IdSet
scope_occs)
tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
tagSkeletonRhs :: Id -> GenStgRhs 'CodeGen -> (Skeleton, IdSet, LlStgRhs)
tagSkeletonRhs Id
_ (StgRhsCon CostCentreStack
ccs DataCon
dc ConstructorNumber
mn [StgTickish]
ts [StgArg]
args)
  = (Skeleton
NilSk, [StgArg] -> IdSet
mkArgOccs [StgArg]
args, CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> LlStgRhs
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, XRhsClosure 'LiftLams
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'LiftLams]
-> LlStgExpr
-> LlStgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'LiftLams
XRhsClosure 'CodeGen
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 = 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 = (Card, SubDemand) -> Card
forall a b. (a, b) -> a
fst (Int -> SubDemand -> (Card, SubDemand)
peelManyCalls (Id -> Int
idArity Id
bndr) SubDemand
cd)
  where
    is_thunk :: Bool
is_thunk = Id -> Int
idArity Id
bndr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    
    Card
n :* SubDemand
cd = Id -> Demand
idDemandInfo Id
bndr
tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)
tagSkeletonAlt :: GenStgAlt 'CodeGen -> (Skeleton, IdSet, GenStgAlt 'LiftLams)
tagSkeletonAlt old :: GenStgAlt 'CodeGen
old@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
_, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'CodeGen]
bndrs, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=CgStgExpr
rhs}
  = (Skeleton
alt_skel, IdSet
arg_occs, GenStgAlt 'CodeGen
old {alt_bndrs :: [BinderP 'LiftLams]
alt_bndrs=(Id -> BinderInfo) -> [Id] -> [BinderInfo]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> BinderInfo
BoringBinder [Id]
[BinderP 'CodeGen]
bndrs, alt_rhs :: LlStgExpr
alt_rhs=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
goodToLift
  :: StgLiftConfig
  -> TopLevelFlag
  -> RecFlag
  -> (DIdSet -> DIdSet) 
                        
  -> [(BinderInfo, LlStgRhs)]
  -> Skeleton
  -> Maybe DIdSet       
                        
                        
goodToLift :: StgLiftConfig
-> TopLevelFlag
-> RecFlag
-> (DIdSet -> DIdSet)
-> [(BinderInfo, LlStgRhs)]
-> Skeleton
-> Maybe DIdSet
goodToLift StgLiftConfig
cfg TopLevelFlag
top_lvl RecFlag
rec_flag DIdSet -> DIdSet
expander [(BinderInfo, LlStgRhs)]
pairs Skeleton
scope = [(String, Bool)] -> Maybe DIdSet
decide
  [ (String
"top-level", TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl) 
  , (String
"memoized", Bool
any_memoized)
  , (String
"argument occurrences", Bool
arg_occs)
  , (String
"join point", Bool
is_join_point)
  , (String
"abstracts join points", Bool
abstracts_join_ids)
  , (String
"abstracts known local function", Bool
abstracts_known_local_fun)
  , (String
"args spill on stack", Bool
args_spill_on_stack)
  , (String
"increases allocation", Bool
inc_allocs)
  ] where
      profile :: Profile
profile  = StgLiftConfig -> Profile
c_targetProfile StgLiftConfig
cfg
      platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
      decide :: [(String, Bool)] -> Maybe DIdSet
decide [(String, Bool)]
deciders
        | Bool -> Bool
not ([(String, Bool)] -> Bool
fancy_or [(String, Bool)]
deciders)
        = String -> SDoc -> Maybe DIdSet -> Maybe DIdSet
forall a. String -> SDoc -> a -> a
llTrace String
"stgLiftLams:lifting"
                  ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bndrs SDoc -> SDoc -> SDoc
<+> 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
      
      
      
      
      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)
      
      
      
      
      
      
      
      
      abs_ids :: DIdSet
abs_ids = DIdSet -> DIdSet
expander (DIdSet -> [Id] -> DIdSet
delDVarSetList DIdSet
fvs [Id]
bndrs)
      
      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
      
      
      
      
      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)
      
      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
      
      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)
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      known_fun :: Id -> Bool
known_fun Id
id = Id -> Int
idArity Id
id Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      abstracts_known_local_fun :: Bool
abstracts_known_local_fun
        = Bool -> Bool
not (StgLiftConfig -> Bool
c_liftLamsKnown StgLiftConfig
cfg) Bool -> Bool -> Bool
&& (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
known_fun (DIdSet -> [Id]
dVarSetElems DIdSet
abs_ids)
      
      
      n_args :: LlStgRhs -> Int
n_args
        = [NonVoid Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
        ([NonVoid Id] -> Int)
-> (LlStgRhs -> [NonVoid Id]) -> LlStgRhs -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Id] -> [NonVoid Id]
StgToCmm.Closure.nonVoidIds 
        ([Id] -> [NonVoid Id])
-> (LlStgRhs -> [Id]) -> LlStgRhs -> [NonVoid Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DIdSet -> [Id]
dVarSetElems DIdSet
abs_ids [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++)
        ([Id] -> [Id]) -> (LlStgRhs -> [Id]) -> LlStgRhs -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlStgRhs -> [Id]
rhsLambdaBndrs
      max_n_args :: Maybe Int
max_n_args
        | RecFlag -> Bool
isRec RecFlag
rec_flag = StgLiftConfig -> Maybe Int
c_liftLamsRecArgs StgLiftConfig
cfg
        | Bool
otherwise      = StgLiftConfig -> Maybe Int
c_liftLamsNonRecArgs StgLiftConfig
cfg
      
      
      args_spill_on_stack :: Bool
args_spill_on_stack
        | Just Int
n <- Maybe Int
max_n_args = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((LlStgRhs -> Int) -> [LlStgRhs] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map LlStgRhs -> Int
n_args [LlStgRhs]
rhss) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n
        | Bool
otherwise = Bool
False
      
      
      
      
      
      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)
      
      
      
      closuresSize :: Int
closuresSize = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((LlStgRhs -> Int) -> [LlStgRhs] -> [Int])
-> [LlStgRhs] -> (LlStgRhs -> Int) -> [Int]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (LlStgRhs -> Int) -> [LlStgRhs] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [LlStgRhs]
rhss ((LlStgRhs -> Int) -> [Int]) -> (LlStgRhs -> Int) -> [Int]
forall a b. (a -> b) -> a -> b
$ \LlStgRhs
rhs ->
        Profile -> [Id] -> Int
closureSize Profile
profile
        ([Id] -> Int) -> (DIdSet -> [Id]) -> DIdSet -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIdSet -> [Id]
dVarSetElems
        (DIdSet -> [Id]) -> (DIdSet -> DIdSet) -> DIdSet -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIdSet -> DIdSet
expander
        (DIdSet -> DIdSet) -> (DIdSet -> DIdSet) -> DIdSet -> DIdSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DIdSet -> IdSet -> DIdSet) -> IdSet -> DIdSet -> DIdSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip DIdSet -> IdSet -> DIdSet
dVarSetMinusVarSet IdSet
bndrs_set
        (DIdSet -> Int) -> DIdSet -> Int
forall a b. (a -> b) -> a -> b
$ LlStgRhs -> DIdSet
forall (pass :: StgPass).
(XRhsClosure pass ~ DIdSet) =>
GenStgRhs pass -> DIdSet
freeVarsOfRhs LlStgRhs
rhs
      clo_growth :: IntWithInf
clo_growth = (DIdSet -> DIdSet)
-> (Id -> Int) -> IdSet -> DIdSet -> Skeleton -> IntWithInf
closureGrowth DIdSet -> DIdSet
expander (Platform -> Id -> Int
idClosureFootprint Platform
platform) IdSet
bndrs_set DIdSet
abs_ids Skeleton
scope
rhsLambdaBndrs :: LlStgRhs -> [Id]
rhsLambdaBndrs :: LlStgRhs -> [Id]
rhsLambdaBndrs StgRhsCon{} = []
rhsLambdaBndrs (StgRhsClosure XRhsClosure 'LiftLams
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'LiftLams]
bndrs LlStgExpr
_) = (BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderP 'LiftLams]
[BinderInfo]
bndrs
closureSize :: Profile -> [Id] -> WordOff
closureSize :: Profile -> [Id] -> Int
closureSize Profile
profile [Id]
ids = Int
words Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PlatformConstants -> Int
pc_STD_HDR_SIZE (Platform -> PlatformConstants
platformConstants (Profile -> Platform
profilePlatform Profile
profile))
  
  
  where
    (Int
words, Int
_, [(NonVoid Id, Int)]
_)
      
      = Profile
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (Int, Int, [(NonVoid Id, Int)])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
StgToCmm.Layout.mkVirtHeapOffsets Profile
profile ClosureHeader
StgToCmm.Layout.StdHeader
      ([NonVoid (PrimRep, Id)] -> (Int, Int, [(NonVoid Id, Int)]))
-> ([Id] -> [NonVoid (PrimRep, Id)])
-> [Id]
-> (Int, Int, [(NonVoid Id, Int)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NonVoid Id] -> [NonVoid (PrimRep, Id)]
StgToCmm.Closure.addIdReps
      ([NonVoid Id] -> [NonVoid (PrimRep, Id)])
-> ([Id] -> [NonVoid Id]) -> [Id] -> [NonVoid (PrimRep, Id)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Id] -> [NonVoid Id]
StgToCmm.Closure.nonVoidIds
      ([Id] -> (Int, Int, [(NonVoid Id, Int)]))
-> [Id] -> (Int, Int, [(NonVoid Id, Int)])
forall a b. (a -> b) -> a -> b
$ [Id]
ids
idClosureFootprint:: Platform -> Id -> WordOff
 Platform
platform
  = Platform -> ArgRep -> Int
StgToCmm.ArgRep.argRepSizeW Platform
platform
  (ArgRep -> Int) -> (Id -> ArgRep) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> ArgRep
StgToCmm.ArgRep.idArgRep Platform
platform
closureGrowth
  :: (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 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)
      
      
      | Int
n_occs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = IntWithInf
0
      
      
      | 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)
        
        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 = (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
        
    go (RhsSk Card
n Skeleton
body)
      
      
      
      
      
      
      
      
      
      
      
      
      | Card -> Bool
isAbs Card
n      = IntWithInf
0
      | IntWithInf
cg IntWithInf -> IntWithInf -> Bool
forall a. Ord a => a -> a -> Bool
<= IntWithInf
0      = if Card -> Bool
isStrict Card
n then IntWithInf
cg else IntWithInf
0
      | Card -> Bool
isUsedOnce Card
n = IntWithInf
cg
      | Bool
otherwise    = IntWithInf
infinity
      where
        cg :: IntWithInf
cg = Skeleton -> IntWithInf
go Skeleton
body