[Git][ghc/ghc][wip/T18603] wibbles
Simon Peyton Jones
gitlab at gitlab.haskell.org
Fri Aug 28 07:44:55 UTC 2020
Simon Peyton Jones pushed to branch wip/T18603 at Glasgow Haskell Compiler / GHC
Commits:
91d15840 by Simon Peyton Jones at 2020-08-28T00:30:33+01:00
wibbles
- - - - -
2 changed files:
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -10,16 +10,12 @@ Taken quite directly from the Peyton Jones/Lester paper.
-- | A module concerned with finding the free variables of an expression.
module GHC.Core.FVs (
-- * Free variables of expressions and binding groups
- exprFreeVars,
+ exprFreeVars, exprsFreeVars,
exprFreeVarsDSet,
- exprFreeVarsList,
- exprFreeIds,
- exprFreeIdsDSet,
- exprFreeIdsList,
- exprsFreeIdsDSet,
- exprsFreeIdsList,
- exprsFreeVars,
- exprsFreeVarsList,
+ exprFreeVarsList, exprsFreeVarsList,
+ exprFreeIds, exprsFreeIds,
+ exprFreeIdsDSet, exprsFreeIdsDSet,
+ exprFreeIdsList, exprsFreeIdsList,
bindFreeVars,
-- * Selective free variables of expressions
@@ -126,6 +122,9 @@ exprFreeVarsList = fvVarList . exprFVs
exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
exprFreeIds = exprSomeFreeVars isLocalId
+exprsFreeIds :: [CoreExpr] -> IdSet -- Find all locally-defined free Ids
+exprsFreeIds = exprsSomeFreeVars isLocalId
+
-- | Find all locally-defined free Ids in an expression
-- returning a deterministic set.
exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -64,7 +64,7 @@ Here's the externally-callable interface:
occurAnalysePgm :: Module -- Used only in debug output
-> (Id -> Bool) -- Active unfoldings
-> (Activation -> Bool) -- Active rules
- -> [CoreRule]
+ -> [CoreRule] -- Local rules for imported Ids
-> CoreProgram -> CoreProgram
occurAnalysePgm this_mod active_unf active_rule imp_rules binds
| isEmptyDetails final_usage
@@ -96,20 +96,20 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
-- The RULES declarations keep things alive!
-- imp_rule_edges maps a top-level local binder 'f' to the
- -- RHS free vars of any local RULES for an imported function,
+ -- RHS free vars of any active local RULES for an imported function,
-- where 'f' appears on the LHS
-- e.g. RULE foldr f = blah
-- imp_rule_edges contains f :-> fvs(blah)
-- See Note [Preventing loops due to imported functions rules]
imp_rule_edges :: ImpRuleEdges
imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv
- [ mapVarEnv (const maps_to) $
- getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule)
- | imp_rule <- imp_rules
- , not (isBuiltinRule imp_rule) -- See Note [Plugin rules]
- , let maps_to = exprFreeIds (ru_rhs imp_rule)
- `delVarSetList` ru_bndrs imp_rule
- , arg <- ru_args imp_rule ]
+ [ mapVarEnv (const rhs_fvs) $ getUniqSet $
+ exprsFreeIds args `delVarSetList` bndrs
+ | Rule { ru_act = act, ru_bndrs = bndrs
+ , ru_args = args, ru_rhs = rhs } <- imp_rules
+ -- Not BuiltinRules; see Note [Plugin rules]
+ , active_rule act -- Only active rules
+ , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
go _ []
@@ -260,13 +260,11 @@ always in scope.
(because it isn't referenced any more), then the children will die
too (unless they are already referenced directly).
- To that end, we build a Rec group for each cyclic strongly
- connected component,
- *treating f's rules as extra RHSs for 'f'*.
More concretely, the SCC analysis runs on a graph with an edge
from f -> g iff g is mentioned in
- (a) f's rhs
- (b) f's RULES
+ (a) f's RHS
+ (b) The LHS or RHS of all of f's RULES, active or inactive
+ (i.e. regardless of phase)
These are rec_edges.
Under (b) we include variables free in *either* LHS *or* RHS of
@@ -275,6 +273,9 @@ always in scope.
will be put in the same Rec, even though their 'main' RHSs are
both non-recursive.
+ We must also include inactive rules, so that their free vars
+ remain in scope.
+
* Note [Rule dependency info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The VarSet in a RuleInfo is used for dependency analysis in the
@@ -819,45 +820,45 @@ occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage
= (body_usage, [])
| otherwise -- It's mentioned in the body
- = (body_usage' `andUDs` rhs_usage4, [NonRec final_bndr rhs'])
+ = (body_usage' `andUDs` rhs_usage, [NonRec final_bndr rhs'])
where
(body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr
final_bndr = tagged_bndr `setIdUnfolding` unf'
`setIdSpecialisation` mkRuleInfo rules'
- inl_fvs = inlineFreeVars unf unf_usage rhs_usage1
+ rhs_usage = rhs_uds `andUDs` unf_uds `andUDs` rule_uds
-- Get the join info from the *new* decision
-- See Note [Join points and unfoldings/rules]
mb_join_arity = willBeJoinId_maybe tagged_bndr
is_join_point = isJust mb_join_arity
-
+ --------- Right hand side ---------
env1 | is_join_point = env -- See Note [Join point RHSs]
| certainly_inline = env -- See Note [Cascading inlines]
| otherwise = rhsCtxt env
-- See Note [Sources of one-shot information]
rhs_env = env1 { occ_one_shots = argOneShots dmd }
+ (rhs_uds, rhs') = occAnalRhs rhs_env NonRecursive mb_join_arity rhs
- (rhs_usage1, rhs') = occAnalRhs rhs_env mb_join_arity rhs
-
- -- Unfoldings
+ --------- Unfolding ---------
-- See Note [Unfoldings and join points]
unf = idUnfolding bndr
- (unf_usage, unf') = occAnalUnfolding rhs_env mb_join_arity unf
- rhs_usage2 = rhs_usage1 `andUDs` unf_usage
+ (unf_uds, unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf
- -- Rules
+ --------- Rules ---------
-- See Note [Rules are extra RHSs] and Note [Rule dependency info]
rules_w_uds = occAnalRules rhs_env mb_join_arity bndr
- rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds
rules' = map fstOf3 rules_w_uds
- rhs_usage3 = foldr andUDs rhs_usage2 rule_uds
- rhs_usage4 = case lookupVarEnv imp_rule_edges bndr of
- Nothing -> rhs_usage3
- Just vs -> addManyOccs rhs_usage3 vs
+ imp_rule_uds = case lookupVarEnv imp_rule_edges bndr of
+ Nothing -> emptyDetails
+ Just vs -> addManyOccs emptyDetails vs
-- See Note [Preventing loops due to imported functions rules]
+ rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds
+ add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds
+
+ ----------
occ = idOccInfo tagged_bndr
certainly_inline -- See Note [Cascading inlines]
= case occ of
@@ -869,16 +870,6 @@ occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage
active = isAlwaysActive (idInlineActivation bndr)
not_stable = not (isStableUnfolding (idUnfolding bndr))
-setNonRecLoopBreaker :: TopLevelFlag -> RuleFvEnv -> VarSet -> Id -> Id
--- See Note [Non-recursive loop breakers]
-setNonRecLoopBreaker lvl rule_fv_env inl_fvs bndr
- | isTopLevel lvl -- Only relevant for top-level binders
- -- since nested binders are never in rng(rule_fv_env)
- , rule_loop = mk_loop_breaker bndr
- | otherwise = bndr
- where
- rule_loop = bndr `elemVarSet` extendFvs_ rule_fv_env inl_fvs
-
-----------------
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
-> UsageDetails -> (UsageDetails, [CoreBind])
@@ -904,15 +895,13 @@ occAnalRecBind env lvl imp_rule_edges pairs body_usage
rule_fv_env :: RuleFvEnv
-- Maps a variable f to the variables from this group
- -- mentioned in RHS of active rules for f
+ -- mentioned in RHS of /active/ rules for f
-- Domain is *subset* of bound vars (others have no rule fvs)
- rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs)
- init_rule_fvs -- See Note [Finding rule RHS free vars]
- = [ (b, trimmed_rule_fvs)
- | (node_payload -> ND { nd_bndr = b
- , nd_active_rule_fvs = rule_fvs }) <- nodes
- , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set
- , not (isEmptyVarSet trimmed_rule_fvs) ]
+ rule_fv_env -- See Note [Finding rule RHS free vars]
+ = mkVarEnv [ (b, rule_fvs)
+ | (node_payload -> ND { nd_bndr = b
+ , nd_active_rule_fvs = rule_fvs }) <- nodes
+ , not (isEmptyVarSet rule_fvs) ]
{-
@@ -944,7 +933,7 @@ occAnalRec _ lvl rule_fv_env
where
(body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr
final_bndr = setNonRecLoopBreaker lvl rule_fv_env inl_fvs tagged_bndr
- rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive
+ rhs_uds' = adjustRhsUsage NonRecursive (willBeJoinId_maybe tagged_bndr)
rhs_bndrs rhs_uds
-- The Rec case is the interesting one
@@ -993,6 +982,16 @@ occAnalRec env lvl rule_fv_env
-- Loop breaking
------------------------------------------------------------------
+setNonRecLoopBreaker :: TopLevelFlag -> RuleFvEnv -> VarSet -> Id -> Id
+-- See Note [Non-recursive loop breakers]
+setNonRecLoopBreaker lvl rule_fv_env inl_fvs bndr
+ | isTopLevel lvl -- Only relevant for top-level binders
+ -- since nested binders are never in rng(rule_fv_env)
+ , rule_loop = mk_loop_breaker bndr
+ | otherwise = bndr
+ where
+ rule_loop = bndr `elemVarSet` extendFvs_ rule_fv_env inl_fvs
+
type Binding = (Id,CoreExpr)
loopBreakNodes :: Int
@@ -1243,9 +1242,6 @@ type ImpRuleEdges = RuleFvEnv
-- Mapping from a local Id 'f' to the free vars of the RHS of
-- local rules for an imported Id that mention 'f' on the LHS
-lookupRuleFvEnv :: RuleFvEnv -> Id -> IdSet
-lookupRuleFvEnv env id = lookupVarEnv env id `orElse` emptyVarSet
-
noImpRuleEdges :: ImpRuleEdges
noImpRuleEdges = emptyVarEnv
@@ -1317,15 +1313,20 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs)
details = ND { nd_bndr = bndr'
, nd_rhs = rhs'
, nd_rhs_bndrs = bndrs'
- , nd_uds = rhs_usage3
+ , nd_uds = rhs_usage
, nd_inl = inl_fvs
, nd_weak = node_fvs `minusVarSet` inl_fvs
- , nd_active_rule_fvs = active_rule_fvs
+ , nd_active_rule_fvs = active_rule_fvs `intersectVarSet` bndr_set
, nd_score = pprPanic "makeNodeDetails" (ppr bndr) }
bndr' = bndr `setIdUnfolding` unf'
`setIdSpecialisation` mkRuleInfo rules'
+ rhs_usage = rhs_uds `andUDs` unf_uds `andUDs` rule_uds
+ -- Note [Rules are extra RHSs]
+ -- Note [Rule dependency info]
+ node_fvs = udFreeVars bndr_set rhs_usage
+
-- Get join point info from the *current* decision
-- We don't know what the new decision will be!
-- Using the old decision at least allows us to
@@ -1333,42 +1334,43 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs)
-- See Note [Join points and unfoldings/rules]
mb_join_arity = isJoinId_maybe bndr
+ --------- Right hand side ---------
-- Constructing the edges for the main Rec computation
-- See Note [Forming Rec groups]
- (bndrs, body) = collectBinders rhs
- rhs_env = rhsCtxt env
- (rhs_usage1, bndrs', body') = occAnalLamOrRhs rhs_env bndrs body
- rhs' = mkLams bndrs' body'
- rhs_usage3 = foldr andUDs rhs_usage1 rule_uds
- `andUDs` unf_uds
- -- Note [Rules are extra RHSs]
- -- Note [Rule dependency info]
- node_fvs = udFreeVars bndr_set rhs_usage3
-
- -- Finding the free variables of the rules
- is_active = occ_rule_act env :: Activation -> Bool
+ -- Do not use occAnalRhs because we don't yet know
+ -- the final answer for mb_join_arity
+ (bndrs, body) = collectBinders rhs
+ rhs_env = rhsCtxt env
+ (rhs_uds, bndrs', body') = occAnalLamOrRhs rhs_env bndrs body
+ rhs' = mkLams bndrs' body'
+
+ --------- Unfolding ---------
+ -- See Note [Unfoldings and join points]
+ unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness
+ -- here because that is what we are setting!
+ (unf_uds, unf') = occAnalUnfolding rhs_env Recursive mb_join_arity unf
+ inl_fvs = restrictFreeVars bndr_set (inlineFreeVars unf unf_uds rhs_uds)
+ --------- Rules ---------
rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds = occAnalRules rhs_env mb_join_arity bndr
+ rules' = map fstOf3 rules_w_uds
- rules' = map fstOf3 rules_w_uds
-
- rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs
- rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):))
- (lookupVarEnv imp_rule_edges bndr)
- -- See Note [Preventing loops due to imported functions rules]
- [ (ru_act rule, udFreeVars bndr_set rhs_uds)
- | (rule, _, rhs_uds) <- rules_w_uds ]
- rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds
- active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs
- , is_active a]
+ rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds
+ add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds
+ imp_rule_uds = case lookupVarEnv imp_rule_edges bndr of
+ Nothing -> emptyDetails
+ Just vs -> addManyOccs emptyDetails vs
- -- Finding the usage details of the INLINE pragma (if any)
- unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness
- -- here because that is what we are setting!
- (unf_uds, unf') = occAnalUnfolding rhs_env mb_join_arity unf
- inl_fvs = restrictFreeVars bndr_set (inlineFreeVars unf unf_uds rhs_usage1)
+ is_active = occ_rule_act env :: Activation -> Bool
+ imp_rule_fvs = udFreeVars bndr_set imp_rule_uds
+ active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds
+ add_active_rule (rule, _, rhs_uds) fvs
+ | is_active (ruleActivation rule)
+ = udFreeVars bndr_set rhs_uds `unionVarSet` fvs
+ | otherwise
+ = fvs
inlineFreeVars :: Unfolding
-> UsageDetails -- Of the unfolding
@@ -1632,29 +1634,31 @@ Hence the is_lb field of NodeScore
************************************************************************
-}
-occAnalRhs :: OccEnv -> Maybe JoinArity
+occAnalRhs :: OccEnv -> RecFlag -> Maybe JoinArity
-> CoreExpr -- RHS
-> (UsageDetails, CoreExpr)
-occAnalRhs env mb_join_arity rhs
+occAnalRhs env is_rec mb_join_arity rhs
= case occAnalLamOrRhs env bndrs body of { (body_usage, bndrs', body') ->
- let rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'
+ let final_bndrs | isRec is_rec = bndrs'
+ | otherwise = markJoinOneShots mb_join_arity bndrs'
-- For a /non-recursive/ join point we can mark all
-- its join-lambda as one-shot; and it's a good idea to do so
-- Final adjustment
- rhs_usage = adjustRhsUsage mb_join_arity NonRecursive bndrs' body_usage
+ rhs_usage = adjustRhsUsage is_rec mb_join_arity final_bndrs body_usage
- in (rhs_usage, rhs') }
+ in (rhs_usage, mkLams final_bndrs body') }
where
(bndrs, body) = collectBinders rhs
occAnalUnfolding :: OccEnv
+ -> RecFlag
-> Maybe JoinArity -- See Note [Join points and unfoldings/rules]
-> Unfolding
-> (UsageDetails, Unfolding)
-- Occurrence-analyse a stable unfolding;
-- discard a non-stable one altogether.
-occAnalUnfolding env mb_join_arity unf
+occAnalUnfolding env is_rec mb_join_arity unf
= case unf of
unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src -> (usage, unf')
@@ -1665,7 +1669,7 @@ occAnalUnfolding env mb_join_arity unf
-- to guide its decisions. It's ok to leave un-substituted
-- expressions in the tree because all the variables that were in
-- scope remain in scope; there is no cloning etc.
- (usage, rhs') = occAnalRhs env mb_join_arity rhs
+ (usage, rhs') = occAnalRhs env is_rec mb_join_arity rhs
unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]
| otherwise = unf { uf_tmpl = rhs' }
@@ -1962,7 +1966,7 @@ occAnalApp env (Var fun, args, ticks)
-- This caused #18296
| fun `hasKey` runRWKey
, [t1, t2, arg] <- args
- , let (usage, arg') = occAnalRhs env (Just 1) arg
+ , let (usage, arg') = occAnalRhs env NonRecursive (Just 1) arg
= (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
occAnalApp env (Var fun, args, ticks)
@@ -2298,6 +2302,7 @@ addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
= env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }
+{-
transClosureFV :: VarEnv VarSet -> VarEnv VarSet
-- If (f,g), (g,h) are in the input, then (f,h) is in the output
-- as well as (f,g), (g,h)
@@ -2313,7 +2318,7 @@ transClosureFV env
| otherwise = (False, (b,new_fvs))
where
(new_fvs, no_change_here) = extendFvs env fvs
-
+-}
-------------
extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet
extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag
@@ -2780,20 +2785,20 @@ flattenUsageDetails ud
-------------------
-- See Note [Adjusting right-hand sides]
-adjustRhsUsage :: Maybe JoinArity -> RecFlag
+adjustRhsUsage :: RecFlag -> Maybe JoinArity
-> [CoreBndr] -- Outer lambdas, AFTER occ anal
-> UsageDetails -- From body of lambda
-> UsageDetails
-adjustRhsUsage mb_join_arity rec_flag bndrs usage
- = markAllInsideLamIf (not one_shot) $
+adjustRhsUsage is_rec mb_join_arity bndrs usage
+ = markAllInsideLamIf (not one_shot) $
markAllNonTailIf (not exact_join) $
usage
where
one_shot = case mb_join_arity of
Just join_arity
- | isRec rec_flag -> False
- | otherwise -> all isOneShotBndr (drop join_arity bndrs)
- Nothing -> all isOneShotBndr bndrs
+ | isRec is_rec -> False
+ | otherwise -> all isOneShotBndr (drop join_arity bndrs)
+ Nothing -> all isOneShotBndr bndrs
exact_join = exactJoin mb_join_arity bndrs
@@ -2874,7 +2879,7 @@ tagRecBinders lvl body_uds triples
-- join-point-hood decision
rhs_udss' = map adjust triples
adjust (bndr, rhs_uds, rhs_bndrs)
- = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds
+ = adjustRhsUsage Recursive mb_join_arity rhs_bndrs rhs_uds
where
-- Can't use willBeJoinId_maybe here because we haven't tagged the
-- binder yet (the tag depends on these adjustments!)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91d15840d7c4a7bf26d70b45ecad70d6fb940eaa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91d15840d7c4a7bf26d70b45ecad70d6fb940eaa
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200828/856cf20b/attachment-0001.html>
More information about the ghc-commits
mailing list