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