{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -fmax-worker-args=12 #-}
module GHC.Core.Opt.OccurAnal (
occurAnalysePgm,
occurAnalyseExpr,
zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap
) 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( 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, isDeadEndSig )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
import Data.List (mapAccumL)
occurAnalyseExpr :: CoreExpr -> CoreExpr
occurAnalyseExpr :: CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
expr = CoreExpr
expr'
where
WUD UsageDetails
_ CoreExpr
expr' = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
initOccEnv CoreExpr
expr
occurAnalysePgm :: Module
-> (Id -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram -> CoreProgram
occurAnalysePgm :: Module
-> (Id -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm Module
this_mod Id -> 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 }
WUD UsageDetails
final_usage CoreProgram
occ_anald_binds = CoreProgram -> OccEnv -> WithUsageDetails CoreProgram
go CoreProgram
binds OccEnv
init_env
WUD UsageDetails
_ CoreProgram
occ_anald_glommed_binds = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(Id, CoreExpr)]
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalRecBind OccEnv
init_env TopLevelFlag
TopLevel
ImpRuleEdges
imp_rule_edges
(CoreProgram -> [(Id, 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
[ (Id -> [(Activation, VarSet)]) -> VarEnv Id -> ImpRuleEdges
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv ([(Activation, VarSet)] -> Id -> [(Activation, VarSet)]
forall a b. a -> b -> a
const [(Activation
act,VarSet
rhs_fvs)]) (VarEnv Id -> ImpRuleEdges) -> VarEnv Id -> ImpRuleEdges
forall a b. (a -> b) -> a -> b
$ VarSet -> VarEnv Id
forall a. UniqSet a -> UniqFM a a
getUniqSet (VarSet -> VarEnv Id) -> VarSet -> VarEnv Id
forall a b. (a -> b) -> a -> b
$
[CoreExpr] -> VarSet
exprsFreeIds [CoreExpr]
args VarSet -> [Id] -> VarSet
`delVarSetList` [Id]
bndrs
| Rule { ru_act :: CoreRule -> Activation
ru_act = Activation
act, ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
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 -> [Id] -> VarSet
`delVarSetList` [Id]
bndrs ]
go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind]
go :: CoreProgram -> OccEnv -> WithUsageDetails CoreProgram
go [] OccEnv
_ = UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
initial_uds []
go (CoreBind
bind:CoreProgram
binds) OccEnv
env = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> (OccEnv -> WithUsageDetails CoreProgram)
-> (CoreProgram -> CoreProgram -> CoreProgram)
-> WithUsageDetails CoreProgram
forall r.
OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> (OccEnv -> WithUsageDetails r)
-> (CoreProgram -> r -> r)
-> WithUsageDetails r
occAnalBind OccEnv
env TopLevelFlag
TopLevel
ImpRuleEdges
imp_rule_edges CoreBind
bind (CoreProgram -> OccEnv -> WithUsageDetails CoreProgram
go CoreProgram
binds) CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
(++)
type ImpRuleEdges = IdEnv [(Activation, VarSet)]
noImpRuleEdges :: ImpRuleEdges
noImpRuleEdges :: ImpRuleEdges
noImpRuleEdges = ImpRuleEdges
forall a. VarEnv a
emptyVarEnv
lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]
lookupImpRules :: ImpRuleEdges -> Id -> [(Activation, VarSet)]
lookupImpRules ImpRuleEdges
imp_rule_edges Id
bndr
= case ImpRuleEdges -> Id -> Maybe [(Activation, VarSet)]
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv ImpRuleEdges
imp_rule_edges Id
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
occAnalBind
:: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> (OccEnv -> WithUsageDetails r)
-> ([CoreBind] -> r -> r)
-> WithUsageDetails r
occAnalBind :: forall r.
OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> (OccEnv -> WithUsageDetails r)
-> (CoreProgram -> r -> r)
-> WithUsageDetails r
occAnalBind OccEnv
env TopLevelFlag
lvl ImpRuleEdges
ire (Rec [(Id, CoreExpr)]
pairs) OccEnv -> WithUsageDetails r
thing_inside CoreProgram -> r -> r
combine
= OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails r) -> WithUsageDetails r
forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeList OccEnv
env (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
pairs) ((OccEnv -> WithUsageDetails r) -> WithUsageDetails r)
-> (OccEnv -> WithUsageDetails r) -> WithUsageDetails r
forall a b. (a -> b) -> a -> b
$ \OccEnv
env ->
let WUD UsageDetails
body_uds r
body' = OccEnv -> WithUsageDetails r
thing_inside OccEnv
env
WUD UsageDetails
bind_uds CoreProgram
binds' = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(Id, CoreExpr)]
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalRecBind OccEnv
env TopLevelFlag
lvl ImpRuleEdges
ire [(Id, CoreExpr)]
pairs UsageDetails
body_uds
in UsageDetails -> r -> WithUsageDetails r
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
bind_uds (CoreProgram -> r -> r
combine CoreProgram
binds' r
body')
occAnalBind !OccEnv
env TopLevelFlag
lvl ImpRuleEdges
ire (NonRec Id
bndr CoreExpr
rhs) OccEnv -> WithUsageDetails r
thing_inside CoreProgram -> r -> r
combine
| Id -> Bool
isTyVar Id
bndr
= let !(WUD UsageDetails
body_uds r
res) = OccEnv
-> Id -> (OccEnv -> WithUsageDetails r) -> WithUsageDetails r
forall a.
OccEnv
-> Id -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeOne OccEnv
env Id
bndr OccEnv -> WithUsageDetails r
thing_inside
in UsageDetails -> r -> WithUsageDetails r
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
body_uds (CoreProgram -> r -> r
combine [Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CoreExpr
rhs] r
res)
| mb_join :: JoinPointHood
mb_join@(JoinPoint {}) <- Id -> JoinPointHood
idJoinPointHood Id
bndr
=
let
!([UsageDetails]
rhs_uds_s, Id
bndr', CoreExpr
rhs') = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> JoinPointHood
-> Id
-> CoreExpr
-> ([UsageDetails], Id, CoreExpr)
occAnalNonRecRhs OccEnv
env TopLevelFlag
lvl ImpRuleEdges
ire JoinPointHood
mb_join Id
bndr CoreExpr
rhs
rhs_uds :: UsageDetails
rhs_uds = (UsageDetails -> UsageDetails -> UsageDetails)
-> [UsageDetails] -> UsageDetails
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 UsageDetails -> UsageDetails -> UsageDetails
orUDs [UsageDetails]
rhs_uds_s
!(WUD UsageDetails
body_uds (OccInfo
occ, r
body)) = OccEnv
-> Id
-> (OccEnv -> WithUsageDetails r)
-> WithUsageDetails (OccInfo, r)
forall r.
OccEnv
-> Id
-> (OccEnv -> WithUsageDetails r)
-> WithUsageDetails (OccInfo, r)
occAnalNonRecBody OccEnv
env Id
bndr' ((OccEnv -> WithUsageDetails r) -> WithUsageDetails (OccInfo, r))
-> (OccEnv -> WithUsageDetails r) -> WithUsageDetails (OccInfo, r)
forall a b. (a -> b) -> a -> b
$ \OccEnv
env ->
OccEnv -> WithUsageDetails r
thing_inside (OccEnv -> Id -> UsageDetails -> OccEnv
addJoinPoint OccEnv
env Id
bndr' UsageDetails
rhs_uds)
in
if OccInfo -> Bool
isDeadOcc OccInfo
occ
then UsageDetails -> r -> WithUsageDetails r
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
body_uds r
body
else UsageDetails -> r -> WithUsageDetails r
forall a. UsageDetails -> a -> WithUsageDetails a
WUD (UsageDetails
rhs_uds UsageDetails -> UsageDetails -> UsageDetails
`orUDs` UsageDetails
body_uds)
(CoreProgram -> r -> r
combine [Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec ((Id, JoinPointHood) -> Id
forall a b. (a, b) -> a
fst (TopLevelFlag -> OccInfo -> Id -> (Id, JoinPointHood)
tagNonRecBinder TopLevelFlag
lvl OccInfo
occ Id
bndr')) CoreExpr
rhs']
r
body)
| WUD UsageDetails
body_uds (OccInfo
occ,r
body) <- OccEnv
-> Id
-> (OccEnv -> WithUsageDetails r)
-> WithUsageDetails (OccInfo, r)
forall r.
OccEnv
-> Id
-> (OccEnv -> WithUsageDetails r)
-> WithUsageDetails (OccInfo, r)
occAnalNonRecBody OccEnv
env Id
bndr OccEnv -> WithUsageDetails r
thing_inside
= if OccInfo -> Bool
isDeadOcc OccInfo
occ
then UsageDetails -> r -> WithUsageDetails r
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
body_uds r
body
else let
(Id
tagged_bndr, JoinPointHood
mb_join) = TopLevelFlag -> OccInfo -> Id -> (Id, JoinPointHood)
tagNonRecBinder TopLevelFlag
lvl OccInfo
occ Id
bndr
!([UsageDetails]
rhs_uds_s, Id
final_bndr, CoreExpr
rhs') = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> JoinPointHood
-> Id
-> CoreExpr
-> ([UsageDetails], Id, CoreExpr)
occAnalNonRecRhs OccEnv
env TopLevelFlag
lvl ImpRuleEdges
ire JoinPointHood
mb_join Id
tagged_bndr CoreExpr
rhs
in UsageDetails -> r -> WithUsageDetails r
forall a. UsageDetails -> a -> WithUsageDetails a
WUD ((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_uds_s)
(CoreProgram -> r -> r
combine [Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
final_bndr CoreExpr
rhs'] r
body)
occAnalNonRecBody :: OccEnv -> Id
-> (OccEnv -> WithUsageDetails r)
-> (WithUsageDetails (OccInfo, r))
occAnalNonRecBody :: forall r.
OccEnv
-> Id
-> (OccEnv -> WithUsageDetails r)
-> WithUsageDetails (OccInfo, r)
occAnalNonRecBody OccEnv
env Id
bndr OccEnv -> WithUsageDetails r
thing_inside
= OccEnv
-> Id
-> (OccEnv -> WithUsageDetails (OccInfo, r))
-> WithUsageDetails (OccInfo, r)
forall a.
OccEnv
-> Id -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeOne OccEnv
env Id
bndr ((OccEnv -> WithUsageDetails (OccInfo, r))
-> WithUsageDetails (OccInfo, r))
-> (OccEnv -> WithUsageDetails (OccInfo, r))
-> WithUsageDetails (OccInfo, r)
forall a b. (a -> b) -> a -> b
$ \OccEnv
env ->
let !(WUD UsageDetails
inner_uds r
res) = OccEnv -> WithUsageDetails r
thing_inside OccEnv
env
!occ :: OccInfo
occ = UsageDetails -> Id -> OccInfo
lookupLetOccInfo UsageDetails
inner_uds Id
bndr
in UsageDetails -> (OccInfo, r) -> WithUsageDetails (OccInfo, r)
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
inner_uds (OccInfo
occ, r
res)
occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges
-> JoinPointHood -> Id -> CoreExpr
-> ([UsageDetails], Id, CoreExpr)
occAnalNonRecRhs :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> JoinPointHood
-> Id
-> CoreExpr
-> ([UsageDetails], Id, CoreExpr)
occAnalNonRecRhs !OccEnv
env TopLevelFlag
lvl ImpRuleEdges
imp_rule_edges JoinPointHood
mb_join Id
bndr CoreExpr
rhs
| [CoreRule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules, [(Activation, VarSet)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Activation, VarSet)]
imp_rule_infos
=
( [UsageDetails
adj_rhs_uds, UsageDetails
adj_unf_uds], Id
final_bndr_no_rules, CoreExpr
final_rhs )
| Bool
otherwise
= (UsageDetails
adj_rhs_uds UsageDetails -> [UsageDetails] -> [UsageDetails]
forall a. a -> [a] -> [a]
: UsageDetails
adj_unf_uds UsageDetails -> [UsageDetails] -> [UsageDetails]
forall a. a -> [a] -> [a]
: [UsageDetails]
adj_rule_uds, Id
final_bndr_with_rules, CoreExpr
final_rhs )
where
rhs_env :: OccEnv
rhs_env = OccEnv
-> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv
mkRhsOccEnv OccEnv
env RecFlag
NonRecursive OccEncl
rhs_ctxt JoinPointHood
mb_join Id
bndr CoreExpr
rhs
rhs_ctxt :: OccEncl
rhs_ctxt = TopLevelFlag -> Id -> Unfolding -> OccEncl
mkNonRecRhsCtxt TopLevelFlag
lvl Id
bndr Unfolding
unf
WUD UsageDetails
adj_rhs_uds CoreExpr
final_rhs = JoinPointHood
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs JoinPointHood
mb_join (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
final_bndr_with_rules :: Id
final_bndr_with_rules
| OccEnv -> Bool
noBinderSwaps OccEnv
env = Id
bndr
| Bool
otherwise = Id
bndr Id -> RuleInfo -> Id
`setIdSpecialisation` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule]
rules'
Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
unf1
final_bndr_no_rules :: Id
final_bndr_no_rules
| OccEnv -> Bool
noBinderSwaps OccEnv
env = Id
bndr
| Bool
otherwise = Id
bndr Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
unf1
unf :: Unfolding
unf = IdUnfoldingFun
idUnfolding Id
bndr
WTUD TailUsageDetails
unf_tuds Unfolding
unf1 = OccEnv -> Unfolding -> WithTailUsageDetails Unfolding
occAnalUnfolding OccEnv
rhs_env Unfolding
unf
adj_unf_uds :: UsageDetails
adj_unf_uds = JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity JoinPointHood
mb_join TailUsageDetails
unf_tuds
rules :: [CoreRule]
rules = Id -> [CoreRule]
idCoreRules Id
bndr
rules_w_uds :: [(CoreRule, UsageDetails, TailUsageDetails)]
rules_w_uds = (CoreRule -> (CoreRule, UsageDetails, TailUsageDetails))
-> [CoreRule] -> [(CoreRule, UsageDetails, TailUsageDetails)]
forall a b. (a -> b) -> [a] -> [b]
map (OccEnv -> CoreRule -> (CoreRule, UsageDetails, TailUsageDetails)
occAnalRule OccEnv
rhs_env) [CoreRule]
rules
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_infos :: [(Activation, VarSet)]
imp_rule_infos = ImpRuleEdges -> Id -> [(Activation, VarSet)]
lookupImpRules ImpRuleEdges
imp_rule_edges Id
bndr
imp_rule_uds :: [UsageDetails]
imp_rule_uds = [[(Activation, VarSet)] -> UsageDetails
impRulesScopeUsage [(Activation, VarSet)]
imp_rule_infos]
adj_rule_uds :: [UsageDetails]
adj_rule_uds :: [UsageDetails]
adj_rule_uds = [UsageDetails]
imp_rule_uds [UsageDetails] -> [UsageDetails] -> [UsageDetails]
forall a. [a] -> [a] -> [a]
++
[ UsageDetails
l UsageDetails -> UsageDetails -> UsageDetails
`andUDs` JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity JoinPointHood
mb_join TailUsageDetails
r
| (CoreRule
_,UsageDetails
l,TailUsageDetails
r) <- [(CoreRule, UsageDetails, TailUsageDetails)]
rules_w_uds ]
mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl
mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl
mkNonRecRhsCtxt TopLevelFlag
lvl Id
bndr Unfolding
unf
| Bool
certainly_inline = OccEncl
OccVanilla
| Bool
otherwise = OccEncl
OccRhs
where
certainly_inline :: Bool
certainly_inline
=
case Id -> OccInfo
idOccInfo Id
bndr 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 -> Bool
not Bool
stable_unf Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
top_bottoming
OccInfo
_ -> Bool
False
active :: Bool
active = Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
bndr)
stable_unf :: Bool
stable_unf = Unfolding -> Bool
isStableUnfolding Unfolding
unf
top_bottoming :: Bool
top_bottoming = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
lvl Bool -> Bool -> Bool
&& Id -> Bool
isDeadEndId Id
bndr
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
-> UsageDetails -> WithUsageDetails [CoreBind]
occAnalRecBind :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(Id, CoreExpr)]
-> UsageDetails
-> WithUsageDetails CoreProgram
occAnalRecBind !OccEnv
rhs_env TopLevelFlag
lvl ImpRuleEdges
imp_rule_edges [(Id, 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
WUD UsageDetails
body_usage []) [SCC NodeDetails]
sccs
where
sccs :: [SCC NodeDetails]
sccs :: [SCC NodeDetails]
sccs = [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 = ((Id, CoreExpr) -> Node Unique NodeDetails)
-> [(Id, CoreExpr)] -> [Node Unique NodeDetails]
forall a b. (a -> b) -> [a] -> [b]
map (OccEnv
-> ImpRuleEdges
-> VarSet
-> (Id, CoreExpr)
-> Node Unique NodeDetails
makeNode OccEnv
rhs_env ImpRuleEdges
imp_rule_edges VarSet
bndr_set) [(Id, CoreExpr)]
pairs
bndrs :: [Id]
bndrs = ((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
pairs
bndr_set :: VarSet
bndr_set = [Id] -> VarSet
mkVarSet [Id]
bndrs
occAnalRec :: OccEnv -> TopLevelFlag
-> SCC NodeDetails
-> WithUsageDetails [CoreBind]
-> WithUsageDetails [CoreBind]
occAnalRec :: OccEnv
-> TopLevelFlag
-> SCC NodeDetails
-> WithUsageDetails CoreProgram
-> WithUsageDetails CoreProgram
occAnalRec !OccEnv
_ TopLevelFlag
lvl
(AcyclicSCC (ND { nd_bndr :: NodeDetails -> Id
nd_bndr = Id
bndr, nd_rhs :: NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs = WithTailUsageDetails CoreExpr
wtuds }))
(WUD UsageDetails
body_uds CoreProgram
binds)
| OccInfo -> Bool
isDeadOcc OccInfo
occ
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
body_uds CoreProgram
binds
| Bool
otherwise
= let (Id
bndr', JoinPointHood
mb_join) = TopLevelFlag -> OccInfo -> Id -> (Id, JoinPointHood)
tagNonRecBinder TopLevelFlag
lvl OccInfo
occ Id
bndr
!(WUD UsageDetails
rhs_uds' CoreExpr
rhs') = JoinPointHood
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs JoinPointHood
mb_join WithTailUsageDetails CoreExpr
wtuds
in UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WUD (UsageDetails
body_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
rhs_uds')
(Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' CoreExpr
rhs' CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
binds)
where
occ :: OccInfo
occ = UsageDetails -> Id -> OccInfo
lookupLetOccInfo UsageDetails
body_uds Id
bndr
occAnalRec OccEnv
env TopLevelFlag
lvl (CyclicSCC [NodeDetails]
details_s) (WUD UsageDetails
body_uds CoreProgram
binds)
| Bool -> Bool
not ((NodeDetails -> Bool) -> [NodeDetails] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NodeDetails -> Bool
needed [NodeDetails]
details_s)
=
UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
body_uds CoreProgram
binds
| Bool
otherwise
= UsageDetails -> CoreProgram -> WithUsageDetails CoreProgram
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
final_uds ([(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, 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
needed :: NodeDetails -> Bool
needed :: NodeDetails -> Bool
needed (ND { nd_bndr :: NodeDetails -> Id
nd_bndr = Id
bndr }) = Id -> Bool
isExportedId Id
bndr Bool -> Bool -> Bool
|| Id
bndr Id -> VarEnv LocalOcc -> Bool
forall a. Id -> VarEnv a -> Bool
`elemVarEnv` VarEnv LocalOcc
body_env
body_env :: VarEnv LocalOcc
body_env = UsageDetails -> VarEnv LocalOcc
ud_env UsageDetails
body_uds
final_uds :: UsageDetails
loop_breaker_nodes :: [LoopBreakerNode]
WUD 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 :: [(Id, CoreExpr)]
pairs | Bool
all_simple = JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
reOrderNodes JoinArity
0 VarSet
weak_fvs [LoopBreakerNode]
loop_breaker_nodes []
| Bool
otherwise = JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(Id, CoreExpr)]
-> [(Id, 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]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
loopBreakNodes JoinArity
depth VarSet
weak_fvs [LoopBreakerNode]
nodes [(Id, CoreExpr)]
binds
=
[SCC LoopBreakerNode] -> [(Id, CoreExpr)]
go ([LoopBreakerNode] -> [SCC LoopBreakerNode]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR [LoopBreakerNode]
nodes)
where
go :: [SCC LoopBreakerNode] -> [(Id, CoreExpr)]
go [] = [(Id, CoreExpr)]
binds
go (SCC LoopBreakerNode
scc:[SCC LoopBreakerNode]
sccs) = SCC LoopBreakerNode -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
loop_break_scc SCC LoopBreakerNode
scc ([SCC LoopBreakerNode] -> [(Id, CoreExpr)]
go [SCC LoopBreakerNode]
sccs)
loop_break_scc :: SCC LoopBreakerNode -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
loop_break_scc SCC LoopBreakerNode
scc [(Id, CoreExpr)]
binds
= case SCC LoopBreakerNode
scc of
AcyclicSCC LoopBreakerNode
node -> (Id -> Id) -> LoopBreakerNode -> (Id, CoreExpr)
nodeBinding (VarSet -> Id -> Id
mk_non_loop_breaker VarSet
weak_fvs) LoopBreakerNode
node (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
binds
CyclicSCC [LoopBreakerNode]
nodes -> JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
reOrderNodes JoinArity
depth VarSet
weak_fvs [LoopBreakerNode]
nodes [(Id, CoreExpr)]
binds
reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding]
reOrderNodes :: JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
reOrderNodes JoinArity
_ VarSet
_ [] [(Id, CoreExpr)]
_ = String -> [(Id, CoreExpr)]
forall a. HasCallStack => String -> a
panic String
"reOrderNodes"
reOrderNodes JoinArity
_ VarSet
_ [LoopBreakerNode
node] [(Id, CoreExpr)]
binds = (Id -> Id) -> LoopBreakerNode -> (Id, CoreExpr)
nodeBinding Id -> Id
mk_loop_breaker LoopBreakerNode
node (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
binds
reOrderNodes JoinArity
depth VarSet
weak_fvs (LoopBreakerNode
node : [LoopBreakerNode]
nodes) [(Id, CoreExpr)]
binds
=
JoinArity
-> VarSet
-> [LoopBreakerNode]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
loopBreakNodes JoinArity
new_depth VarSet
weak_fvs [LoopBreakerNode]
unchosen ([(Id, CoreExpr)] -> [(Id, CoreExpr)])
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a b. (a -> b) -> a -> b
$
((LoopBreakerNode -> (Id, CoreExpr))
-> [LoopBreakerNode] -> [(Id, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Id -> Id) -> LoopBreakerNode -> (Id, CoreExpr)
nodeBinding Id -> Id
mk_loop_breaker) [LoopBreakerNode]
chosen_nodes [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, 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 :: (Id -> Id) -> LoopBreakerNode -> (Id, CoreExpr)
nodeBinding Id -> Id
set_id_occ (LoopBreakerNode -> SimpleNodeDetails
forall key payload. Node key payload -> payload
node_payload -> SND { snd_bndr :: SimpleNodeDetails -> Id
snd_bndr = Id
bndr, snd_rhs :: SimpleNodeDetails -> CoreExpr
snd_rhs = CoreExpr
rhs})
= (Id -> Id
set_id_occ Id
bndr, CoreExpr
rhs)
mk_loop_breaker :: Id -> Id
mk_loop_breaker :: Id -> Id
mk_loop_breaker Id
bndr
= Id
bndr Id -> OccInfo -> Id
`setIdOccInfo` OccInfo
occ'
where
occ' :: OccInfo
occ' = OccInfo
strongLoopBreaker { occ_tail = tail_info }
tail_info :: TailCallInfo
tail_info = OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr)
mk_non_loop_breaker :: VarSet -> Id -> Id
mk_non_loop_breaker :: VarSet -> Id -> Id
mk_non_loop_breaker VarSet
weak_fvs Id
bndr
| Id
bndr Id -> VarSet -> Bool
`elemVarSet` VarSet
weak_fvs = Id -> OccInfo -> Id
setIdOccInfo Id
bndr OccInfo
occ'
| Bool
otherwise = Id
bndr
where
occ' :: OccInfo
occ' = OccInfo
weakLoopBreaker { occ_tail = tail_info }
tail_info :: TailCallInfo
tail_info = OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
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 -> Id
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
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (NodeDetails -> Id
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
WTUD TailUsageDetails
uds CoreExpr
_ = NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs NodeDetails
nd
type LoopBreakerNode = Node Unique SimpleNodeDetails
data SimpleNodeDetails
= SND { SimpleNodeDetails -> Id
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
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SimpleNodeDetails -> Id
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
-> (Id, CoreExpr)
-> Node Unique NodeDetails
makeNode !OccEnv
env ImpRuleEdges
imp_rule_edges VarSet
bndr_set (Id
bndr, CoreExpr
rhs)
=
DigraphNode { node_payload :: NodeDetails
node_payload = NodeDetails
details
, node_key :: Unique
node_key = Id -> Unique
varUnique Id
bndr
, node_dependencies :: [Unique]
node_dependencies = VarSet -> [Unique]
forall elt. UniqSet elt -> [Unique]
nonDetKeysUniqSet VarSet
scope_fvs }
where
details :: NodeDetails
details = ND { nd_bndr :: Id
nd_bndr = Id
bndr'
, nd_rhs :: WithTailUsageDetails CoreExpr
nd_rhs = TailUsageDetails -> CoreExpr -> WithTailUsageDetails CoreExpr
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WTUD (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
rhs_ja UsageDetails
unadj_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' :: Id
bndr' | OccEnv -> Bool
noBinderSwaps OccEnv
env = Id
bndr
| Bool
otherwise = Id
bndr Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
unf'
Id -> RuleInfo -> Id
`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_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
-> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv
mkRhsOccEnv OccEnv
env RecFlag
Recursive OccEncl
OccRhs (Id -> JoinPointHood
idJoinPointHood Id
bndr) Id
bndr CoreExpr
rhs
WTUD (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 Id
bndr
WTUD TailUsageDetails
unf_tuds Unfolding
unf' = OccEnv -> Unfolding -> WithTailUsageDetails Unfolding
occAnalUnfolding OccEnv
rhs_env Unfolding
unf
adj_unf_uds :: UsageDetails
adj_unf_uds = JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity (JoinArity -> JoinPointHood
JoinPoint 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 -> Id -> [(Activation, VarSet)]
lookupImpRules ImpRuleEdges
imp_rule_edges Id
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,JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity (JoinArity -> JoinPointHood
JoinPoint JoinArity
rhs_ja) TailUsageDetails
rhs_wuds)
| CoreRule
rule <- Id -> [CoreRule]
idCoreRules Id
bndr
, let (CoreRule
r,UsageDetails
l,TailUsageDetails
rhs_wuds) = OccEnv -> CoreRule -> (CoreRule, UsageDetails, TailUsageDetails)
occAnalRule OccEnv
rhs_env CoreRule
rule ]
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
WUD UsageDetails
final_uds (String
-> (NodeDetails -> Id -> LoopBreakerNode)
-> [NodeDetails]
-> [Id]
-> [LoopBreakerNode]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"mkLoopBreakerNodes" NodeDetails -> Id -> LoopBreakerNode
mk_lb_node [NodeDetails]
details_s [Id]
bndrs')
where
WUD UsageDetails
final_uds [Id]
bndrs' = TopLevelFlag
-> UsageDetails -> [NodeDetails] -> WithUsageDetails [Id]
tagRecBinders TopLevelFlag
lvl UsageDetails
body_uds [NodeDetails]
details_s
mk_lb_node :: NodeDetails -> Id -> LoopBreakerNode
mk_lb_node nd :: NodeDetails
nd@(ND { nd_bndr :: NodeDetails -> Id
nd_bndr = Id
old_bndr, nd_inl :: NodeDetails -> VarSet
nd_inl = VarSet
inl_fvs
, nd_rhs :: NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs = WTUD TailUsageDetails
_ CoreExpr
rhs }) Id
new_bndr
= DigraphNode { node_payload :: SimpleNodeDetails
node_payload = SimpleNodeDetails
simple_nd
, node_key :: Unique
node_key = Id -> Unique
varUnique Id
old_bndr
, node_dependencies :: [Unique]
node_dependencies = VarSet -> [Unique]
forall elt. UniqSet elt -> [Unique]
nonDetKeysUniqSet VarSet
lb_deps }
where
simple_nd :: SimpleNodeDetails
simple_nd = SND { snd_bndr :: Id
snd_bndr = Id
new_bndr, snd_rhs :: CoreExpr
snd_rhs = CoreExpr
rhs, snd_score :: NodeScore
snd_score = NodeScore
score }
score :: NodeScore
score = OccEnv -> Id -> VarSet -> NodeDetails -> NodeScore
nodeScore OccEnv
env Id
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
$ [(Id, VarSet)] -> VarEnv VarSet
forall a. [(Id, a)] -> VarEnv a
mkVarEnv ([(Id, VarSet)] -> VarEnv VarSet)
-> [(Id, VarSet)] -> VarEnv VarSet
forall a b. (a -> b) -> a -> b
$
[ (Id
b, VarSet
rule_fvs)
| ND { nd_bndr :: NodeDetails -> Id
nd_bndr = Id
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 -> Id -> VarSet -> NodeDetails -> NodeScore
nodeScore !OccEnv
env Id
new_bndr VarSet
lb_deps
(ND { nd_bndr :: NodeDetails -> Id
nd_bndr = Id
old_bndr, nd_rhs :: NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs = WTUD TailUsageDetails
_ CoreExpr
bind_rhs })
| Bool -> Bool
not (Id -> Bool
isId Id
old_bndr)
= (JoinArity
100, JoinArity
0, Bool
False)
| Id
old_bndr Id -> VarSet -> Bool
`elemVarSet` VarSet
lb_deps
= (JoinArity
0, JoinArity
0, Bool
True)
| Bool -> Bool
not (OccEnv -> Id -> Bool
occ_unf_act OccEnv
env Id
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 (Id -> OccInfo
idOccInfo Id
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 (Id -> OccInfo
idOccInfo Id
old_bndr)
old_unf :: Unfolding
old_unf = IdUnfoldingFun
realIdUnfolding Id
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 Id
v) = Id -> Bool
isConLikeId Id
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 Id
b CoreExpr
e)
| Id -> Bool
isTyVar Id
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 Id
_ Type
_ [Alt Id]
as) = JoinArity -> [CoreExpr] -> JoinArity
gos (JoinArity -> CoreExpr -> JoinArity
go1 JoinArity
n CoreExpr
e) ([Alt Id] -> [CoreExpr]
forall b. [Alt b] -> [Expr b]
rhssOfAlts [Alt Id]
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 Id
b CoreExpr
e) = Id -> Bool
isOneShotBndr Id
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 { e' <- JoinArity -> CoreExpr -> Maybe CoreExpr
zap JoinArity
n CoreExpr
e; return (Cast e' co) }
zap JoinArity
n (Lam Id
b CoreExpr
e) = do { e' <- JoinArity -> CoreExpr -> Maybe CoreExpr
zap (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
-JoinArity
1) CoreExpr
e
; return (Lam (zap_bndr b) e') }
zap JoinArity
_ CoreExpr
_ = Maybe CoreExpr
forall a. Maybe a
Nothing
zap_bndr :: Id -> Id
zap_bndr Id
b | Id -> Bool
isTyVar Id
b = Id
b
| Bool
otherwise = Id -> Id
zapLamIdInfo Id
b
occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env CoreExpr
expr
= let !(WUD UsageDetails
usage CoreExpr
expr') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occ_anal_lam_tail OccEnv
env CoreExpr
expr
in TailUsageDetails -> CoreExpr -> WithTailUsageDetails CoreExpr
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WTUD (JoinArity -> UsageDetails -> TailUsageDetails
TUD (CoreExpr -> JoinArity
joinRhsArity CoreExpr
expr) UsageDetails
usage) CoreExpr
expr'
occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occ_anal_lam_tail OccEnv
env expr :: CoreExpr
expr@(Lam {})
= OccEnv -> [Id] -> CoreExpr -> WithUsageDetails CoreExpr
go OccEnv
env [] CoreExpr
expr
where
go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr
go :: OccEnv -> [Id] -> CoreExpr -> WithUsageDetails CoreExpr
go OccEnv
env [Id]
rev_bndrs (Lam Id
bndr CoreExpr
body)
| Id -> Bool
isTyVar Id
bndr
= OccEnv -> [Id] -> CoreExpr -> WithUsageDetails CoreExpr
go OccEnv
env (Id
bndrId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
rev_bndrs) CoreExpr
body
| Bool
otherwise
= let ([OneShotInfo]
env_one_shots', Id
bndr')
= case OccEnv -> [OneShotInfo]
occ_one_shots OccEnv
env of
[] -> ([], Id
bndr)
(OneShotInfo
os : [OneShotInfo]
oss) -> ([OneShotInfo]
oss, Id -> OneShotInfo -> Id
updOneShotInfo Id
bndr OneShotInfo
os)
env' :: OccEnv
env' = OccEnv
env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
in OccEnv -> [Id] -> CoreExpr -> WithUsageDetails CoreExpr
go OccEnv
env' (Id
bndr'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
rev_bndrs) CoreExpr
body
go OccEnv
env [Id]
rev_bndrs CoreExpr
body
= OccEnv
-> [Id]
-> (OccEnv -> WithUsageDetails CoreExpr)
-> WithUsageDetails CoreExpr
forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScope OccEnv
env [Id]
rev_bndrs ((OccEnv -> WithUsageDetails CoreExpr)
-> WithUsageDetails CoreExpr)
-> (OccEnv -> WithUsageDetails CoreExpr)
-> WithUsageDetails CoreExpr
forall a b. (a -> b) -> a -> b
$ \OccEnv
env ->
let !(WUD UsageDetails
usage CoreExpr
body') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occ_anal_lam_tail OccEnv
env CoreExpr
body
wrap_lam :: CoreExpr -> Id -> CoreExpr
wrap_lam CoreExpr
body Id
bndr = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam (UsageDetails -> Id -> Id
tagLamBinder UsageDetails
usage Id
bndr) CoreExpr
body
in UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WUD (UsageDetails
usage UsageDetails -> [Id] -> UsageDetails
`addLamCoVarOccs` [Id]
rev_bndrs)
((CoreExpr -> Id -> CoreExpr) -> CoreExpr -> [Id] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CoreExpr -> Id -> CoreExpr
wrap_lam CoreExpr
body' [Id]
rev_bndrs)
occ_anal_lam_tail OccEnv
env (Cast CoreExpr
expr CoercionR
co)
= let WUD UsageDetails
usage CoreExpr
expr' = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occ_anal_lam_tail 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 UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
usage3 (CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
expr' CoercionR
co)
occ_anal_lam_tail OccEnv
env CoreExpr
expr
= OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env 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
WTUD (TUD JoinArity
rhs_ja UsageDetails
uds) CoreExpr
rhs' = OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
occAnalLamTail OccEnv
env CoreExpr
rhs
unf' :: Unfolding
unf' = Unfolding
unf { uf_tmpl = rhs' }
in TailUsageDetails -> Unfolding -> WithTailUsageDetails Unfolding
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WTUD (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
rhs_ja (UsageDetails -> UsageDetails
markAllMany UsageDetails
uds)) Unfolding
unf'
| Bool
otherwise -> TailUsageDetails -> Unfolding -> WithTailUsageDetails Unfolding
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WTUD (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
0 UsageDetails
emptyDetails) Unfolding
unf
unf :: Unfolding
unf@(DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args })
-> let WUD UsageDetails
uds [CoreExpr]
args' = OccEnv
-> [Id]
-> (OccEnv -> WithUsageDetails [CoreExpr])
-> WithUsageDetails [CoreExpr]
forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeList OccEnv
env [Id]
bndrs ((OccEnv -> WithUsageDetails [CoreExpr])
-> WithUsageDetails [CoreExpr])
-> (OccEnv -> WithUsageDetails [CoreExpr])
-> WithUsageDetails [CoreExpr]
forall a b. (a -> b) -> a -> b
$ \ OccEnv
env ->
OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
occAnalList OccEnv
env [CoreExpr]
args
in TailUsageDetails -> Unfolding -> WithTailUsageDetails Unfolding
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WTUD (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
0 UsageDetails
uds) (Unfolding
unf { df_args = args' })
Unfolding
unf -> TailUsageDetails -> Unfolding -> WithTailUsageDetails Unfolding
forall a. TailUsageDetails -> a -> WithTailUsageDetails a
WTUD (JoinArity -> UsageDetails -> TailUsageDetails
TUD JoinArity
0 UsageDetails
emptyDetails) Unfolding
unf
occAnalRule :: OccEnv
-> CoreRule
-> (CoreRule,
UsageDetails,
TailUsageDetails)
occAnalRule :: OccEnv -> CoreRule -> (CoreRule, UsageDetails, TailUsageDetails)
occAnalRule OccEnv
env rule :: CoreRule
rule@(Rule { ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
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
rule' :: CoreRule
rule' = CoreRule
rule { ru_args = args', ru_rhs = rhs' }
WUD UsageDetails
lhs_uds [CoreExpr]
args' = OccEnv
-> [Id]
-> (OccEnv -> WithUsageDetails [CoreExpr])
-> WithUsageDetails [CoreExpr]
forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeList OccEnv
env [Id]
bndrs ((OccEnv -> WithUsageDetails [CoreExpr])
-> WithUsageDetails [CoreExpr])
-> (OccEnv -> WithUsageDetails [CoreExpr])
-> WithUsageDetails [CoreExpr]
forall a b. (a -> b) -> a -> b
$ \OccEnv
env ->
OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
occAnalList OccEnv
env [CoreExpr]
args
lhs_uds' :: UsageDetails
lhs_uds' = UsageDetails -> UsageDetails
markAllManyNonTail UsageDetails
lhs_uds
WUD UsageDetails
rhs_uds CoreExpr
rhs' = OccEnv
-> [Id]
-> (OccEnv -> WithUsageDetails CoreExpr)
-> WithUsageDetails CoreExpr
forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeList OccEnv
env [Id]
bndrs ((OccEnv -> WithUsageDetails CoreExpr)
-> WithUsageDetails CoreExpr)
-> (OccEnv -> WithUsageDetails CoreExpr)
-> WithUsageDetails CoreExpr
forall a b. (a -> b) -> a -> b
$ \OccEnv
env ->
OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
rhs
rhs_uds' :: UsageDetails
rhs_uds' = UsageDetails -> UsageDetails
markAllMany UsageDetails
rhs_uds
rhs_ja :: JoinArity
rhs_ja = [CoreExpr] -> JoinArity
forall a. [a] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
length [CoreExpr]
args
occAnalRule OccEnv
_ 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
WUD UsageDetails
emptyDetails []
occAnalList OccEnv
env (CoreExpr
e:[CoreExpr]
es) = let
(WUD UsageDetails
uds1 CoreExpr
e') = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
e
(WUD UsageDetails
uds2 [CoreExpr]
es') = OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
occAnalList OccEnv
env [CoreExpr]
es
in UsageDetails -> [CoreExpr] -> WithUsageDetails [CoreExpr]
forall a. UsageDetails -> a -> WithUsageDetails a
WUD (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
WUD UsageDetails
emptyDetails CoreExpr
expr
occAnal OccEnv
env expr :: CoreExpr
expr@(Var Id
_) = 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
WUD (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
WUD (UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
emptyDetails (CoercionR -> VarSet
coVarsOfCo CoercionR
co)) CoreExpr
expr
occAnal OccEnv
env (Tick CoreTickish
tickish CoreExpr
body)
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
usage' (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
body')
where
WUD UsageDetails
usage CoreExpr
body' = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
body
usage' :: UsageDetails
usage'
| CoreTickish
tickish CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= UsageDetails
usage
| Breakpoint XBreakpoint 'TickishPassCore
_ JoinArity
_ [XTickishId 'TickishPassCore]
ids Module
_ <- CoreTickish
tickish
=
UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
usage_lam ([Id] -> VarSet
mkVarSet [Id]
[XTickishId 'TickishPassCore]
ids)
| Bool
otherwise
= UsageDetails
usage_lam
usage_lam :: UsageDetails
usage_lam = UsageDetails -> UsageDetails
markAllNonTail (UsageDetails -> UsageDetails
markAllInsideLam UsageDetails
usage)
occAnal OccEnv
env (Cast CoreExpr
expr CoercionR
co)
= let (WUD 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
WUD 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 {})
= JoinPointHood
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs JoinPointHood
NotJoinPoint (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 Id
bndr Type
ty [Alt Id]
alts)
= let
WUD UsageDetails
scrut_usage CoreExpr
scrut' = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal (OccEnv -> [Alt Id] -> OccEnv
setScrutCtxt OccEnv
env [Alt Id]
alts) CoreExpr
scrut
WUD UsageDetails
alts_usage (Id
tagged_bndr, [Alt Id]
alts')
= OccEnv
-> Id
-> (OccEnv -> WithUsageDetails (Id, [Alt Id]))
-> WithUsageDetails (Id, [Alt Id])
forall a.
OccEnv
-> Id -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeOne OccEnv
env Id
bndr ((OccEnv -> WithUsageDetails (Id, [Alt Id]))
-> WithUsageDetails (Id, [Alt Id]))
-> (OccEnv -> WithUsageDetails (Id, [Alt Id]))
-> WithUsageDetails (Id, [Alt Id])
forall a b. (a -> b) -> a -> b
$ \OccEnv
env ->
let alt_env :: OccEnv
alt_env = CoreExpr -> Id -> OccEnv -> OccEnv
addBndrSwap CoreExpr
scrut' Id
bndr (OccEnv -> OccEnv) -> OccEnv -> OccEnv
forall a b. (a -> b) -> a -> b
$
OccEnv -> OccEnv
setTailCtxt OccEnv
env
WUD UsageDetails
alts_usage [Alt Id]
alts' = OccEnv -> [Alt Id] -> WithUsageDetails [Alt Id]
do_alts OccEnv
alt_env [Alt Id]
alts
tagged_bndr :: Id
tagged_bndr = UsageDetails -> Id -> Id
tagLamBinder UsageDetails
alts_usage Id
bndr
in UsageDetails -> (Id, [Alt Id]) -> WithUsageDetails (Id, [Alt Id])
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
alts_usage (Id
tagged_bndr, [Alt Id]
alts')
total_usage :: UsageDetails
total_usage = UsageDetails -> UsageDetails
markAllNonTail UsageDetails
scrut_usage UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
alts_usage
in UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
total_usage (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' Id
tagged_bndr Type
ty [Alt Id]
alts')
where
do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]
do_alts :: OccEnv -> [Alt Id] -> WithUsageDetails [Alt Id]
do_alts OccEnv
_ [] = UsageDetails -> [Alt Id] -> WithUsageDetails [Alt Id]
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
emptyDetails []
do_alts OccEnv
env (Alt Id
alt:[Alt Id]
alts) = UsageDetails -> [Alt Id] -> WithUsageDetails [Alt Id]
forall a. UsageDetails -> a -> WithUsageDetails a
WUD (UsageDetails
uds1 UsageDetails -> UsageDetails -> UsageDetails
`orUDs` UsageDetails
uds2) (Alt Id
alt'Alt Id -> [Alt Id] -> [Alt Id]
forall a. a -> [a] -> [a]
:[Alt Id]
alts')
where
WUD UsageDetails
uds1 Alt Id
alt' = OccEnv -> Alt Id -> WithUsageDetails (Alt Id)
do_alt OccEnv
env Alt Id
alt
WUD UsageDetails
uds2 [Alt Id]
alts' = OccEnv -> [Alt Id] -> WithUsageDetails [Alt Id]
do_alts OccEnv
env [Alt Id]
alts
do_alt :: OccEnv -> Alt Id -> WithUsageDetails (Alt Id)
do_alt !OccEnv
env (Alt AltCon
con [Id]
bndrs CoreExpr
rhs)
= OccEnv
-> [Id]
-> (OccEnv -> WithUsageDetails (Alt Id))
-> WithUsageDetails (Alt Id)
forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeList OccEnv
env [Id]
bndrs ((OccEnv -> WithUsageDetails (Alt Id))
-> WithUsageDetails (Alt Id))
-> (OccEnv -> WithUsageDetails (Alt Id))
-> WithUsageDetails (Alt Id)
forall a b. (a -> b) -> a -> b
$ \ OccEnv
env ->
let WUD UsageDetails
rhs_usage CoreExpr
rhs' = OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
rhs
tagged_bndrs :: [Id]
tagged_bndrs = UsageDetails -> [Id] -> [Id]
tagLamBinders UsageDetails
rhs_usage [Id]
bndrs
in
UsageDetails -> Alt Id -> WithUsageDetails (Alt Id)
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
rhs_usage (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
tagged_bndrs CoreExpr
rhs')
occAnal OccEnv
env (Let CoreBind
bind CoreExpr
body)
= OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> (OccEnv -> WithUsageDetails CoreExpr)
-> (CoreProgram -> CoreExpr -> CoreExpr)
-> WithUsageDetails CoreExpr
forall r.
OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> (OccEnv -> WithUsageDetails r)
-> (CoreProgram -> r -> r)
-> WithUsageDetails r
occAnalBind OccEnv
env TopLevelFlag
NotTopLevel ImpRuleEdges
noImpRuleEdges CoreBind
bind
(\OccEnv
env -> OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occAnal OccEnv
env CoreExpr
body) CoreProgram -> CoreExpr -> CoreExpr
forall b. [Bind b] -> Expr b -> Expr b
mkLets
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
env_args :: OccEnv
env_args = OccEncl -> OccEnv -> OccEnv
setNonTailCtxt OccEncl
encl OccEnv
env
encl :: OccEncl
encl | Var Id
f <- CoreExpr
fun, DmdSig -> Bool
isDeadEndSig (Id -> DmdSig
idDmdSig Id
f) = OccEncl
OccScrut
| Bool
otherwise = OccEncl
OccVanilla
go :: UsageDetails
-> CoreExpr
-> [CoreExpr]
-> [[OneShotInfo]]
-> WithUsageDetails CoreExpr
go UsageDetails
uds CoreExpr
fun [] [[OneShotInfo]]
_ = UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WUD 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
!(WUD 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_args, [[OneShotInfo]]
one_shots)
| Bool
otherwise
= case [[OneShotInfo]]
one_shots of
[] -> (OccEnv
env_args, [])
([OneShotInfo]
os : [[OneShotInfo]]
one_shots') -> ([OneShotInfo] -> OccEnv -> OccEnv
setOneShots [OneShotInfo]
os OccEnv
env_args, [[OneShotInfo]]
one_shots')
occAnalApp :: OccEnv
-> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])
-> WithUsageDetails (Expr CoreBndr)
occAnalApp :: OccEnv
-> (CoreExpr, [CoreExpr], [CoreTickish])
-> WithUsageDetails CoreExpr
occAnalApp !OccEnv
env (Var Id
fun, [CoreExpr]
args, [CoreTickish]
ticks)
| Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
, [CoreExpr
t1, CoreExpr
t2, CoreExpr
arg] <- [CoreExpr]
args
, WUD UsageDetails
usage CoreExpr
arg' <- JoinPointHood
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs (JoinArity -> JoinPointHood
JoinPoint 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
WUD 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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fun) [CoreExpr
t1, CoreExpr
t2, CoreExpr
arg'])
occAnalApp OccEnv
env (Var Id
fun_id, [CoreExpr]
args, [CoreTickish]
ticks)
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
all_uds ([CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
ticks CoreExpr
app')
where
!(CoreExpr
fun', Id
fun_id') = OccEnv -> Id -> (CoreExpr, Id)
lookupBndrSwap OccEnv
env Id
fun_id
!(WUD 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 = OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
mkOneOcc OccEnv
env Id
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 Id
fun_id JoinArity
n_val_args
one_shots :: [[OneShotInfo]]
one_shots = DmdSig -> JoinArity -> [[OneShotInfo]]
argsOneShots (Id -> DmdSig
idDmdSig Id
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
WUD (UsageDetails -> UsageDetails
markAllNonTail (UsageDetails
fun_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
args_uds))
([CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
ticks CoreExpr
app')
where
!(WUD UsageDetails
args_uds CoreExpr
app') = OccEnv
-> CoreExpr
-> [CoreExpr]
-> [[OneShotInfo]]
-> WithUsageDetails CoreExpr
occAnalArgs OccEnv
env CoreExpr
fun' [CoreExpr]
args []
!(WUD 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 -> Id -> Bool
occ_unf_act :: Id -> Bool
, OccEnv -> Activation -> Bool
occ_rule_act :: Activation -> Bool
, OccEnv -> IdEnv (Id, MCoercion)
occ_bs_env :: !(IdEnv (OutId, MCoercion))
, OccEnv -> VarSet
occ_bs_rng :: !VarSet
, OccEnv -> JoinPointInfo
occ_join_points :: !JoinPointInfo
}
type JoinPointInfo = IdEnv OccInfoEnv
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 :: Id -> Bool
occ_unf_act = \Id
_ -> Bool
True
, occ_rule_act :: Activation -> Bool
occ_rule_act = \Activation
_ -> Bool
True
, occ_join_points :: JoinPointInfo
occ_join_points = JoinPointInfo
forall a. VarEnv a
emptyVarEnv
, occ_bs_env :: IdEnv (Id, MCoercion)
occ_bs_env = IdEnv (Id, 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 (Id, MCoercion)
occ_bs_env = IdEnv (Id, MCoercion)
bs_env }) = IdEnv (Id, MCoercion) -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv IdEnv (Id, MCoercion)
bs_env
setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv
setScrutCtxt :: OccEnv -> [Alt Id] -> OccEnv
setScrutCtxt !OccEnv
env [Alt Id]
alts
= OccEncl -> OccEnv -> OccEnv
setNonTailCtxt OccEncl
encl OccEnv
env
where
encl :: OccEncl
encl | Bool
interesting_alts = OccEncl
OccScrut
| Bool
otherwise = OccEncl
OccVanilla
interesting_alts :: Bool
interesting_alts = case [Alt Id]
alts of
[] -> Bool
False
[Alt Id
alt] -> Bool -> Bool
not (Alt Id -> Bool
forall b. Alt b -> Bool
isDefaultAlt Alt Id
alt)
[Alt Id]
_ -> Bool
True
setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv
setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv
setNonTailCtxt OccEncl
ctxt !OccEnv
env
= OccEnv
env { occ_encl = ctxt
, occ_one_shots = []
, occ_join_points = zapJoinPointInfo (occ_join_points env) }
setTailCtxt :: OccEnv -> OccEnv
setTailCtxt :: OccEnv -> OccEnv
setTailCtxt !OccEnv
env = OccEnv
env { occ_encl = OccVanilla }
mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv
mkRhsOccEnv :: OccEnv
-> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv
mkRhsOccEnv env :: OccEnv
env@(OccEnv { occ_one_shots :: OccEnv -> [OneShotInfo]
occ_one_shots = [OneShotInfo]
ctxt_one_shots, occ_join_points :: OccEnv -> JoinPointInfo
occ_join_points = JoinPointInfo
ctxt_join_points })
RecFlag
is_rec OccEncl
encl JoinPointHood
jp_hood Id
bndr CoreExpr
rhs
| JoinPoint JoinArity
join_arity <- JoinPointHood
jp_hood
= OccEnv
env { occ_encl = OccVanilla
, occ_one_shots = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots
, occ_join_points = ctxt_join_points }
| Bool
otherwise
= OccEnv
env { occ_encl = encl
, occ_one_shots = argOneShots (idDemandInfo bndr)
, occ_join_points = zapJoinPointInfo ctxt_join_points }
zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo
#ifdef DEBUG
zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info
#else
zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo
zapJoinPointInfo JoinPointInfo
_ = JoinPointInfo
forall a. VarEnv a
emptyVarEnv
#endif
extendOneShotsForJoinPoint
:: RecFlag -> JoinArity -> CoreExpr
-> [OneShotInfo] -> [OneShotInfo]
extendOneShotsForJoinPoint :: RecFlag -> JoinArity -> CoreExpr -> [OneShotInfo] -> [OneShotInfo]
extendOneShotsForJoinPoint RecFlag
is_rec JoinArity
join_arity CoreExpr
rhs [OneShotInfo]
ctxt_one_shots
= JoinArity -> CoreExpr -> [OneShotInfo]
go JoinArity
join_arity CoreExpr
rhs
where
os :: OneShotInfo
os = case RecFlag
is_rec of
RecFlag
NonRecursive -> OneShotInfo
OneShotLam
RecFlag
Recursive -> OneShotInfo
NoOneShotInfo
go :: JoinArity -> CoreExpr -> [OneShotInfo]
go JoinArity
0 CoreExpr
_ = [OneShotInfo]
ctxt_one_shots
go JoinArity
n (Lam Id
b CoreExpr
rhs)
| Id -> Bool
isId Id
b = OneShotInfo
os OneShotInfo -> [OneShotInfo] -> [OneShotInfo]
forall a. a -> [a] -> [a]
: JoinArity -> CoreExpr -> [OneShotInfo]
go (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
-JoinArity
1) CoreExpr
rhs
| Bool
otherwise = JoinArity -> CoreExpr -> [OneShotInfo]
go (JoinArity
nJoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
-JoinArity
1) CoreExpr
rhs
go JoinArity
_ CoreExpr
_ = []
setOneShots :: OneShots -> OccEnv -> OccEnv
setOneShots :: [OneShotInfo] -> OccEnv -> OccEnv
setOneShots [OneShotInfo]
os !OccEnv
env
| [OneShotInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OneShotInfo]
os = OccEnv
env
| Bool
otherwise = OccEnv
env { occ_one_shots = os }
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
addInScopeList :: OccEnv -> [Var]
-> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
{-# INLINE addInScopeList #-}
addInScopeList :: forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeList OccEnv
env [Id]
bndrs OccEnv -> WithUsageDetails a
thing_inside
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs = OccEnv -> WithUsageDetails a
thing_inside OccEnv
env
| Bool
otherwise = OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScope OccEnv
env [Id]
bndrs OccEnv -> WithUsageDetails a
thing_inside
addInScopeOne :: OccEnv -> Id
-> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
{-# INLINE addInScopeOne #-}
addInScopeOne :: forall a.
OccEnv
-> Id -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScopeOne OccEnv
env Id
bndr = OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScope OccEnv
env [Id
bndr]
addInScope :: OccEnv -> [Var]
-> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
{-# INLINE addInScope #-}
addInScope :: forall a.
OccEnv
-> [Id] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
addInScope OccEnv
env [Id]
bndrs OccEnv -> WithUsageDetails a
thing_inside
| IdEnv (Id, MCoercion) -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv (OccEnv -> IdEnv (Id, MCoercion)
occ_bs_env OccEnv
env)
, JoinPointInfo -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv (OccEnv -> JoinPointInfo
occ_join_points OccEnv
env)
, WUD UsageDetails
uds a
res <- OccEnv -> WithUsageDetails a
thing_inside OccEnv
env
= UsageDetails -> a -> WithUsageDetails a
forall a. UsageDetails -> a -> WithUsageDetails a
WUD ([Id] -> UsageDetails -> UsageDetails
delBndrsFromUDs [Id]
bndrs UsageDetails
uds) a
res
addInScope OccEnv
env [Id]
bndrs OccEnv -> WithUsageDetails a
thing_inside
= UsageDetails -> a -> WithUsageDetails a
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
uds' a
res
where
bndr_set :: VarSet
bndr_set = [Id] -> VarSet
mkVarSet [Id]
bndrs
!(OccEnv
env', JoinPointInfo
bad_joins) = OccEnv -> VarSet -> (OccEnv, JoinPointInfo)
preprocess_env OccEnv
env VarSet
bndr_set
!(WUD UsageDetails
uds a
res) = OccEnv -> WithUsageDetails a
thing_inside OccEnv
env'
uds' :: UsageDetails
uds' = [Id] -> JoinPointInfo -> UsageDetails -> UsageDetails
postprocess_uds [Id]
bndrs JoinPointInfo
bad_joins UsageDetails
uds
preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)
preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)
preprocess_env env :: OccEnv
env@(OccEnv { occ_join_points :: OccEnv -> JoinPointInfo
occ_join_points = JoinPointInfo
join_points
, occ_bs_rng :: OccEnv -> VarSet
occ_bs_rng = VarSet
bs_rng_vars })
VarSet
bndr_set
| Bool
bad_joins = (OccEnv -> OccEnv
drop_shadowed_swaps (OccEnv -> OccEnv
drop_shadowed_joins OccEnv
env), JoinPointInfo
join_points)
| Bool
otherwise = (OccEnv -> OccEnv
drop_shadowed_swaps OccEnv
env, JoinPointInfo
forall a. VarEnv a
emptyVarEnv)
where
drop_shadowed_swaps :: OccEnv -> OccEnv
drop_shadowed_swaps :: OccEnv -> OccEnv
drop_shadowed_swaps env :: OccEnv
env@(OccEnv { occ_bs_env :: OccEnv -> IdEnv (Id, MCoercion)
occ_bs_env = IdEnv (Id, MCoercion)
swap_env })
| IdEnv (Id, MCoercion) -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv IdEnv (Id, MCoercion)
swap_env
= OccEnv
env
| VarSet
bs_rng_vars VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
bndr_set
= OccEnv
env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
| Bool
otherwise
= OccEnv
env { occ_bs_env = swap_env `minusUFM` bndr_fm }
drop_shadowed_joins :: OccEnv -> OccEnv
drop_shadowed_joins :: OccEnv -> OccEnv
drop_shadowed_joins OccEnv
env = OccEnv
env { occ_join_points = emptyVarEnv }
bad_joins :: Bool
bad_joins :: Bool
bad_joins = (Unique -> VarEnv LocalOcc -> Bool -> Bool)
-> Bool -> JoinPointInfo -> Bool
forall a r. (Unique -> a -> r -> r) -> r -> VarEnv a -> r
nonDetStrictFoldVarEnv_Directly Unique -> VarEnv LocalOcc -> Bool -> Bool
is_bad Bool
False JoinPointInfo
join_points
bndr_fm :: UniqFM Var Var
bndr_fm :: VarEnv Id
bndr_fm = VarSet -> VarEnv Id
forall a. UniqSet a -> UniqFM a a
getUniqSet VarSet
bndr_set
is_bad :: Unique -> OccInfoEnv -> Bool -> Bool
is_bad :: Unique -> VarEnv LocalOcc -> Bool -> Bool
is_bad Unique
uniq VarEnv LocalOcc
join_uds Bool
rest
= Unique
uniq Unique -> VarSet -> Bool
forall a. Unique -> UniqSet a -> Bool
`elemUniqSet_Directly` VarSet
bndr_set Bool -> Bool -> Bool
||
Bool -> Bool
not (VarEnv Id
bndr_fm VarEnv Id -> VarEnv LocalOcc -> Bool
forall {k} (key :: k) elt1 elt2.
UniqFM key elt1 -> UniqFM key elt2 -> Bool
`disjointUFM` VarEnv LocalOcc
join_uds) Bool -> Bool -> Bool
||
Bool
rest
postprocess_uds :: [Var] -> JoinPointInfo -> UsageDetails -> UsageDetails
postprocess_uds :: [Id] -> JoinPointInfo -> UsageDetails -> UsageDetails
postprocess_uds [Id]
bndrs JoinPointInfo
bad_joins UsageDetails
uds
= UsageDetails -> UsageDetails
add_bad_joins ([Id] -> UsageDetails -> UsageDetails
delBndrsFromUDs [Id]
bndrs UsageDetails
uds)
where
add_bad_joins :: UsageDetails -> UsageDetails
add_bad_joins :: UsageDetails -> UsageDetails
add_bad_joins UsageDetails
uds
| JoinPointInfo -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv JoinPointInfo
bad_joins = UsageDetails
uds
| Bool
otherwise = (VarEnv LocalOcc -> VarEnv LocalOcc)
-> UsageDetails -> UsageDetails
modifyUDEnv VarEnv LocalOcc -> VarEnv LocalOcc
extend_with_bad_joins UsageDetails
uds
extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv
extend_with_bad_joins :: VarEnv LocalOcc -> VarEnv LocalOcc
extend_with_bad_joins VarEnv LocalOcc
env
= (Unique -> VarEnv LocalOcc -> VarEnv LocalOcc -> VarEnv LocalOcc)
-> VarEnv LocalOcc -> JoinPointInfo -> VarEnv LocalOcc
forall {k} elt a (key :: k).
(Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a
nonDetStrictFoldUFM_Directly Unique -> VarEnv LocalOcc -> VarEnv LocalOcc -> VarEnv LocalOcc
add_bad_join VarEnv LocalOcc
env JoinPointInfo
bad_joins
add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv
add_bad_join :: Unique -> VarEnv LocalOcc -> VarEnv LocalOcc -> VarEnv LocalOcc
add_bad_join Unique
uniq VarEnv LocalOcc
join_env VarEnv LocalOcc
env
| Unique
uniq Unique -> VarEnv LocalOcc -> Bool
forall a. Unique -> VarEnv a -> Bool
`elemVarEnvByKey` VarEnv LocalOcc
env = (LocalOcc -> LocalOcc -> LocalOcc)
-> VarEnv LocalOcc -> VarEnv LocalOcc -> VarEnv LocalOcc
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C LocalOcc -> LocalOcc -> LocalOcc
andLocalOcc VarEnv LocalOcc
env VarEnv LocalOcc
join_env
| Bool
otherwise = VarEnv LocalOcc
env
addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv
addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv
addJoinPoint OccEnv
env Id
bndr UsageDetails
rhs_uds
| VarEnv LocalOcc -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarEnv LocalOcc
zeroed_form
= OccEnv
env
| Bool
otherwise
= OccEnv
env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form }
where
zeroed_form :: VarEnv LocalOcc
zeroed_form = UsageDetails -> VarEnv LocalOcc
mkZeroedForm UsageDetails
rhs_uds
mkZeroedForm :: UsageDetails -> OccInfoEnv
mkZeroedForm :: UsageDetails -> VarEnv LocalOcc
mkZeroedForm (UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
rhs_occs })
= (LocalOcc -> Maybe LocalOcc) -> VarEnv LocalOcc -> VarEnv LocalOcc
forall {k} elt1 elt2 (key :: k).
(elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapMaybeUFM LocalOcc -> Maybe LocalOcc
do_one VarEnv LocalOcc
rhs_occs
where
do_one :: LocalOcc -> Maybe LocalOcc
do_one :: LocalOcc -> Maybe LocalOcc
do_one (ManyOccL {}) = Maybe LocalOcc
forall a. Maybe a
Nothing
do_one occ :: LocalOcc
occ@(OneOccL {}) = LocalOcc -> Maybe LocalOcc
forall a. a -> Maybe a
Just (LocalOcc
occ { lo_n_br = 0 })
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 {k} elt (key :: k). [(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 {k} (key :: k) 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 {k} (key :: k) 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 {k} elt a (key :: k).
(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 -> Id -> VarSet)
-> VarEnv VarSet -> VarEnv Id -> VarEnv VarSet
forall {k} elt1 elt2 elt3 (key :: k).
(elt1 -> elt2 -> elt3)
-> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt3
intersectUFM_C (\VarSet
x Id
_ -> VarSet
x) VarEnv VarSet
env (VarSet -> VarEnv Id
forall a. UniqSet a -> UniqFM a a
getUniqSet VarSet
s)
addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
addBndrSwap :: CoreExpr -> Id -> OccEnv -> OccEnv
addBndrSwap CoreExpr
scrut Id
case_bndr
env :: OccEnv
env@(OccEnv { occ_bs_env :: OccEnv -> IdEnv (Id, MCoercion)
occ_bs_env = IdEnv (Id, MCoercion)
swap_env, occ_bs_rng :: OccEnv -> VarSet
occ_bs_rng = VarSet
rng_vars })
| DoBinderSwap Id
scrut_var MCoercion
mco <- CoreExpr -> BinderSwapDecision
scrutOkForBinderSwap CoreExpr
scrut
, Id
scrut_var Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
/= Id
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' :: Id
case_bndr' = Id -> Id
zapIdOccInfo Id
case_bndr
data BinderSwapDecision
= NoBinderSwap
| DoBinderSwap OutVar MCoercion
scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision
scrutOkForBinderSwap :: CoreExpr -> BinderSwapDecision
scrutOkForBinderSwap (Var Id
v) = Id -> MCoercion -> BinderSwapDecision
DoBinderSwap Id
v MCoercion
MRefl
scrutOkForBinderSwap (Cast (Var Id
v) CoercionR
co)
| Bool -> Bool
not (Id -> Bool
isDictId Id
v) = Id -> MCoercion -> BinderSwapDecision
DoBinderSwap Id
v (CoercionR -> MCoercion
MCo (CoercionR -> CoercionR
mkSymCo CoercionR
co))
scrutOkForBinderSwap (Tick CoreTickish
_ CoreExpr
e) = CoreExpr -> BinderSwapDecision
scrutOkForBinderSwap CoreExpr
e
scrutOkForBinderSwap CoreExpr
_ = BinderSwapDecision
NoBinderSwap
lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
lookupBndrSwap env :: OccEnv
env@(OccEnv { occ_bs_env :: OccEnv -> IdEnv (Id, MCoercion)
occ_bs_env = IdEnv (Id, MCoercion)
bs_env }) Id
bndr
= case IdEnv (Id, MCoercion) -> Id -> Maybe (Id, MCoercion)
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv (Id, MCoercion)
bs_env Id
bndr of {
Maybe (Id, MCoercion)
Nothing -> (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bndr, Id
bndr) ;
Just (Id
bndr1, MCoercion
mco) ->
case OccEnv -> Id -> (CoreExpr, Id)
lookupBndrSwap OccEnv
env Id
bndr1 of
(CoreExpr
fun, Id
fun_id) -> (CoreExpr -> MCoercion -> CoreExpr
mkCastMCo CoreExpr
fun MCoercion
mco, Id
fun_id) }
type OccInfoEnv = IdEnv LocalOcc
data LocalOcc
= OneOccL { LocalOcc -> JoinArity
lo_n_br :: {-# UNPACK #-} !BranchCount
, LocalOcc -> TailCallInfo
lo_tail :: !TailCallInfo
, LocalOcc -> InterestingCxt
lo_int_cxt :: !InterestingCxt }
| ManyOccL !TailCallInfo
instance Outputable LocalOcc where
ppr :: LocalOcc -> SDoc
ppr (OneOccL { lo_n_br :: LocalOcc -> JoinArity
lo_n_br = JoinArity
n, lo_tail :: LocalOcc -> TailCallInfo
lo_tail = TailCallInfo
tci })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"OneOccL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (JoinArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr JoinArity
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TailCallInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TailCallInfo
tci)
ppr (ManyOccL TailCallInfo
tci) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ManyOccL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (TailCallInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TailCallInfo
tci)
localTailCallInfo :: LocalOcc -> TailCallInfo
localTailCallInfo :: LocalOcc -> TailCallInfo
localTailCallInfo (OneOccL { lo_tail :: LocalOcc -> TailCallInfo
lo_tail = TailCallInfo
tci }) = TailCallInfo
tci
localTailCallInfo (ManyOccL TailCallInfo
tci) = TailCallInfo
tci
type ZappedSet = OccInfoEnv
data UsageDetails
= UD { UsageDetails -> VarEnv LocalOcc
ud_env :: !OccInfoEnv
, UsageDetails -> VarEnv LocalOcc
ud_z_many :: !ZappedSet
, UsageDetails -> VarEnv LocalOcc
ud_z_in_lam :: !ZappedSet
, UsageDetails -> VarEnv LocalOcc
ud_z_tail :: !ZappedSet
}
instance Outputable UsageDetails where
ppr :: UsageDetails -> SDoc
ppr ud :: UsageDetails
ud@(UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env, ud_z_tail :: UsageDetails -> VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc
z_tail })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UD" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
[ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
uq SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
":->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UsageDetails -> Unique -> OccInfo
lookupOccInfoByUnique UsageDetails
ud Unique
uq)
| (Unique
uq, LocalOcc
_) <- (Unique
-> LocalOcc -> [(Unique, LocalOcc)] -> [(Unique, LocalOcc)])
-> [(Unique, LocalOcc)] -> VarEnv LocalOcc -> [(Unique, LocalOcc)]
forall a r. (Unique -> a -> r -> r) -> r -> VarEnv a -> r
nonDetStrictFoldVarEnv_Directly Unique -> LocalOcc -> [(Unique, LocalOcc)] -> [(Unique, LocalOcc)]
do_one [] VarEnv LocalOcc
env ])
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ JoinArity -> SDoc -> SDoc
nest JoinArity
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ud_z_tail" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarEnv LocalOcc -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarEnv LocalOcc
z_tail)
where
do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)]
do_one :: Unique -> LocalOcc -> [(Unique, LocalOcc)] -> [(Unique, LocalOcc)]
do_one Unique
uniq LocalOcc
occ [(Unique, LocalOcc)]
occs = (Unique
uniq, LocalOcc
occ) (Unique, LocalOcc) -> [(Unique, LocalOcc)] -> [(Unique, LocalOcc)]
forall a. a -> [a] -> [a]
: [(Unique, LocalOcc)]
occs
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
data WithUsageDetails a = WUD !UsageDetails !a
data WithTailUsageDetails a = WTUD !TailUsageDetails !a
andUDs, orUDs
:: UsageDetails -> UsageDetails -> UsageDetails
andUDs :: UsageDetails -> UsageDetails -> UsageDetails
andUDs = (LocalOcc -> LocalOcc -> LocalOcc)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith LocalOcc -> LocalOcc -> LocalOcc
andLocalOcc
orUDs :: UsageDetails -> UsageDetails -> UsageDetails
orUDs = (LocalOcc -> LocalOcc -> LocalOcc)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith LocalOcc -> LocalOcc -> LocalOcc
orLocalOcc
mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
mkOneOcc !OccEnv
env Id
id InterestingCxt
int_cxt JoinArity
arity
| Bool -> Bool
not (Id -> Bool
isLocalId Id
id)
= UsageDetails
emptyDetails
| Just VarEnv LocalOcc
join_uds <- JoinPointInfo -> Id -> Maybe (VarEnv LocalOcc)
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (OccEnv -> JoinPointInfo
occ_join_points OccEnv
env) Id
id
=
Bool -> SDoc -> UsageDetails -> UsageDetails
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (VarEnv LocalOcc -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarEnv LocalOcc
join_uds)) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id) (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$
VarEnv LocalOcc -> UsageDetails
mkSimpleDetails (VarEnv LocalOcc -> Id -> LocalOcc -> VarEnv LocalOcc
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv LocalOcc
join_uds Id
id LocalOcc
occ)
| Bool
otherwise
= VarEnv LocalOcc -> UsageDetails
mkSimpleDetails (Id -> LocalOcc -> VarEnv LocalOcc
forall a. Id -> a -> VarEnv a
unitVarEnv Id
id LocalOcc
occ)
where
occ :: LocalOcc
occ = OneOccL { lo_n_br :: JoinArity
lo_n_br = JoinArity
1, lo_int_cxt :: InterestingCxt
lo_int_cxt = InterestingCxt
int_cxt
, lo_tail :: TailCallInfo
lo_tail = JoinArity -> TailCallInfo
AlwaysTailCalled JoinArity
arity }
add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv
add_many_occ :: Id -> VarEnv LocalOcc -> VarEnv LocalOcc
add_many_occ Id
v VarEnv LocalOcc
env | Id -> Bool
isId Id
v = VarEnv LocalOcc -> Id -> LocalOcc -> VarEnv LocalOcc
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv LocalOcc
env Id
v (TailCallInfo -> LocalOcc
ManyOccL TailCallInfo
NoTailCallInfo)
| Bool
otherwise = VarEnv LocalOcc
env
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
addManyOccs UsageDetails
uds VarSet
var_set
| VarSet -> Bool
isEmptyVarSet VarSet
var_set = UsageDetails
uds
| Bool
otherwise = UsageDetails
uds { ud_env = add_to (ud_env uds) }
where
add_to :: VarEnv LocalOcc -> VarEnv LocalOcc
add_to VarEnv LocalOcc
env = (Id -> VarEnv LocalOcc -> VarEnv LocalOcc)
-> VarEnv LocalOcc -> VarSet -> VarEnv LocalOcc
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet Id -> VarEnv LocalOcc -> VarEnv LocalOcc
add_many_occ VarEnv LocalOcc
env VarSet
var_set
addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
addLamCoVarOccs :: UsageDetails -> [Id] -> UsageDetails
addLamCoVarOccs UsageDetails
uds [Id]
bndrs
= (Id -> UsageDetails -> UsageDetails)
-> UsageDetails -> [Id] -> UsageDetails
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> UsageDetails -> UsageDetails
add UsageDetails
uds [Id]
bndrs
where
add :: Id -> UsageDetails -> UsageDetails
add Id
bndr UsageDetails
uds = UsageDetails
uds UsageDetails -> VarSet -> UsageDetails
`addManyOccs` Type -> VarSet
coVarsOfType (Id -> Type
varType Id
bndr)
emptyDetails :: UsageDetails
emptyDetails :: UsageDetails
emptyDetails = VarEnv LocalOcc -> UsageDetails
mkSimpleDetails VarEnv LocalOcc
forall a. VarEnv a
emptyVarEnv
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails (UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env }) = VarEnv LocalOcc -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarEnv LocalOcc
env
mkSimpleDetails :: OccInfoEnv -> UsageDetails
mkSimpleDetails :: VarEnv LocalOcc -> UsageDetails
mkSimpleDetails VarEnv LocalOcc
env = UD { ud_env :: VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env
, ud_z_many :: VarEnv LocalOcc
ud_z_many = VarEnv LocalOcc
forall a. VarEnv a
emptyVarEnv
, ud_z_in_lam :: VarEnv LocalOcc
ud_z_in_lam = VarEnv LocalOcc
forall a. VarEnv a
emptyVarEnv
, ud_z_tail :: VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc
forall a. VarEnv a
emptyVarEnv }
modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails
modifyUDEnv :: (VarEnv LocalOcc -> VarEnv LocalOcc)
-> UsageDetails -> UsageDetails
modifyUDEnv VarEnv LocalOcc -> VarEnv LocalOcc
f uds :: UsageDetails
uds@(UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env }) = UsageDetails
uds { ud_env = f env }
delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails
delBndrsFromUDs :: [Id] -> UsageDetails -> UsageDetails
delBndrsFromUDs [Id]
bndrs (UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env, ud_z_many :: UsageDetails -> VarEnv LocalOcc
ud_z_many = VarEnv LocalOcc
z_many
, ud_z_in_lam :: UsageDetails -> VarEnv LocalOcc
ud_z_in_lam = VarEnv LocalOcc
z_in_lam, ud_z_tail :: UsageDetails -> VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc
z_tail })
= UD { ud_env :: VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env VarEnv LocalOcc -> [Id] -> VarEnv LocalOcc
forall a. VarEnv a -> [Id] -> VarEnv a
`delVarEnvList` [Id]
bndrs
, ud_z_many :: VarEnv LocalOcc
ud_z_many = VarEnv LocalOcc
z_many VarEnv LocalOcc -> [Id] -> VarEnv LocalOcc
forall a. VarEnv a -> [Id] -> VarEnv a
`delVarEnvList` [Id]
bndrs
, ud_z_in_lam :: VarEnv LocalOcc
ud_z_in_lam = VarEnv LocalOcc
z_in_lam VarEnv LocalOcc -> [Id] -> VarEnv LocalOcc
forall a. VarEnv a -> [Id] -> VarEnv a
`delVarEnvList` [Id]
bndrs
, ud_z_tail :: VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc
z_tail VarEnv LocalOcc -> [Id] -> VarEnv LocalOcc
forall a. VarEnv a -> [Id] -> VarEnv a
`delVarEnvList` [Id]
bndrs }
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
markAllMany :: UsageDetails -> UsageDetails
markAllMany ud :: UsageDetails
ud@(UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env }) = UsageDetails
ud { ud_z_many = env }
markAllInsideLam :: UsageDetails -> UsageDetails
markAllInsideLam ud :: UsageDetails
ud@(UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env }) = UsageDetails
ud { ud_z_in_lam = env }
markAllNonTail :: UsageDetails -> UsageDetails
markAllNonTail ud :: UsageDetails
ud@(UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env }) = UsageDetails
ud { ud_z_tail = env }
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
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
lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo
lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo
lookupTailCallInfo UsageDetails
uds Id
id
| UD { ud_z_tail :: UsageDetails -> VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc
z_tail, ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env } <- UsageDetails
uds
, Bool -> Bool
not (Id
id Id -> VarEnv LocalOcc -> Bool
forall a. Id -> VarEnv a -> Bool
`elemVarEnv` VarEnv LocalOcc
z_tail)
, Just LocalOcc
occ <- VarEnv LocalOcc -> Id -> Maybe LocalOcc
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv LocalOcc
env Id
id
= LocalOcc -> TailCallInfo
localTailCallInfo LocalOcc
occ
| Bool
otherwise
= TailCallInfo
NoTailCallInfo
udFreeVars :: VarSet -> UsageDetails -> VarSet
udFreeVars :: VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndrs (UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env }) = VarSet -> VarEnv LocalOcc -> VarSet
restrictFreeVars VarSet
bndrs VarEnv LocalOcc
env
restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet
restrictFreeVars :: VarSet -> VarEnv LocalOcc -> VarSet
restrictFreeVars VarSet
bndrs VarEnv LocalOcc
fvs = VarSet -> VarEnv LocalOcc -> VarSet
forall key b. UniqSet key -> UniqFM key b -> UniqSet key
restrictUniqSetToUFM VarSet
bndrs VarEnv LocalOcc
fvs
combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)
-> UsageDetails -> UsageDetails -> UsageDetails
{-# INLINE combineUsageDetailsWith #-}
combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith LocalOcc -> LocalOcc -> LocalOcc
plus_occ_info
uds1 :: UsageDetails
uds1@(UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env1, ud_z_many :: UsageDetails -> VarEnv LocalOcc
ud_z_many = VarEnv LocalOcc
z_many1, ud_z_in_lam :: UsageDetails -> VarEnv LocalOcc
ud_z_in_lam = VarEnv LocalOcc
z_in_lam1, ud_z_tail :: UsageDetails -> VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc
z_tail1 })
uds2 :: UsageDetails
uds2@(UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env2, ud_z_many :: UsageDetails -> VarEnv LocalOcc
ud_z_many = VarEnv LocalOcc
z_many2, ud_z_in_lam :: UsageDetails -> VarEnv LocalOcc
ud_z_in_lam = VarEnv LocalOcc
z_in_lam2, ud_z_tail :: UsageDetails -> VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc
z_tail2 })
| VarEnv LocalOcc -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarEnv LocalOcc
env1 = UsageDetails
uds2
| VarEnv LocalOcc -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarEnv LocalOcc
env2 = UsageDetails
uds1
| Bool
otherwise
= UD { ud_env :: VarEnv LocalOcc
ud_env = (LocalOcc -> LocalOcc -> LocalOcc)
-> VarEnv LocalOcc -> VarEnv LocalOcc -> VarEnv LocalOcc
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C LocalOcc -> LocalOcc -> LocalOcc
plus_occ_info VarEnv LocalOcc
env1 VarEnv LocalOcc
env2
, ud_z_many :: VarEnv LocalOcc
ud_z_many = VarEnv LocalOcc -> VarEnv LocalOcc -> VarEnv LocalOcc
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv VarEnv LocalOcc
z_many1 VarEnv LocalOcc
z_many2
, ud_z_in_lam :: VarEnv LocalOcc
ud_z_in_lam = VarEnv LocalOcc -> VarEnv LocalOcc -> VarEnv LocalOcc
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv VarEnv LocalOcc
z_in_lam1 VarEnv LocalOcc
z_in_lam2
, ud_z_tail :: VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc -> VarEnv LocalOcc -> VarEnv LocalOcc
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv VarEnv LocalOcc
z_tail1 VarEnv LocalOcc
z_tail2 }
lookupLetOccInfo :: UsageDetails -> Id -> OccInfo
lookupLetOccInfo :: UsageDetails -> Id -> OccInfo
lookupLetOccInfo UsageDetails
ud Id
id
| Id -> Bool
isExportedId Id
id = OccInfo
noOccInfo
| Bool
otherwise = UsageDetails -> Unique -> OccInfo
lookupOccInfoByUnique UsageDetails
ud (Id -> Unique
idUnique Id
id)
lookupOccInfo :: UsageDetails -> Id -> OccInfo
lookupOccInfo :: UsageDetails -> Id -> OccInfo
lookupOccInfo UsageDetails
ud Id
id = UsageDetails -> Unique -> OccInfo
lookupOccInfoByUnique UsageDetails
ud (Id -> Unique
idUnique Id
id)
lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo
lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo
lookupOccInfoByUnique (UD { ud_env :: UsageDetails -> VarEnv LocalOcc
ud_env = VarEnv LocalOcc
env
, ud_z_many :: UsageDetails -> VarEnv LocalOcc
ud_z_many = VarEnv LocalOcc
z_many
, ud_z_in_lam :: UsageDetails -> VarEnv LocalOcc
ud_z_in_lam = VarEnv LocalOcc
z_in_lam
, ud_z_tail :: UsageDetails -> VarEnv LocalOcc
ud_z_tail = VarEnv LocalOcc
z_tail })
Unique
uniq
= case VarEnv LocalOcc -> Unique -> Maybe LocalOcc
forall a. VarEnv a -> Unique -> Maybe a
lookupVarEnv_Directly VarEnv LocalOcc
env Unique
uniq of
Maybe LocalOcc
Nothing -> OccInfo
IAmDead
Just (OneOccL { lo_n_br :: LocalOcc -> JoinArity
lo_n_br = JoinArity
n_br, lo_int_cxt :: LocalOcc -> InterestingCxt
lo_int_cxt = InterestingCxt
int_cxt
, lo_tail :: LocalOcc -> TailCallInfo
lo_tail = TailCallInfo
tail_info })
| Unique
uniq Unique -> VarEnv LocalOcc -> Bool
forall a. Unique -> VarEnv a -> Bool
`elemVarEnvByKey`VarEnv LocalOcc
z_many
-> ManyOccs { occ_tail :: TailCallInfo
occ_tail = TailCallInfo -> TailCallInfo
mk_tail_info TailCallInfo
tail_info }
| Bool
otherwise
-> OneOcc { occ_in_lam :: InsideLam
occ_in_lam = InsideLam
in_lam
, occ_n_br :: JoinArity
occ_n_br = JoinArity
n_br
, occ_int_cxt :: InterestingCxt
occ_int_cxt = InterestingCxt
int_cxt
, occ_tail :: TailCallInfo
occ_tail = TailCallInfo -> TailCallInfo
mk_tail_info TailCallInfo
tail_info }
where
in_lam :: InsideLam
in_lam | Unique
uniq Unique -> VarEnv LocalOcc -> Bool
forall a. Unique -> VarEnv a -> Bool
`elemVarEnvByKey` VarEnv LocalOcc
z_in_lam = InsideLam
IsInsideLam
| Bool
otherwise = InsideLam
NotInsideLam
Just (ManyOccL TailCallInfo
tail_info) -> ManyOccs { occ_tail :: TailCallInfo
occ_tail = TailCallInfo -> TailCallInfo
mk_tail_info TailCallInfo
tail_info }
where
mk_tail_info :: TailCallInfo -> TailCallInfo
mk_tail_info TailCallInfo
ti
| Unique
uniq Unique -> VarEnv LocalOcc -> Bool
forall a. Unique -> VarEnv a -> Bool
`elemVarEnvByKey` VarEnv LocalOcc
z_tail = TailCallInfo
NoTailCallInfo
| Bool
otherwise = TailCallInfo
ti
adjustNonRecRhs :: JoinPointHood
-> WithTailUsageDetails CoreExpr
-> WithUsageDetails CoreExpr
adjustNonRecRhs :: JoinPointHood
-> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
adjustNonRecRhs JoinPointHood
mb_join_arity rhs_wuds :: WithTailUsageDetails CoreExpr
rhs_wuds@(WTUD TailUsageDetails
_ CoreExpr
rhs)
= UsageDetails -> CoreExpr -> WithUsageDetails CoreExpr
forall a. UsageDetails -> a -> WithUsageDetails a
WUD (JoinPointHood -> WithTailUsageDetails CoreExpr -> UsageDetails
adjustTailUsage JoinPointHood
mb_join_arity WithTailUsageDetails CoreExpr
rhs_wuds) CoreExpr
rhs
adjustTailUsage :: JoinPointHood
-> WithTailUsageDetails CoreExpr
-> UsageDetails
adjustTailUsage :: JoinPointHood -> WithTailUsageDetails CoreExpr -> UsageDetails
adjustTailUsage JoinPointHood
mb_join_arity (WTUD (TUD JoinArity
rhs_ja UsageDetails
uds) CoreExpr
rhs)
=
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
uds
where
one_shot :: Bool
one_shot = CoreExpr -> Bool
isOneShotFun CoreExpr
rhs
exact_join :: Bool
exact_join = JoinPointHood
mb_join_arity JoinPointHood -> JoinPointHood -> Bool
forall a. Eq a => a -> a -> Bool
== JoinArity -> JoinPointHood
JoinPoint JoinArity
rhs_ja
adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity JoinPointHood
mb_rhs_ja (TUD JoinArity
ja UsageDetails
usage)
= Bool -> UsageDetails -> UsageDetails
markAllNonTailIf (JoinPointHood
mb_rhs_ja JoinPointHood -> JoinPointHood -> Bool
forall a. Eq a => a -> a -> Bool
/= JoinArity -> JoinPointHood
JoinPoint JoinArity
ja) UsageDetails
usage
type IdWithOccInfo = Id
tagLamBinders :: UsageDetails
-> [Id]
-> [IdWithOccInfo]
tagLamBinders :: UsageDetails -> [Id] -> [Id]
tagLamBinders UsageDetails
usage [Id]
binders
= (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (UsageDetails -> Id -> Id
tagLamBinder UsageDetails
usage) [Id]
binders
tagLamBinder :: UsageDetails
-> Id
-> IdWithOccInfo
tagLamBinder :: UsageDetails -> Id -> Id
tagLamBinder UsageDetails
usage Id
bndr
= OccInfo -> Id -> Id
setBinderOcc (OccInfo -> OccInfo
markNonTail OccInfo
occ) Id
bndr
where
occ :: OccInfo
occ = UsageDetails -> Id -> OccInfo
lookupOccInfo UsageDetails
usage Id
bndr
tagNonRecBinder :: TopLevelFlag
-> OccInfo
-> CoreBndr
-> (IdWithOccInfo, JoinPointHood)
tagNonRecBinder :: TopLevelFlag -> OccInfo -> Id -> (Id, JoinPointHood)
tagNonRecBinder TopLevelFlag
lvl OccInfo
occ Id
bndr
| TopLevelFlag -> Id -> TailCallInfo -> Bool
okForJoinPoint TopLevelFlag
lvl Id
bndr TailCallInfo
tail_call_info
, AlwaysTailCalled JoinArity
ar <- TailCallInfo
tail_call_info
= (OccInfo -> Id -> Id
setBinderOcc OccInfo
occ Id
bndr, JoinArity -> JoinPointHood
JoinPoint JoinArity
ar)
| Bool
otherwise
= (OccInfo -> Id -> Id
setBinderOcc OccInfo
zapped_occ Id
bndr, JoinPointHood
NotJoinPoint)
where
tail_call_info :: TailCallInfo
tail_call_info = OccInfo -> TailCallInfo
tailCallInfo OccInfo
occ
zapped_occ :: OccInfo
zapped_occ = OccInfo -> OccInfo
markNonTail OccInfo
occ
tagRecBinders :: TopLevelFlag
-> UsageDetails
-> [NodeDetails]
-> WithUsageDetails
[IdWithOccInfo]
tagRecBinders :: TopLevelFlag
-> UsageDetails -> [NodeDetails] -> WithUsageDetails [Id]
tagRecBinders TopLevelFlag
lvl UsageDetails
body_uds [NodeDetails]
details_s
= let
bndrs :: [Id]
bndrs = (NodeDetails -> Id) -> [NodeDetails] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map NodeDetails -> Id
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 = WTUD TailUsageDetails
tuds CoreExpr
rhs}
= JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity (JoinArity -> JoinPointHood
JoinPoint (CoreExpr -> JoinArity
joinRhsArity CoreExpr
rhs)) TailUsageDetails
tuds
will_be_joins :: Bool
will_be_joins = TopLevelFlag -> UsageDetails -> [Id] -> Bool
decideRecJoinPointHood TopLevelFlag
lvl UsageDetails
unadj_uds [Id]
bndrs
mb_join_arity :: Id -> JoinPointHood
mb_join_arity :: Id -> JoinPointHood
mb_join_arity Id
bndr
| Bool
will_be_joins
, AlwaysTailCalled JoinArity
arity <- UsageDetails -> Id -> TailCallInfo
lookupTailCallInfo UsageDetails
unadj_uds Id
bndr
= JoinArity -> JoinPointHood
JoinPoint JoinArity
arity
| Bool
otherwise
= Bool -> JoinPointHood -> JoinPointHood
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not Bool
will_be_joins)
JoinPointHood
NotJoinPoint
rhs_udss' :: [UsageDetails]
rhs_udss' = [ JoinPointHood -> WithTailUsageDetails CoreExpr -> UsageDetails
adjustTailUsage (Id -> JoinPointHood
mb_join_arity Id
bndr) WithTailUsageDetails CoreExpr
rhs_wuds
| ND { nd_bndr :: NodeDetails -> Id
nd_bndr = Id
bndr, nd_rhs :: NodeDetails -> WithTailUsageDetails CoreExpr
nd_rhs = WithTailUsageDetails CoreExpr
rhs_wuds } <- [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' :: [Id]
bndrs' = [ OccInfo -> Id -> Id
setBinderOcc (UsageDetails -> Id -> OccInfo
lookupLetOccInfo UsageDetails
adj_uds Id
bndr) Id
bndr
| Id
bndr <- [Id]
bndrs ]
in
UsageDetails -> [Id] -> WithUsageDetails [Id]
forall a. UsageDetails -> a -> WithUsageDetails a
WUD UsageDetails
adj_uds [Id]
bndrs'
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc :: OccInfo -> Id -> Id
setBinderOcc OccInfo
occ_info Id
bndr
| Id -> Bool
isTyVar Id
bndr = Id
bndr
| OccInfo
occ_info OccInfo -> OccInfo -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> OccInfo
idOccInfo Id
bndr = Id
bndr
| Bool
otherwise = Id -> OccInfo -> Id
setIdOccInfo Id
bndr OccInfo
occ_info
decideRecJoinPointHood :: TopLevelFlag -> UsageDetails
-> [CoreBndr] -> Bool
decideRecJoinPointHood :: TopLevelFlag -> UsageDetails -> [Id] -> Bool
decideRecJoinPointHood TopLevelFlag
lvl UsageDetails
usage [Id]
bndrs
= (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
ok [Id]
bndrs
where
ok :: Id -> Bool
ok Id
bndr = TopLevelFlag -> Id -> TailCallInfo -> Bool
okForJoinPoint TopLevelFlag
lvl Id
bndr (UsageDetails -> Id -> TailCallInfo
lookupTailCallInfo UsageDetails
usage Id
bndr)
okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool
okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool
okForJoinPoint TopLevelFlag
lvl Id
bndr TailCallInfo
tail_call_info
| Id -> Bool
isJoinId Id
bndr
= Bool -> String -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
lost_join String
"Lost join point" SDoc
lost_join_doc (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
Bool
True
| Bool
valid_join
= Bool
True
| Bool
otherwise
= Bool
False
where
valid_join :: Bool
valid_join | TopLevelFlag
NotTopLevel <- TopLevelFlag
lvl
, AlwaysTailCalled JoinArity
arity <- TailCallInfo
tail_call_info
,
(CoreRule -> Bool) -> [CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (JoinArity -> CoreRule -> Bool
ok_rule JoinArity
arity) (Id -> [CoreRule]
idCoreRules Id
bndr)
, JoinArity -> Unfolding -> Bool
ok_unfolding JoinArity
arity (IdUnfoldingFun
realIdUnfolding Id
bndr)
, JoinArity -> Type -> Bool
isValidJoinPointType JoinArity
arity (Id -> Type
idType Id
bndr)
= Bool
True
| Bool
otherwise
= Bool
False
lost_join :: Bool
lost_join | JoinPoint JoinArity
ja <- Id -> JoinPointHood
idJoinPointHood Id
bndr
= Bool -> Bool
not Bool
valid_join Bool -> Bool -> Bool
||
(case TailCallInfo
tail_call_info of
AlwaysTailCalled JoinArity
ja' -> JoinArity
ja JoinArity -> JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
/= JoinArity
ja'
TailCallInfo
_ -> Bool
False)
| 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
lost_join_doc :: SDoc
lost_join_doc
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bndr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TailCallInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TailCallInfo
tail_call_info
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rules:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CoreRule] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> [CoreRule]
idCoreRules Id
bndr)
, case TailCallInfo
tail_call_info of
AlwaysTailCalled JoinArity
arity ->
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ok_unf:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (JoinArity -> Unfolding -> Bool
ok_unfolding JoinArity
arity (IdUnfoldingFun
realIdUnfolding Id
bndr))
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ok_type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (JoinArity -> Type -> Bool
isValidJoinPointType JoinArity
arity (Id -> Type
idType Id
bndr)) ]
TailCallInfo
_ -> SDoc
forall doc. IsOutput doc => doc
empty ]
markNonTail :: OccInfo -> OccInfo
markNonTail :: OccInfo -> OccInfo
markNonTail OccInfo
IAmDead = OccInfo
IAmDead
markNonTail OccInfo
occ = OccInfo
occ { occ_tail = NoTailCallInfo }
andLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc
andLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc
andLocalOcc LocalOcc
occ1 LocalOcc
occ2 = TailCallInfo -> LocalOcc
ManyOccL (TailCallInfo
tci1 TailCallInfo -> TailCallInfo -> TailCallInfo
`andTailCallInfo` TailCallInfo
tci2)
where
!tci1 :: TailCallInfo
tci1 = LocalOcc -> TailCallInfo
localTailCallInfo LocalOcc
occ1
!tci2 :: TailCallInfo
tci2 = LocalOcc -> TailCallInfo
localTailCallInfo LocalOcc
occ2
orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc
orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc
orLocalOcc (OneOccL { lo_n_br :: LocalOcc -> JoinArity
lo_n_br = JoinArity
nbr1, lo_int_cxt :: LocalOcc -> InterestingCxt
lo_int_cxt = InterestingCxt
int_cxt1, lo_tail :: LocalOcc -> TailCallInfo
lo_tail = TailCallInfo
tci1 })
(OneOccL { lo_n_br :: LocalOcc -> JoinArity
lo_n_br = JoinArity
nbr2, lo_int_cxt :: LocalOcc -> InterestingCxt
lo_int_cxt = InterestingCxt
int_cxt2, lo_tail :: LocalOcc -> TailCallInfo
lo_tail = TailCallInfo
tci2 })
= OneOccL { lo_n_br :: JoinArity
lo_n_br = JoinArity
nbr1 JoinArity -> JoinArity -> JoinArity
forall a. Num a => a -> a -> a
+ JoinArity
nbr2
, lo_int_cxt :: InterestingCxt
lo_int_cxt = InterestingCxt
int_cxt1 InterestingCxt -> InterestingCxt -> InterestingCxt
forall a. Monoid a => a -> a -> a
`mappend` InterestingCxt
int_cxt2
, lo_tail :: TailCallInfo
lo_tail = TailCallInfo
tci1 TailCallInfo -> TailCallInfo -> TailCallInfo
`andTailCallInfo` TailCallInfo
tci2 }
orLocalOcc LocalOcc
occ1 LocalOcc
occ2 = LocalOcc -> LocalOcc -> LocalOcc
andLocalOcc LocalOcc
occ1 LocalOcc
occ2
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