{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Core.Opt.OccurAnal (
occurAnalysePgm,
occurAnalyseExpr,
zapLambdaBndrs, scrutBinderSwap_maybe
) where
import GHC.Prelude hiding ( head, init, last, tail )
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp,
mkCastMCo, mkTicks )
import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr )
import GHC.Core.Coercion
import GHC.Core.Predicate ( isDictId )
import GHC.Core.Type
import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo )
import GHC.Data.Maybe( isJust, orElse )
import GHC.Data.Graph.Directed ( SCC(..), Node(..)
, stronglyConnCompFromEdgedVerticesUniq
, stronglyConnCompFromEdgedVerticesUniqR )
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Basic
import GHC.Types.Tickish
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Var
import GHC.Types.Demand ( argOneShots, argsOneShots )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
import Data.List (mapAccumL, mapAccumR)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
occurAnalyseExpr :: CoreExpr -> CoreExpr
occurAnalyseExpr :: CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
expr = CoreExpr
expr'
where
(WithUsageDetails UsageDetails
_ CoreExpr
expr') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
initOccEnv CoreExpr
expr
occurAnalysePgm :: Module
-> (Id -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram -> CoreProgram
occurAnalysePgm :: Module
-> (CoreBndr -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm Module
this_mod CoreBndr -> Bool
active_unf Activation -> Bool
active_rule [CoreRule]
imp_rules CoreProgram
binds
| UsageDetails -> Bool
isEmptyDetails UsageDetails
final_usage
= CoreProgram
occ_anald_binds
| Bool
otherwise
= Bool -> String -> SDoc -> CoreProgram -> CoreProgram
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"Glomming in" (SDoc -> JoinArity -> SDoc -> SDoc
hang (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) JoinArity
2 (UsageDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr UsageDetails
final_usage))
CoreProgram
occ_anald_glommed_binds
where
init_env :: OccEnv
init_env = OccEnv
initOccEnv { occ_rule_act = active_rule
, occ_unf_act = active_unf }
(WithUsageDetails UsageDetails
final_usage CoreProgram
occ_anald_binds) = OccEnv -> CoreProgram -> WithUsageDetails CoreProgram
go OccEnv
init_env CoreProgram
binds
(WithUsageDetails UsageDetails
_ CoreProgram
occ_anald_glommed_binds) = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(CoreBndr, CoreExpr)]
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalRecBind OccEnv
init_env TopLevelFlag
TopLevel
ImpRuleEdges
imp_rule_edges
(CoreProgram -> [(CoreBndr, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds)
UsageDetails
initial_uds
initial_uds :: UsageDetails
initial_uds = UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
emptyDetails ([CoreRule] -> VarSet
rulesFreeVars [CoreRule]
imp_rules)
imp_rule_edges :: ImpRuleEdges
imp_rule_edges :: ImpRuleEdges
imp_rule_edges = (ImpRuleEdges -> ImpRuleEdges -> ImpRuleEdges)
-> ImpRuleEdges -> [ImpRuleEdges] -> ImpRuleEdges
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([(Activation, VarSet)]
-> [(Activation, VarSet)] -> [(Activation, VarSet)])
-> ImpRuleEdges -> ImpRuleEdges -> ImpRuleEdges
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C [(Activation, VarSet)]
-> [(Activation, VarSet)] -> [(Activation, VarSet)]
forall a. [a] -> [a] -> [a]
(++)) ImpRuleEdges
forall a. VarEnv a
emptyVarEnv
[ (CoreBndr -> [(Activation, VarSet)])
-> VarEnv CoreBndr -> ImpRuleEdges
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv ([(Activation, VarSet)] -> CoreBndr -> [(Activation, VarSet)]
forall a b. a -> b -> a
const [(Activation
act,VarSet
rhs_fvs)]) (VarEnv CoreBndr -> ImpRuleEdges)
-> VarEnv CoreBndr -> ImpRuleEdges
forall a b. (a -> b) -> a -> b
$ VarSet -> VarEnv CoreBndr
forall a. UniqSet a -> UniqFM a a
getUniqSet (VarSet -> VarEnv CoreBndr) -> VarSet -> VarEnv CoreBndr
forall a b. (a -> b) -> a -> b
$
[CoreExpr] -> VarSet
exprsFreeIds [CoreExpr]
args VarSet -> [CoreBndr] -> VarSet
`delVarSetList` [CoreBndr]
bndrs
| Rule { ru_act :: CoreRule -> Activation
ru_act = Activation
act, ru_bndrs :: CoreRule -> [CoreBndr]
ru_bndrs = [CoreBndr]
bndrs
, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs } <- [CoreRule]
imp_rules
, let rhs_fvs :: VarSet
rhs_fvs = CoreExpr -> VarSet
exprFreeIds CoreExpr
rhs VarSet -> [CoreBndr] -> VarSet
`delVarSetList` [CoreBndr]
bndrs ]
go :: OccEnv -> [CoreBind] -> WithUsageDetails [CoreBind]
go :: OccEnv -> CoreProgram -> WithUsageDetails CoreProgram
go !OccEnv
_ []
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
initial_uds []
go OccEnv
env (CoreBind
bind:CoreProgram
binds)
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
final_usage (CoreProgram
bind' CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ CoreProgram
binds')
where
(WithUsageDetails UsageDetails
bs_usage CoreProgram
binds') = OccEnv -> CoreProgram -> WithUsageDetails CoreProgram
go OccEnv
env CoreProgram
binds
(WithUsageDetails UsageDetails
final_usage CoreProgram
bind') = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalBind OccEnv
env TopLevelFlag
TopLevel ImpRuleEdges
imp_rule_edges CoreBind
bind UsageDetails
bs_usage
type ImpRuleEdges = IdEnv [(Activation, VarSet)]
noImpRuleEdges :: ImpRuleEdges
noImpRuleEdges :: ImpRuleEdges
noImpRuleEdges = ImpRuleEdges
forall a. VarEnv a
emptyVarEnv
lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]
lookupImpRules :: ImpRuleEdges -> CoreBndr -> [(Activation, VarSet)]
lookupImpRules ImpRuleEdges
imp_rule_edges CoreBndr
bndr
= case ImpRuleEdges -> CoreBndr -> Maybe [(Activation, VarSet)]
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv ImpRuleEdges
imp_rule_edges CoreBndr
bndr of
Maybe [(Activation, VarSet)]
Nothing -> []
Just [(Activation, VarSet)]
vs -> [(Activation, VarSet)]
vs
impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails
impRulesScopeUsage :: [(Activation, VarSet)] -> UsageDetails
impRulesScopeUsage [(Activation, VarSet)]
imp_rules_info
= ((Activation, VarSet) -> UsageDetails -> UsageDetails)
-> UsageDetails -> [(Activation, VarSet)] -> UsageDetails
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Activation, VarSet) -> UsageDetails -> UsageDetails
forall {a}. (a, VarSet) -> UsageDetails -> UsageDetails
add UsageDetails
emptyDetails [(Activation, VarSet)]
imp_rules_info
where
add :: (a, VarSet) -> UsageDetails -> UsageDetails
add (a
_,VarSet
vs) UsageDetails
usage = UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
usage VarSet
vs
impRulesActiveFvs :: (Activation -> Bool) -> VarSet
-> [(Activation,VarSet)] -> VarSet
impRulesActiveFvs :: (Activation -> Bool) -> VarSet -> [(Activation, VarSet)] -> VarSet
impRulesActiveFvs Activation -> Bool
is_active VarSet
bndr_set [(Activation, VarSet)]
vs
= ((Activation, VarSet) -> VarSet -> VarSet)
-> VarSet -> [(Activation, VarSet)] -> VarSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Activation, VarSet) -> VarSet -> VarSet
add VarSet
emptyVarSet [(Activation, VarSet)]
vs VarSet -> VarSet -> VarSet
`intersectVarSet` VarSet
bndr_set
where
add :: (Activation, VarSet) -> VarSet -> VarSet
add (Activation
act,VarSet
vs) VarSet
acc | Activation -> Bool
is_active Activation
act = VarSet
vs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
acc
| Bool
otherwise = VarSet
acc
data WithUsageDetails a = WithUsageDetails !UsageDetails !a
data WithTailUsageDetails a = WithTailUsageDetails !TailUsageDetails !a
occAnalBind :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> UsageDetails
-> WithUsageDetails [CoreBind]
occAnalBind :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalBind !OccEnv
env TopLevelFlag
lvl ImpRuleEdges
top_env (NonRec CoreBndr
binder CoreExpr
rhs) UsageDetails
body_usage
= OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBndr
-> CoreExpr
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalNonRecBind OccEnv
env TopLevelFlag
lvl ImpRuleEdges
top_env CoreBndr
binder CoreExpr
rhs UsageDetails
body_usage
occAnalBind OccEnv
env TopLevelFlag
lvl ImpRuleEdges
top_env (Rec [(CoreBndr, CoreExpr)]
pairs) UsageDetails
body_usage
= OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(CoreBndr, CoreExpr)]
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalRecBind OccEnv
env TopLevelFlag
lvl ImpRuleEdges
top_env [(CoreBndr, CoreExpr)]
pairs UsageDetails
body_usage
occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr
-> UsageDetails -> WithUsageDetails [CoreBind]
occAnalNonRecBind :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBndr
-> CoreExpr
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalNonRecBind !OccEnv
env TopLevelFlag
lvl ImpRuleEdges
imp_rule_edges CoreBndr
bndr CoreExpr
rhs UsageDetails
body_usage
| CoreBndr -> Bool
isTyVar CoreBndr
bndr
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
body_usage [CoreBndr -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
bndr CoreExpr
rhs]
| Bool -> Bool
not (CoreBndr
bndr CoreBndr -> UsageDetails -> Bool
`usedIn` UsageDetails
body_usage)
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
body_usage []
| Bool
otherwise
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails (UsageDetails
body_usage' UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
rhs_usage) [CoreBndr -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
final_bndr CoreExpr
final_rhs]
where
WithUsageDetails UsageDetails
body_usage' CoreBndr
tagged_bndr = TopLevelFlag
-> UsageDetails -> CoreBndr -> WithUsageDetails CoreBndr
tagNonRecBinder TopLevelFlag
lvl UsageDetails
body_usage CoreBndr
bndr
mb_join_arity :: Maybe JoinArity
mb_join_arity = CoreBndr -> Maybe JoinArity
willBeJoinId_maybe CoreBndr
tagged_bndr
is_join_point :: Bool
is_join_point = Maybe JoinArity -> Bool
forall a. Maybe a -> Bool
isJust Maybe JoinArity
mb_join_arity
env1 :: OccEnv
env1 | Bool
is_join_point = OccEnv
env
| Bool
certainly_inline = OccEnv
env
| Bool
otherwise = OccEnv -> OccEnv
rhsCtxt OccEnv
env
rhs_env :: OccEnv
rhs_env = OccEnv
env1 { occ_one_shots = argOneShots dmd }
WithUsageDetails UsageDetails
adj_rhs_uds CoreExpr
final_rhs
= Maybe JoinArity
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs Maybe JoinArity
mb_join_arity (WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr)
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
forall a b. (a -> b) -> a -> b
$ OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
rhs_env CoreExpr
rhs
rhs_usage :: UsageDetails
rhs_usage = UsageDetails
adj_rhs_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
adj_unf_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
adj_rule_uds
final_bndr :: CoreBndr
final_bndr = CoreBndr
tagged_bndr CoreBndr -> RuleInfo -> CoreBndr
`setIdSpecialisation` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule]
rules'
CoreBndr -> Unfolding -> CoreBndr
`setIdUnfolding` Unfolding
unf2
unf :: Unfolding
unf | CoreBndr -> Bool
isId CoreBndr
bndr = IdUnfoldingFun
idUnfolding CoreBndr
bndr
| Bool
otherwise = Unfolding
NoUnfolding
WithTailUsageDetails TailUsageDetails
unf_uds Unfolding
unf1 = OccEnv -> Unfolding -> WithTailUsageDetails Unfolding
occAnalUnfolding OccEnv
rhs_env Unfolding
unf
unf2 :: Unfolding
unf2 = Maybe JoinArity -> Unfolding -> Unfolding
markNonRecUnfoldingOneShots Maybe JoinArity
mb_join_arity Unfolding
unf1
adj_unf_uds :: UsageDetails
adj_unf_uds = Maybe JoinArity -> TailUsageDetails -> UsageDetails
adjustTailArity Maybe JoinArity
mb_join_arity TailUsageDetails
unf_uds
rules_w_uds :: [(CoreRule, UsageDetails, TailUsageDetails)]
rules_w_uds = OccEnv -> CoreBndr -> [(CoreRule, UsageDetails, TailUsageDetails)]
occAnalRules OccEnv
rhs_env CoreBndr
bndr
rules' :: [CoreRule]
rules' = ((CoreRule, UsageDetails, TailUsageDetails) -> CoreRule)
-> [(CoreRule, UsageDetails, TailUsageDetails)] -> [CoreRule]
forall a b. (a -> b) -> [a] -> [b]
map (CoreRule, UsageDetails, TailUsageDetails) -> CoreRule
forall a b c. (a, b, c) -> a
fstOf3 [(CoreRule, UsageDetails, TailUsageDetails)]
rules_w_uds
imp_rule_uds :: UsageDetails
imp_rule_uds = [(Activation, VarSet)] -> UsageDetails
impRulesScopeUsage (ImpRuleEdges -> CoreBndr -> [(Activation, VarSet)]
lookupImpRules ImpRuleEdges
imp_rule_edges CoreBndr
bndr)
adj_rule_uds :: UsageDetails
adj_rule_uds = ((CoreRule, UsageDetails, TailUsageDetails)
-> UsageDetails -> UsageDetails)
-> UsageDetails
-> [(CoreRule, UsageDetails, TailUsageDetails)]
-> UsageDetails
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreRule, UsageDetails, TailUsageDetails)
-> UsageDetails -> UsageDetails
add_rule_uds UsageDetails
imp_rule_uds [(CoreRule, UsageDetails, TailUsageDetails)]
rules_w_uds
add_rule_uds :: (CoreRule, UsageDetails, TailUsageDetails)
-> UsageDetails -> UsageDetails
add_rule_uds (CoreRule
_, UsageDetails
l, TailUsageDetails
r) UsageDetails
uds
= UsageDetails
l UsageDetails -> UsageDetails -> UsageDetails
`andUDs` Maybe JoinArity -> TailUsageDetails -> UsageDetails
adjustTailArity Maybe JoinArity
mb_join_arity TailUsageDetails
r UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
uds
occ :: OccInfo
occ = CoreBndr -> OccInfo
idOccInfo CoreBndr
tagged_bndr
certainly_inline :: Bool
certainly_inline
= case OccInfo
occ of
OneOcc { occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
NotInsideLam, occ_n_br :: OccInfo -> JoinArity
occ_n_br = JoinArity
1 }
-> Bool
active Bool -> Bool -> Bool
&& Bool
not_stable
OccInfo
_ -> Bool
False
dmd :: Demand
dmd = CoreBndr -> Demand
idDemandInfo CoreBndr
bndr
active :: Bool
active = Activation -> Bool
isAlwaysActive (CoreBndr -> Activation
idInlineActivation CoreBndr
bndr)
not_stable :: Bool
not_stable = Bool -> Bool
not (Unfolding -> Bool
isStableUnfolding (IdUnfoldingFun
idUnfolding CoreBndr
bndr))
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
-> UsageDetails -> WithUsageDetails [CoreBind]
occAnalRecBind :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(CoreBndr, CoreExpr)]
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalRecBind !OccEnv
env TopLevelFlag
lvl ImpRuleEdges
imp_rule_edges [(CoreBndr, CoreExpr)]
pairs UsageDetails
body_usage
= (SCC NodeDetails
-> WithUsageDetails CoreProgram -> WithUsageDetails CoreProgram)
-> WithUsageDetails CoreProgram
-> [SCC NodeDetails]
-> WithUsageDetails CoreProgram
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (OccEnv
-> TopLevelFlag
-> SCC NodeDetails
-> WithUsageDetails CoreProgram
-> WithUsageDetails CoreProgram
occAnalRec OccEnv
rhs_env TopLevelFlag
lvl) (UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
body_usage []) [SCC NodeDetails]
sccs
where
sccs :: [SCC NodeDetails]
sccs :: [SCC NodeDetails]
sccs = {-# SCC "occAnalBind.scc" #-}
[Node Unique NodeDetails] -> [SCC NodeDetails]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Unique NodeDetails]
nodes
nodes :: [LetrecNode]
nodes :: [Node Unique NodeDetails]
nodes = {-# SCC "occAnalBind.assoc" #-}
((CoreBndr, CoreExpr) -> Node Unique NodeDetails)
-> [(CoreBndr, CoreExpr)] -> [Node Unique NodeDetails]
forall a b. (a -> b) -> [a] -> [b]
map (OccEnv
-> ImpRuleEdges
-> VarSet
-> (CoreBndr, CoreExpr)
-> Node Unique NodeDetails
makeNode OccEnv
rhs_env ImpRuleEdges
imp_rule_edges VarSet
bndr_set) [(CoreBndr, CoreExpr)]
pairs
bndrs :: [CoreBndr]
bndrs = ((CoreBndr, CoreExpr) -> CoreBndr)
-> [(CoreBndr, CoreExpr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, CoreExpr)]
pairs
bndr_set :: VarSet
bndr_set = [CoreBndr] -> VarSet
mkVarSet [CoreBndr]
bndrs
rhs_env :: OccEnv
rhs_env = OccEnv
env OccEnv -> [CoreBndr] -> OccEnv
`addInScope` [CoreBndr]
bndrs
adjustNonRecRhs :: Maybe JoinArity -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs :: Maybe JoinArity
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs Maybe JoinArity
mb_join_arity (WithTailUsageDetails TailUsageDetails
rhs_tuds CoreExpr
rhs)
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
rhs_uds' CoreExpr
rhs'
where
!rhs' :: CoreExpr
rhs' | Just JoinArity
ja <- Maybe JoinArity
mb_join_arity = JoinArity -> CoreExpr -> CoreExpr
markNonRecJoinOneShots JoinArity
ja CoreExpr
rhs
| Bool
otherwise = CoreExpr
rhs
rhs_uds' :: UsageDetails
rhs_uds' = Maybe JoinArity -> CoreExpr -> TailUsageDetails -> UsageDetails
adjustTailUsage Maybe JoinArity
mb_join_arity CoreExpr
rhs' TailUsageDetails
rhs_tuds
bindersOfSCC :: SCC NodeDetails -> [Var]
bindersOfSCC :: SCC NodeDetails -> [CoreBndr]
bindersOfSCC (AcyclicSCC NodeDetails
nd) = [NodeDetails -> CoreBndr
nd_bndr NodeDetails
nd]
bindersOfSCC (CyclicSCC [NodeDetails]
ds) = (NodeDetails -> CoreBndr) -> [NodeDetails] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map NodeDetails -> CoreBndr
nd_bndr [NodeDetails]
ds
occAnalRec :: OccEnv -> TopLevelFlag
-> SCC NodeDetails
-> WithUsageDetails [CoreBind]
-> WithUsageDetails [CoreBind]
occAnalRec :: OccEnv
-> TopLevelFlag
-> SCC NodeDetails
-> WithUsageDetails CoreProgram
-> WithUsageDetails CoreProgram
occAnalRec !OccEnv
_ TopLevelFlag
_ SCC NodeDetails
scc (WithUsageDetails UsageDetails
body_uds CoreProgram
binds)
| Bool -> Bool
not ((CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CoreBndr -> UsageDetails -> Bool
`usedIn` UsageDetails
body_uds) (SCC NodeDetails -> [CoreBndr]
bindersOfSCC SCC NodeDetails
scc))
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
body_uds CoreProgram
binds
occAnalRec !OccEnv
_ TopLevelFlag
lvl
(AcyclicSCC (ND { nd_bndr :: NodeDetails -> CoreBndr
nd_bndr = CoreBndr
bndr, nd_rhs :: NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs = WithTailUsageDetails CoreExpr
wtuds }))
(WithUsageDetails UsageDetails
body_uds CoreProgram
binds)
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails (UsageDetails
body_uds' UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
rhs_uds') (CoreBndr -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
bndr' CoreExpr
rhs' CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
binds)
where
WithUsageDetails UsageDetails
body_uds' CoreBndr
tagged_bndr = TopLevelFlag
-> UsageDetails -> CoreBndr -> WithUsageDetails CoreBndr
tagNonRecBinder TopLevelFlag
lvl UsageDetails
body_uds CoreBndr
bndr
mb_join_arity :: Maybe JoinArity
mb_join_arity = CoreBndr -> Maybe JoinArity
willBeJoinId_maybe CoreBndr
tagged_bndr
WithUsageDetails UsageDetails
rhs_uds' CoreExpr
rhs' = Maybe JoinArity
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs Maybe JoinArity
mb_join_arity WithTailUsageDetails CoreExpr
wtuds
!unf' :: Unfolding
unf' = Maybe JoinArity -> Unfolding -> Unfolding
markNonRecUnfoldingOneShots Maybe JoinArity
mb_join_arity (IdUnfoldingFun
idUnfolding CoreBndr
tagged_bndr)
!bndr' :: CoreBndr
bndr' = CoreBndr
tagged_bndr CoreBndr -> Unfolding -> CoreBndr
`setIdUnfolding` Unfolding
unf'
occAnalRec OccEnv
env TopLevelFlag
lvl (CyclicSCC [NodeDetails]
details_s) (WithUsageDetails UsageDetails
body_uds CoreProgram
binds)
=
UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
final_uds ([(CoreBndr, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, CoreExpr)]
pairs CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
binds)
where
all_simple :: Bool
all_simple = (NodeDetails -> Bool) -> [NodeDetails] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NodeDetails -> Bool
nd_simple [NodeDetails]
details_s
final_uds :: UsageDetails
loop_breaker_nodes :: [LoopBreakerNode]
(WithUsageDetails UsageDetails
final_uds [LoopBreakerNode]
loop_breaker_nodes) = OccEnv
-> TopLevelFlag
-> UsageDetails
-> [NodeDetails]
-> WithUsageDetails [LoopBreakerNode]
mkLoopBreakerNodes OccEnv
env TopLevelFlag
lvl UsageDetails
body_uds [NodeDetails]
details_s
weak_fvs :: VarSet
weak_fvs :: VarSet
weak_fvs = (NodeDetails -> VarSet) -> [NodeDetails] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet NodeDetails -> VarSet
nd_weak_fvs [NodeDetails]
details_s
pairs :: [(Id,CoreExpr)]
pairs :: [(CoreBndr, CoreExpr)]
pairs | Bool
all_simple = JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(CoreBndr, CoreExpr)]
-> [(CoreBndr, CoreExpr)]
reOrderNodes JoinArity
0 VarSet
weak_fvs [LoopBreakerNode]
loop_breaker_nodes []
| Bool
otherwise = JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(CoreBndr, CoreExpr)]
-> [(CoreBndr, CoreExpr)]
loopBreakNodes JoinArity
0 VarSet
weak_fvs [LoopBreakerNode]
loop_breaker_nodes []
type Binding = (Id,CoreExpr)
loopBreakNodes :: Int
-> VarSet
-> [LoopBreakerNode]
-> [Binding]
-> [Binding]
loopBreakNodes :: JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(CoreBndr, CoreExpr)]
-> [(CoreBndr, CoreExpr)]
loopBreakNodes JoinArity
depth VarSet
weak_fvs [LoopBreakerNode]
nodes [(CoreBndr, CoreExpr)]
binds
=
[SCC LoopBreakerNode] -> [(CoreBndr, CoreExpr)]
go ([LoopBreakerNode] -> [SCC LoopBreakerNode]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR [LoopBreakerNode]
nodes)
where
go :: [SCC LoopBreakerNode] -> [(CoreBndr, CoreExpr)]
go [] = [(CoreBndr, CoreExpr)]
binds
go (SCC LoopBreakerNode
scc:[SCC LoopBreakerNode]
sccs) = SCC LoopBreakerNode
-> [(CoreBndr, CoreExpr)] -> [(CoreBndr, CoreExpr)]
loop_break_scc SCC LoopBreakerNode
scc ([SCC LoopBreakerNode] -> [(CoreBndr, CoreExpr)]
go [SCC LoopBreakerNode]
sccs)
loop_break_scc :: SCC LoopBreakerNode
-> [(CoreBndr, CoreExpr)] -> [(CoreBndr, CoreExpr)]
loop_break_scc SCC LoopBreakerNode
scc [(CoreBndr, CoreExpr)]
binds
= case SCC LoopBreakerNode
scc of
AcyclicSCC LoopBreakerNode
node -> (CoreBndr -> CoreBndr) -> LoopBreakerNode -> (CoreBndr, CoreExpr)
nodeBinding (VarSet -> CoreBndr -> CoreBndr
mk_non_loop_breaker VarSet
weak_fvs) LoopBreakerNode
node (CoreBndr, CoreExpr)
-> [(CoreBndr, CoreExpr)] -> [(CoreBndr, CoreExpr)]
forall a. a -> [a] -> [a]
: [(CoreBndr, CoreExpr)]
binds
CyclicSCC [LoopBreakerNode]
nodes -> JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(CoreBndr, CoreExpr)]
-> [(CoreBndr, CoreExpr)]
reOrderNodes JoinArity
depth VarSet
weak_fvs [LoopBreakerNode]
nodes [(CoreBndr, CoreExpr)]
binds
reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding]
reOrderNodes :: JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(CoreBndr, CoreExpr)]
-> [(CoreBndr, CoreExpr)]
reOrderNodes JoinArity
_ VarSet
_ [] [(CoreBndr, CoreExpr)]
_ = String -> [(CoreBndr, CoreExpr)]
forall a. HasCallStack => String -> a
panic String
"reOrderNodes"
reOrderNodes JoinArity
_ VarSet
_ [LoopBreakerNode
node] [(CoreBndr, CoreExpr)]
binds = (CoreBndr -> CoreBndr) -> LoopBreakerNode -> (CoreBndr, CoreExpr)
nodeBinding CoreBndr -> CoreBndr
mk_loop_breaker LoopBreakerNode
node (CoreBndr, CoreExpr)
-> [(CoreBndr, CoreExpr)] -> [(CoreBndr, CoreExpr)]
forall a. a -> [a] -> [a]
: [(CoreBndr, CoreExpr)]
binds
reOrderNodes JoinArity
depth VarSet
weak_fvs (LoopBreakerNode
node : [LoopBreakerNode]
nodes) [(CoreBndr, CoreExpr)]
binds
=
JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(CoreBndr, CoreExpr)]
-> [(CoreBndr, CoreExpr)]
loopBreakNodes JoinArity
new_depth VarSet
weak_fvs [LoopBreakerNode]
unchosen ([(CoreBndr, CoreExpr)] -> [(CoreBndr, CoreExpr)])
-> [(CoreBndr, CoreExpr)] -> [(CoreBndr, CoreExpr)]
forall a b. (a -> b) -> a -> b
$
((LoopBreakerNode -> (CoreBndr, CoreExpr))
-> [LoopBreakerNode] -> [(CoreBndr, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreBndr -> CoreBndr) -> LoopBreakerNode -> (CoreBndr, CoreExpr)
nodeBinding CoreBndr -> CoreBndr
mk_loop_breaker) [LoopBreakerNode]
chosen_nodes [(CoreBndr, CoreExpr)]
-> [(CoreBndr, CoreExpr)] -> [(CoreBndr, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(CoreBndr, CoreExpr)]
binds)
where
([LoopBreakerNode]
chosen_nodes, [LoopBreakerNode]
unchosen) = Bool
-> NodeScore
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> ([LoopBreakerNode], [LoopBreakerNode])
chooseLoopBreaker Bool
approximate_lb
(SimpleNodeDetails -> NodeScore
snd_score (LoopBreakerNode -> SimpleNodeDetails
forall key payload. Node key payload -> payload
node_payload LoopBreakerNode
node))
[LoopBreakerNode
node] [] [LoopBreakerNode]
nodes
approximate_lb :: Bool
approximate_lb = JoinArity
depth JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
>= JoinArity
2
new_depth :: JoinArity
new_depth | Bool
approximate_lb = JoinArity
0
| Bool
otherwise = JoinArity
depthJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+JoinArity
1
nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding
nodeBinding :: (CoreBndr -> CoreBndr) -> LoopBreakerNode -> (CoreBndr, CoreExpr)
nodeBinding CoreBndr -> CoreBndr
set_id_occ (LoopBreakerNode -> SimpleNodeDetails
forall key payload. Node key payload -> payload
node_payload -> SND { snd_bndr :: SimpleNodeDetails -> CoreBndr
snd_bndr = CoreBndr
bndr, snd_rhs :: SimpleNodeDetails -> CoreExpr
snd_rhs = CoreExpr
rhs})
= (CoreBndr -> CoreBndr
set_id_occ CoreBndr
bndr, CoreExpr
rhs)
mk_loop_breaker :: Id -> Id
mk_loop_breaker :: CoreBndr -> CoreBndr
mk_loop_breaker CoreBndr
bndr
= CoreBndr
bndr CoreBndr -> OccInfo -> CoreBndr
`setIdOccInfo` OccInfo
occ'
where
occ' :: OccInfo
occ' = OccInfo
strongLoopBreaker { occ_tail = tail_info }
tail_info :: TailCallInfo
tail_info = OccInfo -> TailCallInfo
tailCallInfo (CoreBndr -> OccInfo
idOccInfo CoreBndr
bndr)
mk_non_loop_breaker :: VarSet -> Id -> Id
mk_non_loop_breaker :: VarSet -> CoreBndr -> CoreBndr
mk_non_loop_breaker VarSet
weak_fvs CoreBndr
bndr
| CoreBndr
bndr CoreBndr -> VarSet -> Bool
`elemVarSet` VarSet
weak_fvs = CoreBndr -> OccInfo -> CoreBndr
setIdOccInfo CoreBndr
bndr OccInfo
occ'
| Bool
otherwise = CoreBndr
bndr
where
occ' :: OccInfo
occ' = OccInfo
weakLoopBreaker { occ_tail = tail_info }
tail_info :: TailCallInfo
tail_info = OccInfo -> TailCallInfo
tailCallInfo (CoreBndr -> OccInfo
idOccInfo CoreBndr
bndr)
chooseLoopBreaker :: Bool
-> NodeScore
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> ([LoopBreakerNode], [LoopBreakerNode])
chooseLoopBreaker :: Bool
-> NodeScore
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> ([LoopBreakerNode], [LoopBreakerNode])
chooseLoopBreaker Bool
_ NodeScore
_ [LoopBreakerNode]
loop_nodes [LoopBreakerNode]
acc []
= ([LoopBreakerNode]
loop_nodes, [LoopBreakerNode]
acc)
chooseLoopBreaker Bool
approx_lb NodeScore
loop_sc [LoopBreakerNode]
loop_nodes [LoopBreakerNode]
acc (LoopBreakerNode
node : [LoopBreakerNode]
nodes)
| Bool
approx_lb
, NodeScore -> JoinArity
rank NodeScore
sc JoinArity -> JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
== NodeScore -> JoinArity
rank NodeScore
loop_sc
= Bool
-> NodeScore
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> ([LoopBreakerNode], [LoopBreakerNode])
chooseLoopBreaker Bool
approx_lb NodeScore
loop_sc (LoopBreakerNode
node LoopBreakerNode -> [LoopBreakerNode] -> [LoopBreakerNode]
forall a. a -> [a] -> [a]
: [LoopBreakerNode]
loop_nodes) [LoopBreakerNode]
acc [LoopBreakerNode]
nodes
| NodeScore
sc NodeScore -> NodeScore -> Bool
`betterLB` NodeScore
loop_sc
= Bool
-> NodeScore
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> ([LoopBreakerNode], [LoopBreakerNode])
chooseLoopBreaker Bool
approx_lb NodeScore
sc [LoopBreakerNode
node] ([LoopBreakerNode]
loop_nodes [LoopBreakerNode] -> [LoopBreakerNode] -> [LoopBreakerNode]
forall a. [a] -> [a] -> [a]
++ [LoopBreakerNode]
acc) [LoopBreakerNode]
nodes
| Bool
otherwise
= Bool
-> NodeScore
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> [LoopBreakerNode]
-> ([LoopBreakerNode], [LoopBreakerNode])
chooseLoopBreaker Bool
approx_lb NodeScore
loop_sc [LoopBreakerNode]
loop_nodes (LoopBreakerNode
node LoopBreakerNode -> [LoopBreakerNode] -> [LoopBreakerNode]
forall a. a -> [a] -> [a]
: [LoopBreakerNode]
acc) [LoopBreakerNode]
nodes
where
sc :: NodeScore
sc = SimpleNodeDetails -> NodeScore
snd_score (LoopBreakerNode -> SimpleNodeDetails
forall key payload. Node key payload -> payload
node_payload LoopBreakerNode
node)
type LetrecNode = Node Unique NodeDetails
data NodeDetails
= ND { NodeDetails -> CoreBndr
nd_bndr :: Id
, NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs :: !(WithTailUsageDetails CoreExpr)
, NodeDetails -> VarSet
nd_inl :: IdSet
, NodeDetails -> Bool
nd_simple :: Bool
, NodeDetails -> VarSet
nd_weak_fvs :: IdSet
, NodeDetails -> VarSet
nd_active_rule_fvs :: IdSet
}
instance Outputable NodeDetails where
ppr :: NodeDetails -> SDoc
ppr NodeDetails
nd = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ND" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bndr =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr (NodeDetails -> CoreBndr
nd_bndr NodeDetails
nd)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"uds =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TailUsageDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr TailUsageDetails
uds
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"inl =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr (NodeDetails -> VarSet
nd_inl NodeDetails
nd)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"simple =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (NodeDetails -> Bool
nd_simple NodeDetails
nd)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"active_rule_fvs =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr (NodeDetails -> VarSet
nd_active_rule_fvs NodeDetails
nd)
])
where WithTailUsageDetails TailUsageDetails
uds CoreExpr
_ = NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs NodeDetails
nd
type LoopBreakerNode = Node Unique SimpleNodeDetails
data SimpleNodeDetails
= SND { SimpleNodeDetails -> CoreBndr
snd_bndr :: IdWithOccInfo
, SimpleNodeDetails -> CoreExpr
snd_rhs :: CoreExpr
, SimpleNodeDetails -> NodeScore
snd_score :: NodeScore
}
instance Outputable SimpleNodeDetails where
ppr :: SimpleNodeDetails -> SDoc
ppr SimpleNodeDetails
nd = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SND" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bndr =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SimpleNodeDetails -> CoreBndr
snd_bndr SimpleNodeDetails
nd)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"score =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> NodeScore -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SimpleNodeDetails -> NodeScore
snd_score SimpleNodeDetails
nd)
])
type NodeScore = ( Int
, Int
, Bool )
rank :: NodeScore -> Int
rank :: NodeScore -> JoinArity
rank (JoinArity
r, JoinArity
_, Bool
_) = JoinArity
r
makeNode :: OccEnv -> ImpRuleEdges -> VarSet
-> (Var, CoreExpr) -> LetrecNode
makeNode :: OccEnv
-> ImpRuleEdges
-> VarSet
-> (CoreBndr, CoreExpr)
-> Node Unique NodeDetails
makeNode !OccEnv
env ImpRuleEdges
imp_rule_edges VarSet
bndr_set (CoreBndr
bndr, CoreExpr
rhs)
= DigraphNode { node_payload :: NodeDetails
node_payload = NodeDetails
details
, node_key :: Unique
node_key = CoreBndr -> Unique
varUnique CoreBndr
bndr
, node_dependencies :: [Unique]
node_dependencies = VarSet -> [Unique]
forall elt. UniqSet elt -> [Unique]
nonDetKeysUniqSet VarSet
scope_fvs }
where
details :: NodeDetails
details = ND { nd_bndr :: CoreBndr
nd_bndr = CoreBndr
bndr'
, nd_rhs :: WithTailUsageDetails CoreExpr
nd_rhs = TailUsageDetails -> CoreExpr -> WithTailUsageDetails CoreExpr
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails TailUsageDetails
scope_uds CoreExpr
rhs'
, nd_inl :: VarSet
nd_inl = VarSet
inl_fvs
, nd_simple :: Bool
nd_simple = [(CoreRule, UsageDetails, UsageDetails)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds Bool -> Bool -> Bool
&& [(Activation, VarSet)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Activation, VarSet)]
imp_rule_info
, nd_weak_fvs :: VarSet
nd_weak_fvs = VarSet
weak_fvs
, nd_active_rule_fvs :: VarSet
nd_active_rule_fvs = VarSet
active_rule_fvs }
bndr' :: CoreBndr
bndr' = CoreBndr
bndr CoreBndr -> Unfolding -> CoreBndr
`setIdUnfolding` Unfolding
unf'
CoreBndr -> RuleInfo -> CoreBndr
`setIdSpecialisation` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule]
rules'
unadj_inl_uds :: UsageDetails
unadj_inl_uds = UsageDetails
unadj_rhs_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
adj_unf_uds
unadj_scope_uds :: UsageDetails
unadj_scope_uds = UsageDetails
unadj_inl_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
adj_rule_uds
scope_uds :: TailUsageDetails
scope_uds = JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
rhs_ja UsageDetails
unadj_scope_uds
scope_fvs :: VarSet
scope_fvs = VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndr_set UsageDetails
unadj_scope_uds
inl_fvs :: VarSet
inl_fvs = VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndr_set UsageDetails
unadj_inl_uds
rhs_env :: OccEnv
rhs_env = OccEnv -> OccEnv
rhsCtxt OccEnv
env
WithTailUsageDetails (TUD JoinArity
rhs_ja UsageDetails
unadj_rhs_uds) CoreExpr
rhs' = OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
rhs_env CoreExpr
rhs
unf :: Unfolding
unf = IdUnfoldingFun
realIdUnfolding CoreBndr
bndr
WithTailUsageDetails TailUsageDetails
unf_tuds Unfolding
unf' = OccEnv -> Unfolding -> WithTailUsageDetails Unfolding
occAnalUnfolding OccEnv
rhs_env Unfolding
unf
adj_unf_uds :: UsageDetails
adj_unf_uds = Maybe JoinArity -> TailUsageDetails -> UsageDetails
adjustTailArity (JoinArity -> Maybe JoinArity
forall a. a -> Maybe a
Just JoinArity
rhs_ja) TailUsageDetails
unf_tuds
is_active :: Activation -> Bool
is_active = OccEnv -> Activation -> Bool
occ_rule_act OccEnv
env :: Activation -> Bool
imp_rule_info :: [(Activation, VarSet)]
imp_rule_info = ImpRuleEdges -> CoreBndr -> [(Activation, VarSet)]
lookupImpRules ImpRuleEdges
imp_rule_edges CoreBndr
bndr
imp_rule_uds :: UsageDetails
imp_rule_uds = [(Activation, VarSet)] -> UsageDetails
impRulesScopeUsage [(Activation, VarSet)]
imp_rule_info
imp_rule_fvs :: VarSet
imp_rule_fvs = (Activation -> Bool) -> VarSet -> [(Activation, VarSet)] -> VarSet
impRulesActiveFvs Activation -> Bool
is_active VarSet
bndr_set [(Activation, VarSet)]
imp_rule_info
rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds = [ (CoreRule
r,UsageDetails
l,Maybe JoinArity -> TailUsageDetails -> UsageDetails
adjustTailArity (JoinArity -> Maybe JoinArity
forall a. a -> Maybe a
Just JoinArity
rhs_ja) TailUsageDetails
rhs_tuds)
| (CoreRule
r,UsageDetails
l,TailUsageDetails
rhs_tuds) <- OccEnv -> CoreBndr -> [(CoreRule, UsageDetails, TailUsageDetails)]
occAnalRules OccEnv
rhs_env CoreBndr
bndr ]
rules' :: [CoreRule]
rules' = ((CoreRule, UsageDetails, UsageDetails) -> CoreRule)
-> [(CoreRule, UsageDetails, UsageDetails)] -> [CoreRule]
forall a b. (a -> b) -> [a] -> [b]
map (CoreRule, UsageDetails, UsageDetails) -> CoreRule
forall a b c. (a, b, c) -> a
fstOf3 [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds
adj_rule_uds :: UsageDetails
adj_rule_uds = ((CoreRule, UsageDetails, UsageDetails)
-> UsageDetails -> UsageDetails)
-> UsageDetails
-> [(CoreRule, UsageDetails, UsageDetails)]
-> UsageDetails
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreRule, UsageDetails, UsageDetails)
-> UsageDetails -> UsageDetails
forall {a}.
(a, UsageDetails, UsageDetails) -> UsageDetails -> UsageDetails
add_rule_uds UsageDetails
imp_rule_uds [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds
add_rule_uds :: (a, UsageDetails, UsageDetails) -> UsageDetails -> UsageDetails
add_rule_uds (a
_, UsageDetails
l, UsageDetails
r) UsageDetails
uds = UsageDetails
l UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
r UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
uds
active_rule_fvs :: VarSet
active_rule_fvs = ((CoreRule, UsageDetails, UsageDetails) -> VarSet -> VarSet)
-> VarSet -> [(CoreRule, UsageDetails, UsageDetails)] -> VarSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreRule, UsageDetails, UsageDetails) -> VarSet -> VarSet
add_active_rule VarSet
imp_rule_fvs [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds
add_active_rule :: (CoreRule, UsageDetails, UsageDetails) -> VarSet -> VarSet
add_active_rule (CoreRule
rule, UsageDetails
_, UsageDetails
rhs_uds) VarSet
fvs
| Activation -> Bool
is_active (CoreRule -> Activation
ruleActivation CoreRule
rule)
= VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndr_set UsageDetails
rhs_uds VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
fvs
| Bool
otherwise
= VarSet
fvs
weak_fvs :: VarSet
weak_fvs = ((CoreRule, UsageDetails, UsageDetails) -> VarSet -> VarSet)
-> VarSet -> [(CoreRule, UsageDetails, UsageDetails)] -> VarSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreRule, UsageDetails, UsageDetails) -> VarSet -> VarSet
add_rule VarSet
emptyVarSet [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds
add_rule :: (CoreRule, UsageDetails, UsageDetails) -> VarSet -> VarSet
add_rule (CoreRule
_, UsageDetails
_, UsageDetails
rhs_uds) VarSet
fvs = VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndr_set UsageDetails
rhs_uds VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
fvs
mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
-> UsageDetails
-> [NodeDetails]
-> WithUsageDetails [LoopBreakerNode]
mkLoopBreakerNodes :: OccEnv
-> TopLevelFlag
-> UsageDetails
-> [NodeDetails]
-> WithUsageDetails [LoopBreakerNode]
mkLoopBreakerNodes !OccEnv
env TopLevelFlag
lvl UsageDetails
body_uds [NodeDetails]
details_s
= UsageDetails
-> [LoopBreakerNode] -> WithUsageDetails [LoopBreakerNode]
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
final_uds (String
-> (NodeDetails -> CoreBndr -> LoopBreakerNode)
-> [NodeDetails]
-> [CoreBndr]
-> [LoopBreakerNode]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"mkLoopBreakerNodes" NodeDetails -> CoreBndr -> LoopBreakerNode
mk_lb_node [NodeDetails]
details_s [CoreBndr]
bndrs')
where
WithUsageDetails UsageDetails
final_uds [CoreBndr]
bndrs' = TopLevelFlag
-> UsageDetails -> [NodeDetails] -> WithUsageDetails [CoreBndr]
tagRecBinders TopLevelFlag
lvl UsageDetails
body_uds [NodeDetails]
details_s
mk_lb_node :: NodeDetails -> CoreBndr -> LoopBreakerNode
mk_lb_node nd :: NodeDetails
nd@(ND { nd_bndr :: NodeDetails -> CoreBndr
nd_bndr = CoreBndr
old_bndr, nd_inl :: NodeDetails -> VarSet
nd_inl = VarSet
inl_fvs }) CoreBndr
new_bndr
= DigraphNode { node_payload :: SimpleNodeDetails
node_payload = SimpleNodeDetails
simple_nd
, node_key :: Unique
node_key = CoreBndr -> Unique
varUnique CoreBndr
old_bndr
, node_dependencies :: [Unique]
node_dependencies = VarSet -> [Unique]
forall elt. UniqSet elt -> [Unique]
nonDetKeysUniqSet VarSet
lb_deps }
where
WithTailUsageDetails TailUsageDetails
_ CoreExpr
rhs = NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs NodeDetails
nd
simple_nd :: SimpleNodeDetails
simple_nd = SND { snd_bndr :: CoreBndr
snd_bndr = CoreBndr
new_bndr, snd_rhs :: CoreExpr
snd_rhs = CoreExpr
rhs, snd_score :: NodeScore
snd_score = NodeScore
score }
score :: NodeScore
score = OccEnv -> CoreBndr -> VarSet -> NodeDetails -> NodeScore
nodeScore OccEnv
env CoreBndr
new_bndr VarSet
lb_deps NodeDetails
nd
lb_deps :: VarSet
lb_deps = VarEnv VarSet -> VarSet -> VarSet
extendFvs_ VarEnv VarSet
rule_fv_env VarSet
inl_fvs
rule_fv_env :: IdEnv IdSet
rule_fv_env :: VarEnv VarSet
rule_fv_env = VarEnv VarSet -> VarEnv VarSet
transClosureFV (VarEnv VarSet -> VarEnv VarSet) -> VarEnv VarSet -> VarEnv VarSet
forall a b. (a -> b) -> a -> b
$ [(CoreBndr, VarSet)] -> VarEnv VarSet
forall a. [(CoreBndr, a)] -> VarEnv a
mkVarEnv ([(CoreBndr, VarSet)] -> VarEnv VarSet)
-> [(CoreBndr, VarSet)] -> VarEnv VarSet
forall a b. (a -> b) -> a -> b
$
[ (CoreBndr
b, VarSet
rule_fvs)
| ND { nd_bndr :: NodeDetails -> CoreBndr
nd_bndr = CoreBndr
b, nd_active_rule_fvs :: NodeDetails -> VarSet
nd_active_rule_fvs = VarSet
rule_fvs } <- [NodeDetails]
details_s
, Bool -> Bool
not (VarSet -> Bool
isEmptyVarSet VarSet
rule_fvs) ]
nodeScore :: OccEnv
-> Id
-> VarSet
-> NodeDetails
-> NodeScore
nodeScore :: OccEnv -> CoreBndr -> VarSet -> NodeDetails -> NodeScore
nodeScore !OccEnv
env CoreBndr
new_bndr VarSet
lb_deps
(ND { nd_bndr :: NodeDetails -> CoreBndr
nd_bndr = CoreBndr
old_bndr, nd_rhs :: NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs = WithTailUsageDetails TailUsageDetails
_ CoreExpr
bind_rhs })
| Bool -> Bool
not (CoreBndr -> Bool
isId CoreBndr
old_bndr)
= (JoinArity
100, JoinArity
0, Bool
False)
| CoreBndr
old_bndr CoreBndr -> VarSet -> Bool
`elemVarSet` VarSet
lb_deps
= (JoinArity
0, JoinArity
0, Bool
True)
| Bool -> Bool
not (OccEnv -> CoreBndr -> Bool
occ_unf_act OccEnv
env CoreBndr
old_bndr)
= (JoinArity
0, JoinArity
0, Bool
True)
| CoreExpr -> Bool
exprIsTrivial CoreExpr
rhs
= JoinArity -> NodeScore
mk_score JoinArity
10
| DFunUnfolding { df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args } <- Unfolding
old_unf
= (JoinArity
9, [CoreExpr] -> JoinArity
forall a. [a] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [CoreExpr]
args, Bool
is_lb)
| CoreUnfolding { uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfWhen {} } <- Unfolding
old_unf
= JoinArity -> NodeScore
mk_score JoinArity
6
| CoreExpr -> Bool
forall {b}. Expr b -> Bool
is_con_app CoreExpr
rhs
= JoinArity -> NodeScore
mk_score JoinArity
5
| Unfolding -> Bool
isStableUnfolding Unfolding
old_unf
, Bool
can_unfold
= JoinArity -> NodeScore
mk_score JoinArity
3
| OccInfo -> Bool
isOneOcc (CoreBndr -> OccInfo
idOccInfo CoreBndr
new_bndr)
= JoinArity -> NodeScore
mk_score JoinArity
2
| Bool
can_unfold
= JoinArity -> NodeScore
mk_score JoinArity
1
| Bool
otherwise
= (JoinArity
0, JoinArity
0, Bool
is_lb)
where
mk_score :: Int -> NodeScore
mk_score :: JoinArity -> NodeScore
mk_score JoinArity
rank = (JoinArity
rank, JoinArity
rhs_size, Bool
is_lb)
is_lb :: Bool
is_lb = OccInfo -> Bool
isStrongLoopBreaker (CoreBndr -> OccInfo
idOccInfo CoreBndr
old_bndr)
old_unf :: Unfolding
old_unf = IdUnfoldingFun
realIdUnfolding CoreBndr
old_bndr
can_unfold :: Bool
can_unfold = Unfolding -> Bool
canUnfold Unfolding
old_unf
rhs :: CoreExpr
rhs = case Unfolding
old_unf of
CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
unf_rhs }
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
-> CoreExpr
unf_rhs
Unfolding
_ -> CoreExpr
bind_rhs
rhs_size :: JoinArity
rhs_size = case Unfolding
old_unf of
CoreUnfolding { uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guidance }
| UnfIfGoodArgs { ug_size :: UnfoldingGuidance -> JoinArity
ug_size = JoinArity
size } <- UnfoldingGuidance
guidance
-> JoinArity
size
Unfolding
_ -> CoreExpr -> JoinArity
cheapExprSize CoreExpr
rhs
is_con_app :: Expr b -> Bool
is_con_app (Var CoreBndr
v) = CoreBndr -> Bool
isConLikeId CoreBndr
v
is_con_app (App Expr b
f Expr b
_) = Expr b -> Bool
is_con_app Expr b
f
is_con_app (Lam b
_ Expr b
e) = Expr b -> Bool
is_con_app Expr b
e
is_con_app (Tick CoreTickish
_ Expr b
e) = Expr b -> Bool
is_con_app Expr b
e
is_con_app (Let Bind b
_ Expr b
e) = Expr b -> Bool
is_con_app Expr b
e
is_con_app Expr b
_ = Bool
False
maxExprSize :: Int
maxExprSize :: JoinArity
maxExprSize = JoinArity
20
cheapExprSize :: CoreExpr -> Int
cheapExprSize :: CoreExpr -> JoinArity
cheapExprSize CoreExpr
e
= JoinArity -> CoreExpr -> JoinArity
go JoinArity
0 CoreExpr
e
where
go :: JoinArity -> CoreExpr -> JoinArity
go JoinArity
n CoreExpr
e | JoinArity
n JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
>= JoinArity
maxExprSize = JoinArity
n
| Bool
otherwise = JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
e
go1 :: JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n (Var {}) = JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+JoinArity
1
go1 JoinArity
n (Lit {}) = JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+JoinArity
1
go1 JoinArity
n (Type {}) = JoinArity
n
go1 JoinArity
n (Coercion {}) = JoinArity
n
go1 JoinArity
n (Tick CoreTickish
_ CoreExpr
e) = JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
e
go1 JoinArity
n (Cast CoreExpr
e CoercionR
_) = JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
e
go1 JoinArity
n (App CoreExpr
f CoreExpr
a) = JoinArity -> CoreExpr -> JoinArity
go (JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
f) CoreExpr
a
go1 JoinArity
n (Lam CoreBndr
b CoreExpr
e)
| CoreBndr -> Bool
isTyVar CoreBndr
b = JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
e
| Bool
otherwise = JoinArity -> CoreExpr -> JoinArity
go (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+JoinArity
1) CoreExpr
e
go1 JoinArity
n (Let CoreBind
b CoreExpr
e) = JoinArity -> [CoreExpr] -> JoinArity
gos (JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
e) (CoreBind -> [CoreExpr]
forall b. Bind b -> [Expr b]
rhssOfBind CoreBind
b)
go1 JoinArity
n (Case CoreExpr
e CoreBndr
_ Type
_ [Alt CoreBndr]
as) = JoinArity -> [CoreExpr] -> JoinArity
gos (JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
e) ([Alt CoreBndr] -> [CoreExpr]
forall b. [Alt b] -> [Expr b]
rhssOfAlts [Alt CoreBndr]
as)
gos :: JoinArity -> [CoreExpr] -> JoinArity
gos JoinArity
n [] = JoinArity
n
gos JoinArity
n (CoreExpr
e:[CoreExpr]
es) | JoinArity
n JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
>= JoinArity
maxExprSize = JoinArity
n
| Bool
otherwise = JoinArity -> [CoreExpr] -> JoinArity
gos (JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
e) [CoreExpr]
es
betterLB :: NodeScore -> NodeScore -> Bool
betterLB :: NodeScore -> NodeScore -> Bool
betterLB (JoinArity
rank1, JoinArity
size1, Bool
lb1) (JoinArity
rank2, JoinArity
size2, Bool
_)
| JoinArity
rank1 JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
< JoinArity
rank2 = Bool
True
| JoinArity
rank1 JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
> JoinArity
rank2 = Bool
False
| JoinArity
size1 JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
< JoinArity
size2 = Bool
False
| JoinArity
size1 JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
> JoinArity
size2 = Bool
True
| Bool
lb1 = Bool
True
| Bool
otherwise = Bool
False
isOneShotFun :: CoreExpr -> Bool
isOneShotFun :: CoreExpr -> Bool
isOneShotFun (Lam CoreBndr
b CoreExpr
e) = CoreBndr -> Bool
isOneShotBndr CoreBndr
b Bool -> Bool -> Bool
&& CoreExpr -> Bool
isOneShotFun CoreExpr
e
isOneShotFun (Cast CoreExpr
e CoercionR
_) = CoreExpr -> Bool
isOneShotFun CoreExpr
e
isOneShotFun CoreExpr
_ = Bool
True
zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr
zapLambdaBndrs :: CoreExpr -> JoinArity -> CoreExpr
zapLambdaBndrs CoreExpr
fun JoinArity
arg_count
=
JoinArity -> CoreExpr -> Maybe CoreExpr
zap JoinArity
arg_count CoreExpr
fun Maybe CoreExpr -> CoreExpr -> CoreExpr
forall a. Maybe a -> a -> a
`orElse` CoreExpr
fun
where
zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr
zap :: JoinArity -> CoreExpr -> Maybe CoreExpr
zap JoinArity
0 CoreExpr
e | CoreExpr -> Bool
isOneShotFun CoreExpr
e = Maybe CoreExpr
forall a. Maybe a
Nothing
| Bool
otherwise = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
e
zap JoinArity
n (Cast CoreExpr
e CoercionR
co) = do { CoreExpr
e' <- JoinArity -> CoreExpr -> Maybe CoreExpr
zap JoinArity
n CoreExpr
e; CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
e' CoercionR
co) }
zap JoinArity
n (Lam CoreBndr
b CoreExpr
e) = do { CoreExpr
e' <- JoinArity -> CoreExpr -> Maybe CoreExpr
zap (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
-JoinArity
1) CoreExpr
e
; CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam (CoreBndr -> CoreBndr
zap_bndr CoreBndr
b) CoreExpr
e') }
zap JoinArity
_ CoreExpr
_ = Maybe CoreExpr
forall a. Maybe a
Nothing
zap_bndr :: CoreBndr -> CoreBndr
zap_bndr CoreBndr
b | CoreBndr -> Bool
isTyVar CoreBndr
b = CoreBndr
b
| Bool
otherwise = CoreBndr -> CoreBndr
zapLamIdInfo CoreBndr
b
occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env (Lam CoreBndr
bndr CoreExpr
expr)
| CoreBndr -> Bool
isTyVar CoreBndr
bndr
, let env1 :: OccEnv
env1 = OccEnv -> CoreBndr -> OccEnv
addOneInScope OccEnv
env CoreBndr
bndr
, WithTailUsageDetails (TUD JoinArity
ja UsageDetails
usage) CoreExpr
expr' <- OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env1 CoreExpr
expr
= TailUsageDetails -> CoreExpr -> WithTailUsageDetails CoreExpr
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails (JoinArity -> UsageDetails -> TailUsageDetails
TUD (JoinArity
jaJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+JoinArity
1) UsageDetails
usage) (CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
bndr CoreExpr
expr')
| Bool
otherwise
= let ([OneShotInfo]
env_one_shots', CoreBndr
bndr1)
= case OccEnv -> [OneShotInfo]
occ_one_shots OccEnv
env of
[] -> ([], CoreBndr
bndr)
(OneShotInfo
os : [OneShotInfo]
oss) -> ([OneShotInfo]
oss, CoreBndr -> OneShotInfo -> CoreBndr
updOneShotInfo CoreBndr
bndr OneShotInfo
os)
env1 :: OccEnv
env1 = OccEnv
env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
env2 :: OccEnv
env2 = OccEnv -> CoreBndr -> OccEnv
addOneInScope OccEnv
env1 CoreBndr
bndr
WithTailUsageDetails (TUD JoinArity
ja UsageDetails
usage) CoreExpr
expr' = OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env2 CoreExpr
expr
(UsageDetails
usage', CoreBndr
bndr2) = UsageDetails -> CoreBndr -> (UsageDetails, CoreBndr)
tagLamBinder UsageDetails
usage CoreBndr
bndr1
in TailUsageDetails -> CoreExpr -> WithTailUsageDetails CoreExpr
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails (JoinArity -> UsageDetails -> TailUsageDetails
TUD (JoinArity
jaJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+JoinArity
1) UsageDetails
usage') (CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
bndr2 CoreExpr
expr')
occAnalLamTail OccEnv
env (Cast CoreExpr
expr CoercionR
co)
= let WithTailUsageDetails (TUD JoinArity
ja UsageDetails
usage) CoreExpr
expr' = OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env CoreExpr
expr
usage1 :: UsageDetails
usage1 = UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
usage (CoercionR -> VarSet
coVarsOfCo CoercionR
co)
usage2 :: UsageDetails
usage2 = case CoreExpr
expr of
Var {} | OccEnv -> Bool
isRhsEnv OccEnv
env -> UsageDetails -> UsageDetails
markAllMany UsageDetails
usage1
CoreExpr
_ -> UsageDetails
usage1
usage3 :: UsageDetails
usage3 = UsageDetails -> UsageDetails
markAllNonTail UsageDetails
usage2
in TailUsageDetails -> CoreExpr -> WithTailUsageDetails CoreExpr
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
ja UsageDetails
usage3) (CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
expr' CoercionR
co)
occAnalLamTail OccEnv
env CoreExpr
expr = case OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
expr of
WithUsageDetails UsageDetails
usage CoreExpr
expr' -> TailUsageDetails -> CoreExpr -> WithTailUsageDetails CoreExpr
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
0 UsageDetails
usage) CoreExpr
expr'
occAnalUnfolding :: OccEnv
-> Unfolding
-> WithTailUsageDetails Unfolding
occAnalUnfolding :: OccEnv -> Unfolding -> WithTailUsageDetails Unfolding
occAnalUnfolding !OccEnv
env Unfolding
unf
= case Unfolding
unf of
unf :: Unfolding
unf@(CoreUnfolding { uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src })
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src ->
let
WithTailUsageDetails (TUD JoinArity
rhs_ja UsageDetails
usage) CoreExpr
rhs' = OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env CoreExpr
rhs
unf' :: Unfolding
unf' | OccEnv -> Bool
noBinderSwaps OccEnv
env = Unfolding
unf
| Bool
otherwise = Unfolding
unf { uf_tmpl = rhs' }
in TailUsageDetails -> Unfolding -> WithTailUsageDetails Unfolding
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
rhs_ja (UsageDetails -> UsageDetails
markAllMany UsageDetails
usage)) Unfolding
unf'
| Bool
otherwise -> TailUsageDetails -> Unfolding -> WithTailUsageDetails Unfolding
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
0 UsageDetails
emptyDetails) Unfolding
unf
unf :: Unfolding
unf@(DFunUnfolding { df_bndrs :: Unfolding -> [CoreBndr]
df_bndrs = [CoreBndr]
bndrs, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args })
-> TailUsageDetails -> Unfolding -> WithTailUsageDetails Unfolding
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
0 UsageDetails
final_usage) (Unfolding
unf { df_args = args' })
where
env' :: OccEnv
env' = OccEnv
env OccEnv -> [CoreBndr] -> OccEnv
`addInScope` [CoreBndr]
bndrs
(WithUsageDetails UsageDetails
usage [CoreExpr]
args') = OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
occAnalList OccEnv
env' [CoreExpr]
args
final_usage :: UsageDetails
final_usage = UsageDetails
usage UsageDetails -> [CoreBndr] -> UsageDetails
`addLamCoVarOccs` [CoreBndr]
bndrs UsageDetails -> [CoreBndr] -> UsageDetails
`delDetailsList` [CoreBndr]
bndrs
Unfolding
unf -> TailUsageDetails -> Unfolding -> WithTailUsageDetails Unfolding
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WithTailUsageDetails (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
0 UsageDetails
emptyDetails) Unfolding
unf
occAnalRules :: OccEnv
-> Id
-> [(CoreRule,
UsageDetails,
TailUsageDetails)]
occAnalRules :: OccEnv -> CoreBndr -> [(CoreRule, UsageDetails, TailUsageDetails)]
occAnalRules !OccEnv
env CoreBndr
bndr
= (CoreRule -> (CoreRule, UsageDetails, TailUsageDetails))
-> [CoreRule] -> [(CoreRule, UsageDetails, TailUsageDetails)]
forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> (CoreRule, UsageDetails, TailUsageDetails)
occ_anal_rule (CoreBndr -> [CoreRule]
idCoreRules CoreBndr
bndr)
where
occ_anal_rule :: CoreRule -> (CoreRule, UsageDetails, TailUsageDetails)
occ_anal_rule rule :: CoreRule
rule@(Rule { ru_bndrs :: CoreRule -> [CoreBndr]
ru_bndrs = [CoreBndr]
bndrs, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs })
= (CoreRule
rule', UsageDetails
lhs_uds', JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
rhs_ja UsageDetails
rhs_uds')
where
env' :: OccEnv
env' = OccEnv
env OccEnv -> [CoreBndr] -> OccEnv
`addInScope` [CoreBndr]
bndrs
rule' :: CoreRule
rule' | OccEnv -> Bool
noBinderSwaps OccEnv
env = CoreRule
rule
| Bool
otherwise = CoreRule
rule { ru_args = args', ru_rhs = rhs' }
(WithUsageDetails UsageDetails
lhs_uds [CoreExpr]
args') = OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
occAnalList OccEnv
env' [CoreExpr]
args
lhs_uds' :: UsageDetails
lhs_uds' = UsageDetails -> UsageDetails
markAllManyNonTail (UsageDetails
lhs_uds UsageDetails -> [CoreBndr] -> UsageDetails
`delDetailsList` [CoreBndr]
bndrs)
UsageDetails -> [CoreBndr] -> UsageDetails
`addLamCoVarOccs` [CoreBndr]
bndrs
(WithUsageDetails UsageDetails
rhs_uds CoreExpr
rhs') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env' CoreExpr
rhs
rhs_uds' :: UsageDetails
rhs_uds' = UsageDetails -> UsageDetails
markAllMany (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$
UsageDetails
rhs_uds UsageDetails -> [CoreBndr] -> UsageDetails
`delDetailsList` [CoreBndr]
bndrs
rhs_ja :: JoinArity
rhs_ja = [CoreExpr] -> JoinArity
forall a. [a] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [CoreExpr]
args
occ_anal_rule CoreRule
other_rule = (CoreRule
other_rule, UsageDetails
emptyDetails, JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
0 UsageDetails
emptyDetails)
occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
occAnalList !OccEnv
_ [] = UsageDetails -> [CoreExpr] -> WithUsageDetails [CoreExpr]
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
emptyDetails []
occAnalList OccEnv
env (CoreExpr
e:[CoreExpr]
es) = let
(WithUsageDetails UsageDetails
uds1 CoreExpr
e') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
e
(WithUsageDetails UsageDetails
uds2 [CoreExpr]
es') = OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
occAnalList OccEnv
env [CoreExpr]
es
in UsageDetails -> [CoreExpr] -> WithUsageDetails [CoreExpr]
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails (UsageDetails
uds1 UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
uds2) (CoreExpr
e' CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
es')
occAnal :: OccEnv
-> CoreExpr
-> WithUsageDetails CoreExpr
occAnal :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal !OccEnv
_ expr :: CoreExpr
expr@(Lit Literal
_) = UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
emptyDetails CoreExpr
expr
occAnal OccEnv
env expr :: CoreExpr
expr@(Var CoreBndr
_) = OccEnv
-> (CoreExpr, [CoreExpr], [CoreTickish])
-> WithUsageDetails CoreExpr
occAnalApp OccEnv
env (CoreExpr
expr, [], [])
occAnal OccEnv
_ expr :: CoreExpr
expr@(Type Type
ty)
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails (UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
emptyDetails (Type -> VarSet
coVarsOfType Type
ty)) CoreExpr
expr
occAnal OccEnv
_ expr :: CoreExpr
expr@(Coercion CoercionR
co)
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails (UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
emptyDetails (CoercionR -> VarSet
coVarsOfCo CoercionR
co)) CoreExpr
expr
occAnal OccEnv
env (Tick CoreTickish
tickish CoreExpr
body)
| SourceNote{} <- CoreTickish
tickish
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
usage (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
body')
| CoreTickish
tickish CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails (UsageDetails -> UsageDetails
markAllNonTail UsageDetails
usage) (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
body')
| Breakpoint XBreakpoint 'TickishPassCore
_ JoinArity
_ [XTickishId 'TickishPassCore]
ids <- CoreTickish
tickish
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails (UsageDetails
usage_lam UsageDetails -> UsageDetails -> UsageDetails
`andUDs` (CoreBndr -> UsageDetails -> UsageDetails)
-> UsageDetails -> [CoreBndr] -> UsageDetails
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBndr -> UsageDetails -> UsageDetails
addManyOcc UsageDetails
emptyDetails [CoreBndr]
[XTickishId 'TickishPassCore]
ids) (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
body')
| Bool
otherwise
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
usage_lam (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
body')
where
(WithUsageDetails UsageDetails
usage CoreExpr
body') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
body
usage_lam :: UsageDetails
usage_lam = UsageDetails -> UsageDetails
markAllNonTail (UsageDetails -> UsageDetails
markAllInsideLam UsageDetails
usage)
occAnal OccEnv
env (Cast CoreExpr
expr CoercionR
co)
= let (WithUsageDetails UsageDetails
usage CoreExpr
expr') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
expr
usage1 :: UsageDetails
usage1 = UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
usage (CoercionR -> VarSet
coVarsOfCo CoercionR
co)
usage2 :: UsageDetails
usage2 = UsageDetails -> UsageDetails
markAllNonTail UsageDetails
usage1
in UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
usage2 (CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
expr' CoercionR
co)
occAnal OccEnv
env app :: CoreExpr
app@(App CoreExpr
_ CoreExpr
_)
= OccEnv
-> (CoreExpr, [CoreExpr], [CoreTickish])
-> WithUsageDetails CoreExpr
occAnalApp OccEnv
env ((CoreTickish -> Bool)
-> CoreExpr -> (CoreExpr, [CoreExpr], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
app)
occAnal OccEnv
env expr :: CoreExpr
expr@(Lam {})
= Maybe JoinArity
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs Maybe JoinArity
forall a. Maybe a
Nothing (WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr)
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
forall a b. (a -> b) -> a -> b
$ OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env CoreExpr
expr
occAnal OccEnv
env (Case CoreExpr
scrut CoreBndr
bndr Type
ty [Alt CoreBndr]
alts)
= let
(WithUsageDetails UsageDetails
scrut_usage CoreExpr
scrut') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal (OccEnv -> [Alt CoreBndr] -> OccEnv
scrutCtxt OccEnv
env [Alt CoreBndr]
alts) CoreExpr
scrut
alt_env :: OccEnv
alt_env = CoreExpr -> CoreBndr -> OccEnv -> OccEnv
addBndrSwap CoreExpr
scrut' CoreBndr
bndr (OccEnv -> OccEnv) -> OccEnv -> OccEnv
forall a b. (a -> b) -> a -> b
$ OccEnv
env { occ_encl = OccVanilla } OccEnv -> CoreBndr -> OccEnv
`addOneInScope` CoreBndr
bndr
([UsageDetails]
alts_usage_s, [Alt CoreBndr]
alts') = (Alt CoreBndr -> (UsageDetails, Alt CoreBndr))
-> [Alt CoreBndr] -> ([UsageDetails], [Alt CoreBndr])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (OccEnv -> Alt CoreBndr -> (UsageDetails, Alt CoreBndr)
do_alt OccEnv
alt_env) [Alt CoreBndr]
alts
alts_usage :: UsageDetails
alts_usage = (UsageDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [UsageDetails] -> UsageDetails
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UsageDetails -> UsageDetails -> UsageDetails
orUDs UsageDetails
emptyDetails [UsageDetails]
alts_usage_s
(UsageDetails
alts_usage1, CoreBndr
tagged_bndr) = UsageDetails -> CoreBndr -> (UsageDetails, CoreBndr)
tagLamBinder UsageDetails
alts_usage CoreBndr
bndr
total_usage :: UsageDetails
total_usage = UsageDetails -> UsageDetails
markAllNonTail UsageDetails
scrut_usage UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
alts_usage1
in UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
total_usage (CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' CoreBndr
tagged_bndr Type
ty [Alt CoreBndr]
alts')
where
do_alt :: OccEnv -> Alt CoreBndr -> (UsageDetails, Alt CoreBndr)
do_alt !OccEnv
env (Alt AltCon
con [CoreBndr]
bndrs CoreExpr
rhs)
= let
(WithUsageDetails UsageDetails
rhs_usage1 CoreExpr
rhs1) = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal (OccEnv
env OccEnv -> [CoreBndr] -> OccEnv
`addInScope` [CoreBndr]
bndrs) CoreExpr
rhs
(UsageDetails
alt_usg, [CoreBndr]
tagged_bndrs) = UsageDetails -> [CoreBndr] -> (UsageDetails, [CoreBndr])
tagLamBinders UsageDetails
rhs_usage1 [CoreBndr]
bndrs
in
(UsageDetails
alt_usg, AltCon -> [CoreBndr] -> CoreExpr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
tagged_bndrs CoreExpr
rhs1)
occAnal OccEnv
env (Let CoreBind
bind CoreExpr
body)
= let
body_env :: OccEnv
body_env = OccEnv
env { occ_encl = OccVanilla } OccEnv -> [CoreBndr] -> OccEnv
`addInScope` CoreBind -> [CoreBndr]
forall b. Bind b -> [b]
bindersOf CoreBind
bind
(WithUsageDetails UsageDetails
body_usage CoreExpr
body') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
body_env CoreExpr
body
(WithUsageDetails UsageDetails
final_usage CoreProgram
binds') = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalBind OccEnv
env TopLevelFlag
NotTopLevel
ImpRuleEdges
noImpRuleEdges CoreBind
bind UsageDetails
body_usage
in UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
final_usage (CoreProgram -> CoreExpr -> CoreExpr
forall b. [Bind b] -> Expr b -> Expr b
mkLets CoreProgram
binds' CoreExpr
body')
occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr
occAnalArgs :: OccEnv
-> CoreExpr
-> [CoreExpr]
-> [[OneShotInfo]]
-> WithUsageDetails CoreExpr
occAnalArgs !OccEnv
env CoreExpr
fun [CoreExpr]
args ![[OneShotInfo]]
one_shots
= UsageDetails
-> CoreExpr
-> [CoreExpr]
-> [[OneShotInfo]]
-> WithUsageDetails CoreExpr
go UsageDetails
emptyDetails CoreExpr
fun [CoreExpr]
args [[OneShotInfo]]
one_shots
where
go :: UsageDetails
-> CoreExpr
-> [CoreExpr]
-> [[OneShotInfo]]
-> WithUsageDetails CoreExpr
go UsageDetails
uds CoreExpr
fun [] [[OneShotInfo]]
_ = UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
uds CoreExpr
fun
go UsageDetails
uds CoreExpr
fun (CoreExpr
arg:[CoreExpr]
args) [[OneShotInfo]]
one_shots
= UsageDetails
-> CoreExpr
-> [CoreExpr]
-> [[OneShotInfo]]
-> WithUsageDetails CoreExpr
go (UsageDetails
uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
arg_uds) (CoreExpr
fun CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
arg') [CoreExpr]
args [[OneShotInfo]]
one_shots'
where
!(WithUsageDetails UsageDetails
arg_uds CoreExpr
arg') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
arg_env CoreExpr
arg
!(OccEnv
arg_env, [[OneShotInfo]]
one_shots')
| CoreExpr -> Bool
forall {b}. Expr b -> Bool
isTypeArg CoreExpr
arg = (OccEnv
env, [[OneShotInfo]]
one_shots)
| Bool
otherwise = OccEnv -> [[OneShotInfo]] -> (OccEnv, [[OneShotInfo]])
valArgCtxt OccEnv
env [[OneShotInfo]]
one_shots
occAnalApp :: OccEnv
-> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])
-> WithUsageDetails (Expr CoreBndr)
occAnalApp :: OccEnv
-> (CoreExpr, [CoreExpr], [CoreTickish])
-> WithUsageDetails CoreExpr
occAnalApp !OccEnv
env (Var CoreBndr
fun, [CoreExpr]
args, [CoreTickish]
ticks)
| CoreBndr
fun CoreBndr -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
, [CoreExpr
t1, CoreExpr
t2, CoreExpr
arg] <- [CoreExpr]
args
, WithUsageDetails UsageDetails
usage CoreExpr
arg' <- Maybe JoinArity
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs (JoinArity -> Maybe JoinArity
forall a. a -> Maybe a
Just JoinArity
1) (WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr)
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
forall a b. (a -> b) -> a -> b
$ OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env CoreExpr
arg
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
usage ([CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
ticks (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
fun) [CoreExpr
t1, CoreExpr
t2, CoreExpr
arg'])
occAnalApp OccEnv
env (Var CoreBndr
fun_id, [CoreExpr]
args, [CoreTickish]
ticks)
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
all_uds ([CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
ticks CoreExpr
app')
where
!(CoreExpr
fun', CoreBndr
fun_id') = OccEnv -> CoreBndr -> (CoreExpr, CoreBndr)
lookupBndrSwap OccEnv
env CoreBndr
fun_id
!(WithUsageDetails UsageDetails
args_uds CoreExpr
app') = OccEnv
-> CoreExpr
-> [CoreExpr]
-> [[OneShotInfo]]
-> WithUsageDetails CoreExpr
occAnalArgs OccEnv
env CoreExpr
fun' [CoreExpr]
args [[OneShotInfo]]
one_shots
fun_uds :: UsageDetails
fun_uds = CoreBndr -> InterestingCxt -> JoinArity -> UsageDetails
mkOneOcc CoreBndr
fun_id' InterestingCxt
int_cxt JoinArity
n_args
all_uds :: UsageDetails
all_uds = UsageDetails
fun_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
final_args_uds
!final_args_uds :: UsageDetails
final_args_uds = UsageDetails -> UsageDetails
markAllNonTail (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$
Bool -> UsageDetails -> UsageDetails
markAllInsideLamIf (OccEnv -> Bool
isRhsEnv OccEnv
env Bool -> Bool -> Bool
&& Bool
is_exp) (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$
UsageDetails
args_uds
!n_val_args :: JoinArity
n_val_args = [CoreExpr] -> JoinArity
forall b. [Arg b] -> JoinArity
valArgCount [CoreExpr]
args
!n_args :: JoinArity
n_args = [CoreExpr] -> JoinArity
forall a. [a] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [CoreExpr]
args
!int_cxt :: InterestingCxt
int_cxt = case OccEnv -> OccEncl
occ_encl OccEnv
env of
OccEncl
OccScrut -> InterestingCxt
IsInteresting
OccEncl
_other | JoinArity
n_val_args JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
> JoinArity
0 -> InterestingCxt
IsInteresting
| Bool
otherwise -> InterestingCxt
NotInteresting
!is_exp :: Bool
is_exp = CheapAppFun
isExpandableApp CoreBndr
fun_id JoinArity
n_val_args
one_shots :: [[OneShotInfo]]
one_shots = DmdSig -> JoinArity -> [[OneShotInfo]]
argsOneShots (CoreBndr -> DmdSig
idDmdSig CoreBndr
fun_id) JoinArity
guaranteed_val_args
guaranteed_val_args :: JoinArity
guaranteed_val_args = JoinArity
n_val_args JoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+ [OneShotInfo] -> JoinArity
forall a. [a] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length ((OneShotInfo -> Bool) -> [OneShotInfo] -> [OneShotInfo]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile OneShotInfo -> Bool
isOneShotInfo
(OccEnv -> [OneShotInfo]
occ_one_shots OccEnv
env))
occAnalApp OccEnv
env (CoreExpr
fun, [CoreExpr]
args, [CoreTickish]
ticks)
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails (UsageDetails -> UsageDetails
markAllNonTail (UsageDetails
fun_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
args_uds))
([CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
ticks CoreExpr
app')
where
!(WithUsageDetails UsageDetails
args_uds CoreExpr
app') = OccEnv
-> CoreExpr
-> [CoreExpr]
-> [[OneShotInfo]]
-> WithUsageDetails CoreExpr
occAnalArgs OccEnv
env CoreExpr
fun' [CoreExpr]
args []
!(WithUsageDetails UsageDetails
fun_uds CoreExpr
fun') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal (OccEnv -> [CoreExpr] -> OccEnv
addAppCtxt OccEnv
env [CoreExpr]
args) CoreExpr
fun
addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
addAppCtxt :: OccEnv -> [CoreExpr] -> OccEnv
addAppCtxt env :: OccEnv
env@(OccEnv { occ_one_shots :: OccEnv -> [OneShotInfo]
occ_one_shots = [OneShotInfo]
ctxt }) [CoreExpr]
args
| JoinArity
n_val_args JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
> JoinArity
0
= OccEnv
env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt
, occ_encl = OccVanilla }
| Bool
otherwise
= OccEnv
env
where
n_val_args :: JoinArity
n_val_args = [CoreExpr] -> JoinArity
forall b. [Arg b] -> JoinArity
valArgCount [CoreExpr]
args
data OccEnv
= OccEnv { OccEnv -> OccEncl
occ_encl :: !OccEncl
, OccEnv -> [OneShotInfo]
occ_one_shots :: !OneShots
, OccEnv -> CoreBndr -> Bool
occ_unf_act :: Id -> Bool
, OccEnv -> Activation -> Bool
occ_rule_act :: Activation -> Bool
, OccEnv -> IdEnv (CoreBndr, MCoercion)
occ_bs_env :: !(IdEnv (OutId, MCoercion))
, OccEnv -> VarSet
occ_bs_rng :: !VarSet
}
data OccEncl
= OccRhs
| OccScrut
| OccVanilla
instance Outputable OccEncl where
ppr :: OccEncl -> SDoc
ppr OccEncl
OccRhs = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"occRhs"
ppr OccEncl
OccScrut = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"occScrut"
ppr OccEncl
OccVanilla = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"occVanilla"
type OneShots = [OneShotInfo]
initOccEnv :: OccEnv
initOccEnv :: OccEnv
initOccEnv
= OccEnv { occ_encl :: OccEncl
occ_encl = OccEncl
OccVanilla
, occ_one_shots :: [OneShotInfo]
occ_one_shots = []
, occ_unf_act :: CoreBndr -> Bool
occ_unf_act = \CoreBndr
_ -> Bool
True
, occ_rule_act :: Activation -> Bool
occ_rule_act = \Activation
_ -> Bool
True
, occ_bs_env :: IdEnv (CoreBndr, MCoercion)
occ_bs_env = IdEnv (CoreBndr, MCoercion)
forall a. VarEnv a
emptyVarEnv
, occ_bs_rng :: VarSet
occ_bs_rng = VarSet
emptyVarSet }
noBinderSwaps :: OccEnv -> Bool
noBinderSwaps :: OccEnv -> Bool
noBinderSwaps (OccEnv { occ_bs_env :: OccEnv -> IdEnv (CoreBndr, MCoercion)
occ_bs_env = IdEnv (CoreBndr, MCoercion)
bs_env }) = IdEnv (CoreBndr, MCoercion) -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv IdEnv (CoreBndr, MCoercion)
bs_env
scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv
scrutCtxt :: OccEnv -> [Alt CoreBndr] -> OccEnv
scrutCtxt !OccEnv
env [Alt CoreBndr]
alts
| Bool
interesting_alts = OccEnv
env { occ_encl = OccScrut, occ_one_shots = [] }
| Bool
otherwise = OccEnv
env { occ_encl = OccVanilla, occ_one_shots = [] }
where
interesting_alts :: Bool
interesting_alts = case [Alt CoreBndr]
alts of
[] -> Bool
False
[Alt CoreBndr
alt] -> Bool -> Bool
not (Alt CoreBndr -> Bool
forall b. Alt b -> Bool
isDefaultAlt Alt CoreBndr
alt)
[Alt CoreBndr]
_ -> Bool
True
rhsCtxt :: OccEnv -> OccEnv
rhsCtxt :: OccEnv -> OccEnv
rhsCtxt !OccEnv
env = OccEnv
env { occ_encl = OccRhs, occ_one_shots = [] }
valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
valArgCtxt :: OccEnv -> [[OneShotInfo]] -> (OccEnv, [[OneShotInfo]])
valArgCtxt !OccEnv
env []
= (OccEnv
env { occ_encl = OccVanilla, occ_one_shots = [] }, [])
valArgCtxt OccEnv
env ([OneShotInfo]
one_shots:[[OneShotInfo]]
one_shots_s)
= (OccEnv
env { occ_encl = OccVanilla, occ_one_shots = one_shots }, [[OneShotInfo]]
one_shots_s)
isRhsEnv :: OccEnv -> Bool
isRhsEnv :: OccEnv -> Bool
isRhsEnv (OccEnv { occ_encl :: OccEnv -> OccEncl
occ_encl = OccEncl
cxt }) = case OccEncl
cxt of
OccEncl
OccRhs -> Bool
True
OccEncl
_ -> Bool
False
addOneInScope :: OccEnv -> CoreBndr -> OccEnv
addOneInScope :: OccEnv -> CoreBndr -> OccEnv
addOneInScope env :: OccEnv
env@(OccEnv { occ_bs_env :: OccEnv -> IdEnv (CoreBndr, MCoercion)
occ_bs_env = IdEnv (CoreBndr, MCoercion)
swap_env, occ_bs_rng :: OccEnv -> VarSet
occ_bs_rng = VarSet
rng_vars }) CoreBndr
bndr
| CoreBndr
bndr CoreBndr -> VarSet -> Bool
`elemVarSet` VarSet
rng_vars = OccEnv
env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
| Bool
otherwise = OccEnv
env { occ_bs_env = swap_env `delVarEnv` bndr }
addInScope :: OccEnv -> [Var] -> OccEnv
addInScope :: OccEnv -> [CoreBndr] -> OccEnv
addInScope env :: OccEnv
env@(OccEnv { occ_bs_env :: OccEnv -> IdEnv (CoreBndr, MCoercion)
occ_bs_env = IdEnv (CoreBndr, MCoercion)
swap_env, occ_bs_rng :: OccEnv -> VarSet
occ_bs_rng = VarSet
rng_vars }) [CoreBndr]
bndrs
| (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CoreBndr -> VarSet -> Bool
`elemVarSet` VarSet
rng_vars) [CoreBndr]
bndrs = OccEnv
env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
| Bool
otherwise = OccEnv
env { occ_bs_env = swap_env `delVarEnvList` bndrs }
transClosureFV :: VarEnv VarSet -> VarEnv VarSet
transClosureFV :: VarEnv VarSet -> VarEnv VarSet
transClosureFV VarEnv VarSet
env
| Bool
no_change = VarEnv VarSet
env
| Bool
otherwise = VarEnv VarSet -> VarEnv VarSet
transClosureFV ([(Unique, VarSet)] -> VarEnv VarSet
forall elt key. [(Unique, elt)] -> UniqFM key elt
listToUFM_Directly [(Unique, VarSet)]
new_fv_list)
where
(Bool
no_change, [(Unique, VarSet)]
new_fv_list) = (Bool -> (Unique, VarSet) -> (Bool, (Unique, VarSet)))
-> Bool -> [(Unique, VarSet)] -> (Bool, [(Unique, VarSet)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Bool -> (Unique, VarSet) -> (Bool, (Unique, VarSet))
bump Bool
True (VarEnv VarSet -> [(Unique, VarSet)]
forall key elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList VarEnv VarSet
env)
bump :: Bool -> (Unique, VarSet) -> (Bool, (Unique, VarSet))
bump Bool
no_change (Unique
b,VarSet
fvs)
| Bool
no_change_here = (Bool
no_change, (Unique
b,VarSet
fvs))
| Bool
otherwise = (Bool
False, (Unique
b,VarSet
new_fvs))
where
(VarSet
new_fvs, Bool
no_change_here) = VarEnv VarSet -> VarSet -> (VarSet, Bool)
extendFvs VarEnv VarSet
env VarSet
fvs
extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet
extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet
extendFvs_ VarEnv VarSet
env VarSet
s = (VarSet, Bool) -> VarSet
forall a b. (a, b) -> a
fst (VarEnv VarSet -> VarSet -> (VarSet, Bool)
extendFvs VarEnv VarSet
env VarSet
s)
extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)
extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)
extendFvs VarEnv VarSet
env VarSet
s
| VarEnv VarSet -> Bool
forall key elt. UniqFM key elt -> Bool
isNullUFM VarEnv VarSet
env
= (VarSet
s, Bool
True)
| Bool
otherwise
= (VarSet
s VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
extras, VarSet
extras VarSet -> VarSet -> Bool
`subVarSet` VarSet
s)
where
extras :: VarSet
extras :: VarSet
extras = (VarSet -> VarSet -> VarSet) -> VarSet -> VarEnv VarSet -> VarSet
forall elt a key. (elt -> a -> a) -> a -> UniqFM key elt -> a
nonDetStrictFoldUFM VarSet -> VarSet -> VarSet
unionVarSet VarSet
emptyVarSet (VarEnv VarSet -> VarSet) -> VarEnv VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
(VarSet -> CoreBndr -> VarSet)
-> VarEnv VarSet -> VarEnv CoreBndr -> VarEnv VarSet
forall elt1 elt2 elt3 key.
(elt1 -> elt2 -> elt3)
-> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt3
intersectUFM_C (\VarSet
x CoreBndr
_ -> VarSet
x) VarEnv VarSet
env (VarSet -> VarEnv CoreBndr
forall a. UniqSet a -> UniqFM a a
getUniqSet VarSet
s)
addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
addBndrSwap :: CoreExpr -> CoreBndr -> OccEnv -> OccEnv
addBndrSwap CoreExpr
scrut CoreBndr
case_bndr
env :: OccEnv
env@(OccEnv { occ_bs_env :: OccEnv -> IdEnv (CoreBndr, MCoercion)
occ_bs_env = IdEnv (CoreBndr, MCoercion)
swap_env, occ_bs_rng :: OccEnv -> VarSet
occ_bs_rng = VarSet
rng_vars })
| Just (CoreBndr
scrut_var, MCoercion
mco) <- CoreExpr -> Maybe (CoreBndr, MCoercion)
scrutBinderSwap_maybe CoreExpr
scrut
, CoreBndr
scrut_var CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
/= CoreBndr
case_bndr
= OccEnv
env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)
, occ_bs_rng = rng_vars `extendVarSet` case_bndr'
`unionVarSet` tyCoVarsOfMCo mco }
| Bool
otherwise
= OccEnv
env
where
case_bndr' :: CoreBndr
case_bndr' = CoreBndr -> CoreBndr
zapIdOccInfo CoreBndr
case_bndr
scrutBinderSwap_maybe :: OutExpr -> Maybe (OutVar, MCoercion)
scrutBinderSwap_maybe :: CoreExpr -> Maybe (CoreBndr, MCoercion)
scrutBinderSwap_maybe (Var CoreBndr
v) = (CoreBndr, MCoercion) -> Maybe (CoreBndr, MCoercion)
forall a. a -> Maybe a
Just (CoreBndr
v, MCoercion
MRefl)
scrutBinderSwap_maybe (Cast (Var CoreBndr
v) CoercionR
co)
| Bool -> Bool
not (CoreBndr -> Bool
isDictId CoreBndr
v) = (CoreBndr, MCoercion) -> Maybe (CoreBndr, MCoercion)
forall a. a -> Maybe a
Just (CoreBndr
v, CoercionR -> MCoercion
MCo (CoercionR -> CoercionR
mkSymCo CoercionR
co))
scrutBinderSwap_maybe (Tick CoreTickish
_ CoreExpr
e) = CoreExpr -> Maybe (CoreBndr, MCoercion)
scrutBinderSwap_maybe CoreExpr
e
scrutBinderSwap_maybe CoreExpr
_ = Maybe (CoreBndr, MCoercion)
forall a. Maybe a
Nothing
lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
lookupBndrSwap :: OccEnv -> CoreBndr -> (CoreExpr, CoreBndr)
lookupBndrSwap env :: OccEnv
env@(OccEnv { occ_bs_env :: OccEnv -> IdEnv (CoreBndr, MCoercion)
occ_bs_env = IdEnv (CoreBndr, MCoercion)
bs_env }) CoreBndr
bndr
= case IdEnv (CoreBndr, MCoercion)
-> CoreBndr -> Maybe (CoreBndr, MCoercion)
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv IdEnv (CoreBndr, MCoercion)
bs_env CoreBndr
bndr of {
Maybe (CoreBndr, MCoercion)
Nothing -> (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
bndr, CoreBndr
bndr) ;
Just (CoreBndr
bndr1, MCoercion
mco) ->
case OccEnv -> CoreBndr -> (CoreExpr, CoreBndr)
lookupBndrSwap OccEnv
env CoreBndr
bndr1 of
(CoreExpr
fun, CoreBndr
fun_id) -> (CoreExpr -> MCoercion -> CoreExpr
mkCastMCo CoreExpr
fun MCoercion
mco, CoreBndr
fun_id) }
type OccInfoEnv = IdEnv OccInfo
type ZappedSet = OccInfoEnv
data UsageDetails
= UD { UsageDetails -> OccInfoEnv
ud_env :: !OccInfoEnv
, UsageDetails -> OccInfoEnv
ud_z_many :: !ZappedSet
, UsageDetails -> OccInfoEnv
ud_z_in_lam :: !ZappedSet
, UsageDetails -> OccInfoEnv
ud_z_no_tail :: !ZappedSet }
instance Outputable UsageDetails where
ppr :: UsageDetails -> SDoc
ppr UsageDetails
ud = OccInfoEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UsageDetails -> OccInfoEnv
ud_env (UsageDetails -> UsageDetails
flattenUsageDetails UsageDetails
ud))
data TailUsageDetails = TUD !JoinArity !UsageDetails
instance Outputable TailUsageDetails where
ppr :: TailUsageDetails -> SDoc
ppr (TUD JoinArity
ja UsageDetails
uds) = SDoc
lambda SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr JoinArity
ja SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UsageDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr UsageDetails
uds
andUDs, orUDs
:: UsageDetails -> UsageDetails -> UsageDetails
andUDs :: UsageDetails -> UsageDetails -> UsageDetails
andUDs = (OccInfo -> OccInfo -> OccInfo)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith OccInfo -> OccInfo -> OccInfo
addOccInfo
orUDs :: UsageDetails -> UsageDetails -> UsageDetails
orUDs = (OccInfo -> OccInfo -> OccInfo)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith OccInfo -> OccInfo -> OccInfo
orOccInfo
mkOneOcc :: Id -> InterestingCxt -> JoinArity -> UsageDetails
mkOneOcc :: CoreBndr -> InterestingCxt -> JoinArity -> UsageDetails
mkOneOcc CoreBndr
id InterestingCxt
int_cxt JoinArity
arity
| CoreBndr -> Bool
isLocalId CoreBndr
id
= UsageDetails
emptyDetails { ud_env = unitVarEnv id occ_info }
| Bool
otherwise
= UsageDetails
emptyDetails
where
occ_info :: OccInfo
occ_info = OneOcc { occ_in_lam :: InsideLam
occ_in_lam = InsideLam
NotInsideLam
, occ_n_br :: JoinArity
occ_n_br = JoinArity
oneBranch
, occ_int_cxt :: InterestingCxt
occ_int_cxt = InterestingCxt
int_cxt
, occ_tail :: TailCallInfo
occ_tail = JoinArity -> TailCallInfo
AlwaysTailCalled JoinArity
arity }
addManyOccId :: UsageDetails -> Id -> UsageDetails
addManyOccId :: UsageDetails -> CoreBndr -> UsageDetails
addManyOccId UsageDetails
ud CoreBndr
id = UsageDetails
ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo }
addManyOcc :: Var -> UsageDetails -> UsageDetails
addManyOcc :: CoreBndr -> UsageDetails -> UsageDetails
addManyOcc CoreBndr
v UsageDetails
u | CoreBndr -> Bool
isId CoreBndr
v = UsageDetails -> CoreBndr -> UsageDetails
addManyOccId UsageDetails
u CoreBndr
v
| Bool
otherwise = UsageDetails
u
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
usage VarSet
id_set = (CoreBndr -> UsageDetails -> UsageDetails)
-> UsageDetails -> VarSet -> UsageDetails
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet CoreBndr -> UsageDetails -> UsageDetails
addManyOcc UsageDetails
usage VarSet
id_set
addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
addLamCoVarOccs :: UsageDetails -> [CoreBndr] -> UsageDetails
addLamCoVarOccs UsageDetails
uds [CoreBndr]
bndrs
= UsageDetails
uds UsageDetails -> VarSet -> UsageDetails
`addManyOccs` [Type] -> VarSet
coVarsOfTypes ((CoreBndr -> Type) -> [CoreBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Type
varType [CoreBndr]
bndrs)
delDetails :: UsageDetails -> Id -> UsageDetails
delDetails :: UsageDetails -> CoreBndr -> UsageDetails
delDetails UsageDetails
ud CoreBndr
bndr
= UsageDetails
ud UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
`alterUsageDetails` (OccInfoEnv -> CoreBndr -> OccInfoEnv
forall a. VarEnv a -> CoreBndr -> VarEnv a
`delVarEnv` CoreBndr
bndr)
delDetailsList :: UsageDetails -> [Id] -> UsageDetails
delDetailsList :: UsageDetails -> [CoreBndr] -> UsageDetails
delDetailsList UsageDetails
ud [CoreBndr]
bndrs
= UsageDetails
ud UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
`alterUsageDetails` (OccInfoEnv -> [CoreBndr] -> OccInfoEnv
forall a. VarEnv a -> [CoreBndr] -> VarEnv a
`delVarEnvList` [CoreBndr]
bndrs)
emptyDetails :: UsageDetails
emptyDetails :: UsageDetails
emptyDetails = UD { ud_env :: OccInfoEnv
ud_env = OccInfoEnv
forall a. VarEnv a
emptyVarEnv
, ud_z_many :: OccInfoEnv
ud_z_many = OccInfoEnv
forall a. VarEnv a
emptyVarEnv
, ud_z_in_lam :: OccInfoEnv
ud_z_in_lam = OccInfoEnv
forall a. VarEnv a
emptyVarEnv
, ud_z_no_tail :: OccInfoEnv
ud_z_no_tail = OccInfoEnv
forall a. VarEnv a
emptyVarEnv }
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails = OccInfoEnv -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv (OccInfoEnv -> Bool)
-> (UsageDetails -> OccInfoEnv) -> UsageDetails -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UsageDetails -> OccInfoEnv
ud_env
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
markAllMany :: UsageDetails -> UsageDetails
markAllMany UsageDetails
ud = UsageDetails
ud { ud_z_many = ud_env ud }
markAllInsideLam :: UsageDetails -> UsageDetails
markAllInsideLam UsageDetails
ud = UsageDetails
ud { ud_z_in_lam = ud_env ud }
markAllNonTail :: UsageDetails -> UsageDetails
markAllNonTail UsageDetails
ud = UsageDetails
ud { ud_z_no_tail = ud_env ud }
markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
markAllInsideLamIf :: Bool -> UsageDetails -> UsageDetails
markAllInsideLamIf Bool
True UsageDetails
ud = UsageDetails -> UsageDetails
markAllInsideLam UsageDetails
ud
markAllInsideLamIf Bool
False UsageDetails
ud = UsageDetails
ud
markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
markAllNonTailIf Bool
True UsageDetails
ud = UsageDetails -> UsageDetails
markAllNonTail UsageDetails
ud
markAllNonTailIf Bool
False UsageDetails
ud = UsageDetails
ud
markAllManyNonTail :: UsageDetails -> UsageDetails
markAllManyNonTail = UsageDetails -> UsageDetails
markAllMany (UsageDetails -> UsageDetails)
-> (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UsageDetails -> UsageDetails
markAllNonTail
lookupDetails :: UsageDetails -> Id -> OccInfo
lookupDetails :: UsageDetails -> CoreBndr -> OccInfo
lookupDetails UsageDetails
ud CoreBndr
id
= case OccInfoEnv -> CoreBndr -> Maybe OccInfo
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud) CoreBndr
id of
Just OccInfo
occ -> UsageDetails -> CoreBndr -> OccInfo -> OccInfo
doZapping UsageDetails
ud CoreBndr
id OccInfo
occ
Maybe OccInfo
Nothing -> OccInfo
IAmDead
usedIn :: Id -> UsageDetails -> Bool
CoreBndr
v usedIn :: CoreBndr -> UsageDetails -> Bool
`usedIn` UsageDetails
ud = CoreBndr -> Bool
isExportedId CoreBndr
v Bool -> Bool -> Bool
|| CoreBndr
v CoreBndr -> OccInfoEnv -> Bool
forall a. CoreBndr -> VarEnv a -> Bool
`elemVarEnv` UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud
udFreeVars :: VarSet -> UsageDetails -> VarSet
udFreeVars :: VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndrs UsageDetails
ud = VarSet -> OccInfoEnv -> VarSet
restrictFreeVars VarSet
bndrs (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud)
restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet
restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet
restrictFreeVars VarSet
bndrs OccInfoEnv
fvs = VarSet -> OccInfoEnv -> VarSet
forall key b. UniqSet key -> UniqFM key b -> UniqSet key
restrictUniqSetToUFM VarSet
bndrs OccInfoEnv
fvs
combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith OccInfo -> OccInfo -> OccInfo
plus_occ_info UsageDetails
ud1 UsageDetails
ud2
| UsageDetails -> Bool
isEmptyDetails UsageDetails
ud1 = UsageDetails
ud2
| UsageDetails -> Bool
isEmptyDetails UsageDetails
ud2 = UsageDetails
ud1
| Bool
otherwise
= UD { ud_env :: OccInfoEnv
ud_env = (OccInfo -> OccInfo -> OccInfo)
-> OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C OccInfo -> OccInfo -> OccInfo
plus_occ_info (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud1) (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud2)
, ud_z_many :: OccInfoEnv
ud_z_many = OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv (UsageDetails -> OccInfoEnv
ud_z_many UsageDetails
ud1) (UsageDetails -> OccInfoEnv
ud_z_many UsageDetails
ud2)
, ud_z_in_lam :: OccInfoEnv
ud_z_in_lam = OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv (UsageDetails -> OccInfoEnv
ud_z_in_lam UsageDetails
ud1) (UsageDetails -> OccInfoEnv
ud_z_in_lam UsageDetails
ud2)
, ud_z_no_tail :: OccInfoEnv
ud_z_no_tail = OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv (UsageDetails -> OccInfoEnv
ud_z_no_tail UsageDetails
ud1) (UsageDetails -> OccInfoEnv
ud_z_no_tail UsageDetails
ud2) }
doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo
doZapping :: UsageDetails -> CoreBndr -> OccInfo -> OccInfo
doZapping UsageDetails
ud CoreBndr
var OccInfo
occ
= UsageDetails -> Unique -> OccInfo -> OccInfo
doZappingByUnique UsageDetails
ud (CoreBndr -> Unique
varUnique CoreBndr
var) OccInfo
occ
doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo
doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo
doZappingByUnique (UD { ud_z_many :: UsageDetails -> OccInfoEnv
ud_z_many = OccInfoEnv
many
, ud_z_in_lam :: UsageDetails -> OccInfoEnv
ud_z_in_lam = OccInfoEnv
in_lam
, ud_z_no_tail :: UsageDetails -> OccInfoEnv
ud_z_no_tail = OccInfoEnv
no_tail })
Unique
uniq OccInfo
occ
= OccInfo
occ2
where
occ1 :: OccInfo
occ1 | Unique
uniq Unique -> OccInfoEnv -> Bool
forall a. Unique -> VarEnv a -> Bool
`elemVarEnvByKey` OccInfoEnv
many = OccInfo -> OccInfo
markMany OccInfo
occ
| Unique
uniq Unique -> OccInfoEnv -> Bool
forall a. Unique -> VarEnv a -> Bool
`elemVarEnvByKey` OccInfoEnv
in_lam = OccInfo -> OccInfo
markInsideLam OccInfo
occ
| Bool
otherwise = OccInfo
occ
occ2 :: OccInfo
occ2 | Unique
uniq Unique -> OccInfoEnv -> Bool
forall a. Unique -> VarEnv a -> Bool
`elemVarEnvByKey` OccInfoEnv
no_tail = OccInfo -> OccInfo
markNonTail OccInfo
occ1
| Bool
otherwise = OccInfo
occ1
alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
alterUsageDetails !UsageDetails
ud OccInfoEnv -> OccInfoEnv
f
= UD { ud_env :: OccInfoEnv
ud_env = OccInfoEnv -> OccInfoEnv
f (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud)
, ud_z_many :: OccInfoEnv
ud_z_many = OccInfoEnv -> OccInfoEnv
f (UsageDetails -> OccInfoEnv
ud_z_many UsageDetails
ud)
, ud_z_in_lam :: OccInfoEnv
ud_z_in_lam = OccInfoEnv -> OccInfoEnv
f (UsageDetails -> OccInfoEnv
ud_z_in_lam UsageDetails
ud)
, ud_z_no_tail :: OccInfoEnv
ud_z_no_tail = OccInfoEnv -> OccInfoEnv
f (UsageDetails -> OccInfoEnv
ud_z_no_tail UsageDetails
ud) }
flattenUsageDetails :: UsageDetails -> UsageDetails
flattenUsageDetails :: UsageDetails -> UsageDetails
flattenUsageDetails ud :: UsageDetails
ud@(UD { ud_env :: UsageDetails -> OccInfoEnv
ud_env = OccInfoEnv
env })
= UD { ud_env :: OccInfoEnv
ud_env = (Unique -> OccInfo -> OccInfo) -> OccInfoEnv -> OccInfoEnv
forall elt1 elt2 key.
(Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapUFM_Directly (UsageDetails -> Unique -> OccInfo -> OccInfo
doZappingByUnique UsageDetails
ud) OccInfoEnv
env
, ud_z_many :: OccInfoEnv
ud_z_many = OccInfoEnv
forall a. VarEnv a
emptyVarEnv
, ud_z_in_lam :: OccInfoEnv
ud_z_in_lam = OccInfoEnv
forall a. VarEnv a
emptyVarEnv
, ud_z_no_tail :: OccInfoEnv
ud_z_no_tail = OccInfoEnv
forall a. VarEnv a
emptyVarEnv }
adjustTailUsage :: Maybe JoinArity
-> CoreExpr
-> TailUsageDetails
-> UsageDetails
adjustTailUsage :: Maybe JoinArity -> CoreExpr -> TailUsageDetails -> UsageDetails
adjustTailUsage Maybe JoinArity
mb_join_arity CoreExpr
rhs (TUD JoinArity
rhs_ja UsageDetails
usage)
=
Bool -> UsageDetails -> UsageDetails
markAllInsideLamIf (Bool -> Bool
not Bool
one_shot) (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$
Bool -> UsageDetails -> UsageDetails
markAllNonTailIf (Bool -> Bool
not Bool
exact_join) (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$
UsageDetails
usage
where
one_shot :: Bool
one_shot = CoreExpr -> Bool
isOneShotFun CoreExpr
rhs
exact_join :: Bool
exact_join = Maybe JoinArity
mb_join_arity Maybe JoinArity -> Maybe JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
== JoinArity -> Maybe JoinArity
forall a. a -> Maybe a
Just JoinArity
rhs_ja
adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails
adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails
adjustTailArity Maybe JoinArity
mb_rhs_ja (TUD JoinArity
ud_ja UsageDetails
usage) =
Bool -> UsageDetails -> UsageDetails
markAllNonTailIf (Maybe JoinArity
mb_rhs_ja Maybe JoinArity -> Maybe JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
/= JoinArity -> Maybe JoinArity
forall a. a -> Maybe a
Just JoinArity
ud_ja) UsageDetails
usage
markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
markNonRecJoinOneShots JoinArity
join_arity CoreExpr
rhs
= JoinArity -> CoreExpr -> CoreExpr
forall {t}. (Eq t, Num t) => t -> CoreExpr -> CoreExpr
go JoinArity
join_arity CoreExpr
rhs
where
go :: t -> CoreExpr -> CoreExpr
go t
0 CoreExpr
rhs = CoreExpr
rhs
go t
n (Lam CoreBndr
b CoreExpr
rhs) = CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam (if CoreBndr -> Bool
isId CoreBndr
b then CoreBndr -> CoreBndr
setOneShotLambda CoreBndr
b else CoreBndr
b)
(t -> CoreExpr -> CoreExpr
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) CoreExpr
rhs)
go t
_ CoreExpr
rhs = CoreExpr
rhs
markNonRecUnfoldingOneShots :: Maybe JoinArity -> Unfolding -> Unfolding
markNonRecUnfoldingOneShots :: Maybe JoinArity -> Unfolding -> Unfolding
markNonRecUnfoldingOneShots Maybe JoinArity
mb_join_arity Unfolding
unf
| Just JoinArity
ja <- Maybe JoinArity
mb_join_arity
, CoreUnfolding{uf_src :: Unfolding -> UnfoldingSource
uf_src=UnfoldingSource
src,uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl=CoreExpr
tmpl} <- Unfolding
unf
, UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
, let !tmpl' :: CoreExpr
tmpl' = JoinArity -> CoreExpr -> CoreExpr
markNonRecJoinOneShots JoinArity
ja CoreExpr
tmpl
= Unfolding
unf{uf_tmpl=tmpl'}
| Bool
otherwise
= Unfolding
unf
type IdWithOccInfo = Id
tagLamBinders :: UsageDetails
-> [Id]
-> (UsageDetails,
[IdWithOccInfo])
tagLamBinders :: UsageDetails -> [CoreBndr] -> (UsageDetails, [CoreBndr])
tagLamBinders UsageDetails
usage [CoreBndr]
binders
= UsageDetails
usage' UsageDetails
-> (UsageDetails, [CoreBndr]) -> (UsageDetails, [CoreBndr])
forall a b. a -> b -> b
`seq` (UsageDetails
usage', [CoreBndr]
bndrs')
where
(UsageDetails
usage', [CoreBndr]
bndrs') = (UsageDetails -> CoreBndr -> (UsageDetails, CoreBndr))
-> UsageDetails -> [CoreBndr] -> (UsageDetails, [CoreBndr])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumR UsageDetails -> CoreBndr -> (UsageDetails, CoreBndr)
tagLamBinder UsageDetails
usage [CoreBndr]
binders
tagLamBinder :: UsageDetails
-> Id
-> (UsageDetails,
IdWithOccInfo)
tagLamBinder :: UsageDetails -> CoreBndr -> (UsageDetails, CoreBndr)
tagLamBinder UsageDetails
usage CoreBndr
bndr
= (UsageDetails
usage2, CoreBndr
bndr')
where
occ :: OccInfo
occ = UsageDetails -> CoreBndr -> OccInfo
lookupDetails UsageDetails
usage CoreBndr
bndr
bndr' :: CoreBndr
bndr' = OccInfo -> CoreBndr -> CoreBndr
setBinderOcc (OccInfo -> OccInfo
markNonTail OccInfo
occ) CoreBndr
bndr
usage1 :: UsageDetails
usage1 = UsageDetails
usage UsageDetails -> CoreBndr -> UsageDetails
`delDetails` CoreBndr
bndr
usage2 :: UsageDetails
usage2 | CoreBndr -> Bool
isId CoreBndr
bndr = UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
usage1 (CoreBndr -> VarSet
idUnfoldingVars CoreBndr
bndr)
| Bool
otherwise = UsageDetails
usage1
tagNonRecBinder :: TopLevelFlag
-> UsageDetails
-> CoreBndr
-> WithUsageDetails
IdWithOccInfo
tagNonRecBinder :: TopLevelFlag
-> UsageDetails -> CoreBndr -> WithUsageDetails CoreBndr
tagNonRecBinder TopLevelFlag
lvl UsageDetails
usage CoreBndr
binder
= let
occ :: OccInfo
occ = UsageDetails -> CoreBndr -> OccInfo
lookupDetails UsageDetails
usage CoreBndr
binder
will_be_join :: Bool
will_be_join = TopLevelFlag -> UsageDetails -> NonEmpty CoreBndr -> Bool
decideJoinPointHood TopLevelFlag
lvl UsageDetails
usage (CoreBndr -> NonEmpty CoreBndr
forall a. a -> NonEmpty a
NE.singleton CoreBndr
binder)
occ' :: OccInfo
occ' | Bool
will_be_join =
Bool -> OccInfo -> OccInfo
forall a. HasCallStack => Bool -> a -> a
assert (OccInfo -> Bool
isAlwaysTailCalled OccInfo
occ) OccInfo
occ
| Bool
otherwise = OccInfo -> OccInfo
markNonTail OccInfo
occ
binder' :: CoreBndr
binder' = OccInfo -> CoreBndr -> CoreBndr
setBinderOcc OccInfo
occ' CoreBndr
binder
usage' :: UsageDetails
usage' = UsageDetails
usage UsageDetails -> CoreBndr -> UsageDetails
`delDetails` CoreBndr
binder
in
UsageDetails -> CoreBndr -> WithUsageDetails CoreBndr
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
usage' CoreBndr
binder'
tagRecBinders :: TopLevelFlag
-> UsageDetails
-> [NodeDetails]
-> WithUsageDetails
[IdWithOccInfo]
tagRecBinders :: TopLevelFlag
-> UsageDetails -> [NodeDetails] -> WithUsageDetails [CoreBndr]
tagRecBinders TopLevelFlag
lvl UsageDetails
body_uds [NodeDetails]
details_s
= let
bndrs :: [CoreBndr]
bndrs = (NodeDetails -> CoreBndr) -> [NodeDetails] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map NodeDetails -> CoreBndr
nd_bndr [NodeDetails]
details_s
unadj_uds :: UsageDetails
unadj_uds = (NodeDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [NodeDetails] -> UsageDetails
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (UsageDetails -> UsageDetails -> UsageDetails
andUDs (UsageDetails -> UsageDetails -> UsageDetails)
-> (NodeDetails -> UsageDetails)
-> NodeDetails
-> UsageDetails
-> UsageDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeDetails -> UsageDetails
test_manifest_arity) UsageDetails
body_uds [NodeDetails]
details_s
test_manifest_arity :: NodeDetails -> UsageDetails
test_manifest_arity ND{nd_rhs :: NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs=WithTailUsageDetails TailUsageDetails
tuds CoreExpr
rhs}
= Maybe JoinArity -> TailUsageDetails -> UsageDetails
adjustTailArity (JoinArity -> Maybe JoinArity
forall a. a -> Maybe a
Just (CoreExpr -> JoinArity
joinRhsArity CoreExpr
rhs)) TailUsageDetails
tuds
bndr_ne :: NonEmpty CoreBndr
bndr_ne = String -> [CoreBndr] -> NonEmpty CoreBndr
forall a. HasDebugCallStack => String -> [a] -> NonEmpty a
expectNonEmpty String
"List of binders is never empty" [CoreBndr]
bndrs
will_be_joins :: Bool
will_be_joins = TopLevelFlag -> UsageDetails -> NonEmpty CoreBndr -> Bool
decideJoinPointHood TopLevelFlag
lvl UsageDetails
unadj_uds NonEmpty CoreBndr
bndr_ne
mb_join_arity :: Id -> Maybe JoinArity
mb_join_arity :: CoreBndr -> Maybe JoinArity
mb_join_arity CoreBndr
bndr
| Bool
will_be_joins
, let occ :: OccInfo
occ = UsageDetails -> CoreBndr -> OccInfo
lookupDetails UsageDetails
unadj_uds CoreBndr
bndr
, AlwaysTailCalled JoinArity
arity <- OccInfo -> TailCallInfo
tailCallInfo OccInfo
occ
= JoinArity -> Maybe JoinArity
forall a. a -> Maybe a
Just JoinArity
arity
| Bool
otherwise
= Bool -> Maybe JoinArity -> Maybe JoinArity
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not Bool
will_be_joins)
Maybe JoinArity
forall a. Maybe a
Nothing
rhs_udss' :: [UsageDetails]
rhs_udss' = [ Maybe JoinArity -> CoreExpr -> TailUsageDetails -> UsageDetails
adjustTailUsage (CoreBndr -> Maybe JoinArity
mb_join_arity CoreBndr
bndr) CoreExpr
rhs TailUsageDetails
rhs_tuds
| ND { nd_bndr :: NodeDetails -> CoreBndr
nd_bndr = CoreBndr
bndr, nd_rhs :: NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs = WithTailUsageDetails TailUsageDetails
rhs_tuds CoreExpr
rhs }
<- [NodeDetails]
details_s ]
adj_uds :: UsageDetails
adj_uds = (UsageDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [UsageDetails] -> UsageDetails
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UsageDetails -> UsageDetails -> UsageDetails
andUDs UsageDetails
body_uds [UsageDetails]
rhs_udss'
bndrs' :: [CoreBndr]
bndrs' = [ OccInfo -> CoreBndr -> CoreBndr
setBinderOcc (UsageDetails -> CoreBndr -> OccInfo
lookupDetails UsageDetails
adj_uds CoreBndr
bndr) CoreBndr
bndr
| CoreBndr
bndr <- [CoreBndr]
bndrs ]
usage' :: UsageDetails
usage' = UsageDetails
adj_uds UsageDetails -> [CoreBndr] -> UsageDetails
`delDetailsList` [CoreBndr]
bndrs
in
UsageDetails -> [CoreBndr] -> WithUsageDetails [CoreBndr]
forall a. UsageDetails -> a -> WithUsageDetails a
WithUsageDetails UsageDetails
usage' [CoreBndr]
bndrs'
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc OccInfo
occ_info CoreBndr
bndr
| CoreBndr -> Bool
isTyVar CoreBndr
bndr = CoreBndr
bndr
| CoreBndr -> Bool
isExportedId CoreBndr
bndr = if OccInfo -> Bool
isManyOccs (CoreBndr -> OccInfo
idOccInfo CoreBndr
bndr)
then CoreBndr
bndr
else CoreBndr -> OccInfo -> CoreBndr
setIdOccInfo CoreBndr
bndr OccInfo
noOccInfo
| Bool
otherwise = CoreBndr -> OccInfo -> CoreBndr
setIdOccInfo CoreBndr
bndr OccInfo
occ_info
decideJoinPointHood :: TopLevelFlag -> UsageDetails
-> NonEmpty CoreBndr
-> Bool
decideJoinPointHood :: TopLevelFlag -> UsageDetails -> NonEmpty CoreBndr -> Bool
decideJoinPointHood TopLevelFlag
TopLevel UsageDetails
_ NonEmpty CoreBndr
_
= Bool
False
decideJoinPointHood TopLevelFlag
NotTopLevel UsageDetails
usage NonEmpty CoreBndr
bndrs
| CoreBndr -> Bool
isJoinId (NonEmpty CoreBndr -> CoreBndr
forall a. NonEmpty a -> a
NE.head NonEmpty CoreBndr
bndrs)
= Bool -> String -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not Bool
all_ok)
String
"OccurAnal failed to rediscover join point(s)" (NonEmpty CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr NonEmpty CoreBndr
bndrs)
Bool
all_ok
| Bool
otherwise
= Bool
all_ok
where
all_ok :: Bool
all_ok =
(CoreBndr -> Bool) -> NonEmpty CoreBndr -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreBndr -> Bool
ok NonEmpty CoreBndr
bndrs
ok :: CoreBndr -> Bool
ok CoreBndr
bndr
|
AlwaysTailCalled JoinArity
arity <- OccInfo -> TailCallInfo
tailCallInfo (UsageDetails -> CoreBndr -> OccInfo
lookupDetails UsageDetails
usage CoreBndr
bndr)
,
(CoreRule -> Bool) -> [CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (JoinArity -> CoreRule -> Bool
ok_rule JoinArity
arity) (CoreBndr -> [CoreRule]
idCoreRules CoreBndr
bndr)
, JoinArity -> Unfolding -> Bool
ok_unfolding JoinArity
arity (IdUnfoldingFun
realIdUnfolding CoreBndr
bndr)
, JoinArity -> Type -> Bool
isValidJoinPointType JoinArity
arity (CoreBndr -> Type
idType CoreBndr
bndr)
= Bool
True
| Bool
otherwise
= Bool
False
ok_rule :: JoinArity -> CoreRule -> Bool
ok_rule JoinArity
_ BuiltinRule{} = Bool
False
ok_rule JoinArity
join_arity (Rule { ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args })
= [CoreExpr]
args [CoreExpr] -> JoinArity -> Bool
forall a. [a] -> JoinArity -> Bool
`lengthIs` JoinArity
join_arity
ok_unfolding :: JoinArity -> Unfolding -> Bool
ok_unfolding JoinArity
join_arity (CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
rhs })
= Bool -> Bool
not (UnfoldingSource -> Bool
isStableSource UnfoldingSource
src Bool -> Bool -> Bool
&& JoinArity
join_arity JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
> CoreExpr -> JoinArity
joinRhsArity CoreExpr
rhs)
ok_unfolding JoinArity
_ (DFunUnfolding {})
= Bool
False
ok_unfolding JoinArity
_ Unfolding
_
= Bool
True
willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity
willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity
willBeJoinId_maybe CoreBndr
bndr
| CoreBndr -> Bool
isId CoreBndr
bndr
, AlwaysTailCalled JoinArity
arity <- OccInfo -> TailCallInfo
tailCallInfo (CoreBndr -> OccInfo
idOccInfo CoreBndr
bndr)
= JoinArity -> Maybe JoinArity
forall a. a -> Maybe a
Just JoinArity
arity
| Bool
otherwise
= CoreBndr -> Maybe JoinArity
isJoinId_maybe CoreBndr
bndr
markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo
markMany :: OccInfo -> OccInfo
markMany OccInfo
IAmDead = OccInfo
IAmDead
markMany OccInfo
occ = ManyOccs { occ_tail :: TailCallInfo
occ_tail = OccInfo -> TailCallInfo
occ_tail OccInfo
occ }
markInsideLam :: OccInfo -> OccInfo
markInsideLam occ :: OccInfo
occ@(OneOcc {}) = OccInfo
occ { occ_in_lam = IsInsideLam }
markInsideLam OccInfo
occ = OccInfo
occ
markNonTail :: OccInfo -> OccInfo
markNonTail OccInfo
IAmDead = OccInfo
IAmDead
markNonTail OccInfo
occ = OccInfo
occ { occ_tail = NoTailCallInfo }
addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
addOccInfo :: OccInfo -> OccInfo -> OccInfo
addOccInfo OccInfo
a1 OccInfo
a2 = Bool -> OccInfo -> OccInfo
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (OccInfo -> Bool
isDeadOcc OccInfo
a1 Bool -> Bool -> Bool
|| OccInfo -> Bool
isDeadOcc OccInfo
a2)) (OccInfo -> OccInfo) -> OccInfo -> OccInfo
forall a b. (a -> b) -> a -> b
$
ManyOccs { occ_tail :: TailCallInfo
occ_tail = OccInfo -> TailCallInfo
tailCallInfo OccInfo
a1 TailCallInfo -> TailCallInfo -> TailCallInfo
`andTailCallInfo`
OccInfo -> TailCallInfo
tailCallInfo OccInfo
a2 }
orOccInfo :: OccInfo -> OccInfo -> OccInfo
orOccInfo (OneOcc { occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
in_lam1
, occ_n_br :: OccInfo -> JoinArity
occ_n_br = JoinArity
nbr1
, occ_int_cxt :: OccInfo -> InterestingCxt
occ_int_cxt = InterestingCxt
int_cxt1
, occ_tail :: OccInfo -> TailCallInfo
occ_tail = TailCallInfo
tail1 })
(OneOcc { occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
in_lam2
, occ_n_br :: OccInfo -> JoinArity
occ_n_br = JoinArity
nbr2
, occ_int_cxt :: OccInfo -> InterestingCxt
occ_int_cxt = InterestingCxt
int_cxt2
, occ_tail :: OccInfo -> TailCallInfo
occ_tail = TailCallInfo
tail2 })
= OneOcc { occ_n_br :: JoinArity
occ_n_br = JoinArity
nbr1 JoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+ JoinArity
nbr2
, occ_in_lam :: InsideLam
occ_in_lam = InsideLam
in_lam1 InsideLam -> InsideLam -> InsideLam
forall a. Monoid a => a -> a -> a
`mappend` InsideLam
in_lam2
, occ_int_cxt :: InterestingCxt
occ_int_cxt = InterestingCxt
int_cxt1 InterestingCxt -> InterestingCxt -> InterestingCxt
forall a. Monoid a => a -> a -> a
`mappend` InterestingCxt
int_cxt2
, occ_tail :: TailCallInfo
occ_tail = TailCallInfo
tail1 TailCallInfo -> TailCallInfo -> TailCallInfo
`andTailCallInfo` TailCallInfo
tail2 }
orOccInfo OccInfo
a1 OccInfo
a2 = Bool -> OccInfo -> OccInfo
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (OccInfo -> Bool
isDeadOcc OccInfo
a1 Bool -> Bool -> Bool
|| OccInfo -> Bool
isDeadOcc OccInfo
a2)) (OccInfo -> OccInfo) -> OccInfo -> OccInfo
forall a b. (a -> b) -> a -> b
$
ManyOccs { occ_tail :: TailCallInfo
occ_tail = OccInfo -> TailCallInfo
tailCallInfo OccInfo
a1 TailCallInfo -> TailCallInfo -> TailCallInfo
`andTailCallInfo`
OccInfo -> TailCallInfo
tailCallInfo OccInfo
a2 }
andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo
andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo
andTailCallInfo info :: TailCallInfo
info@(AlwaysTailCalled JoinArity
arity1) (AlwaysTailCalled JoinArity
arity2)
| JoinArity
arity1 JoinArity -> JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
== JoinArity
arity2 = TailCallInfo
info
andTailCallInfo TailCallInfo
_ TailCallInfo
_ = TailCallInfo
NoTailCallInfo