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