core expression with (hopefully) improved usage information.
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module OccurAnal (
occurAnalysePgm, occurAnalyseExpr
) where
+-- XXX This define is a bit of a hack, and should be done more nicely
+#define FAST_STRING_NOT_NEEDED 1
#include "HsVersions.h"
import CoreSyn
-import CoreFVs ( idRuleVars )
+import CoreFVs
import CoreUtils ( exprIsTrivial, isDefaultAlt )
-import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
- idOccInfo, setIdOccInfo, isLocalId,
- isExportedId, idArity, idHasRules,
- idUnique, Id
- )
-import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
+import Id
+import IdInfo
+import BasicTypes
import VarSet
import VarEnv
import Digraph ( stronglyConnCompR, SCC(..) )
import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import Unique ( Unique )
-import UniqFM ( keysUFM, intersectsUFM )
+import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )
import Util ( mapAndUnzip )
import Outputable
= snd (go initOccEnv binds)
where
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
- go env []
+ go _ []
= (emptyDetails, [])
go env (bind:binds)
= (final_usage, bind' ++ binds')
= (body_usage, [])
| otherwise -- It's mentioned in the body
- = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [RulesOnly]
+ = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
[NonRec tagged_binder rhs'])
where
(body_usage', tagged_binder) = tagBinder body_usage binder
(rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
\end{code}
+Note [Dead code]
+~~~~~~~~~~~~~~~~
Dropping dead code for recursive bindings is done in a very simple way:
the entire set of bindings is dropped if none of its binders are
mentioned in its body; otherwise none are.
This seems to miss an obvious improvement.
-@
+
letrec f = ...g...
g = ...f...
in
...g...
-
===>
-
letrec f = ...g...
g = ...(...g...)...
in
...g...
-@
-Now @f@ is unused. But dependency analysis will sort this out into a
-@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
-It isn't easy to do a perfect job in one blow. Consider
+Now 'f' is unused! But it's OK! Dependency analysis will sort this
+out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
+dropped. It isn't easy to do a perfect job in one blow. Consider
-@
letrec f = ...g...
g = ...h...
h = ...k...
m = ...m...
in
...m...
-@
+
+
+Note [Loop breaking and RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Loop breaking is surprisingly subtle. First read the section 4 of
+"Secrets of the GHC inliner". This describes our basic plan.
+
+However things are made quite a bit more complicated by RULES. Remember
+
+ * Note [Rules are extra RHSs]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
+ keeps the specialised "children" alive. If the parent dies
+ (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'*.
+
+ When we make the Rec groups we include variables free in *either*
+ LHS *or* RHS of the rule. The former might seems silly, but see
+ Note [Rule dependency info].
+
+ So in Example [eftInt], eftInt and eftIntFB will be put in the
+ same Rec, even though their 'main' RHSs are both non-recursive.
+
+ * Note [Rules are visible in their own rec group]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ We want the rules for 'f' to be visible in f's right-hand side.
+ And we'd like them to be visible in other functions in f's Rec
+ group. E.g. in Example [Specialisation rules] we want f' rule
+ to be visible in both f's RHS, and fs's RHS.
+
+ This means that we must simplify the RULEs first, before looking
+ at any of the definitions. This is done by Simplify.simplRecBind,
+ when it calls addLetIdInfo.
+
+ * Note [Choosing loop breakers]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ We avoid infinite inlinings by choosing loop breakers, and
+ ensuring that a loop breaker cuts each loop. But what is a
+ "loop"? In particular, a RULES is like an equation for 'f' that
+ is *always* inlined if it are applicable. We do *not* disable
+ rules for loop-breakers. It's up to whoever makes the rules to
+ make sure that the rules themselves alwasys terminate. See Note
+ [Rules for recursive functions] in Simplify.lhs
+
+ Hence, if
+ f's RHS mentions g, and
+ g has a RULE that mentions h, and
+ h has a RULE that mentions f
+
+ then we *must* choose f to be a loop breaker. In general, take the
+ free variables of f's RHS, and augment it with all the variables
+ reachable by RULES from those starting points. That is the whole
+ reason for computing rule_fv_env in occAnalBind. (Of course we
+ only consider free vars that are also binders in this Rec group.)
+
+ Note that when we compute this rule_fv_env, we only consider variables
+ free in the *RHS* of the rule, in contrast to the way we build the
+ Rec group in the first place (Note [Rule dependency info])
+
+ Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
+ chosen as a loop breaker, because their RHSs don't mention each other.
+ And indeed both can be inlined safely.
+
+ Note that the edges of the graph we use for computing loop breakers
+ are not the same as the edges we use for computing the Rec blocks.
+ That's why we compute
+ rec_edges for the Rec block analysis
+ loop_breaker_edges for the loop breaker analysis
+
+
+ * Note [Weak loop breakers]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~
+ There is a last nasty wrinkle. Suppose we have
+
+ Rec { f = f_rhs
+ RULE f [] = g
+
+ h = h_rhs
+ g = h
+ ...more...
+ }
+
+ Remmber that we simplify the RULES before any RHS (see Note
+ [Rules are visible in their own rec group] above).
+
+ So we must *not* postInlineUnconditionally 'g', even though
+ its RHS turns out to be trivial. (I'm assuming that 'g' is
+ not choosen as a loop breaker.)
+
+ We "solve" this by making g a "weak" or "rules-only" loop breaker,
+ with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
+ has IAmLoopBreaker False. So
+
+ Inline postInlineUnconditinoally
+ IAmLoopBreaker False no no
+ IAmLoopBreaker True yes no
+ other yes yes
+
+ The **sole** reason for this kind of loop breaker is so that
+ postInlineUnconditionally does not fire. Ugh.
+
+ * Note [Rule dependency info]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ The VarSet in a SpecInfo is used for dependency analysis in the
+ occurrence analyser. We must track free vars in *both* lhs and rhs. Why both?
+ Consider
+ x = y
+ RULE f x = 4
+ Then if we substitute y for x, we'd better do so in the
+ rule's LHS too, so we'd better ensure the dependency is respected
+
+
+Example [eftInt]
+~~~~~~~~~~~~~~~
+Example (from GHC.Enum):
+
+ eftInt :: Int# -> Int# -> [Int]
+ eftInt x y = ...(non-recursive)...
+
+ {-# INLINE [0] eftIntFB #-}
+ eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
+ eftIntFB c n x y = ...(non-recursive)...
+
+ {-# RULES
+ "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
+ "eftIntList" [1] eftIntFB (:) [] = eftInt
+ #-}
+
+Example [Specialisation rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this group, which is typical of what SpecConstr builds:
+
+ fs a = ....f (C a)....
+ f x = ....f (C a)....
+ {-# RULE f (C a) = fs a #-}
+
+So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
+
+But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
+ - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
+ - fs is inlined (say it's small)
+ - now there's another opportunity to apply the RULE
+
+This showed up when compiling Control.Concurrent.Chan.getChanContents.
\begin{code}
occAnalBind env (Rec pairs) body_usage
- = foldr ({-# SCC "occAnalBind.dofinal" #-} do_final_bind) (body_usage, []) sccs
+ | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
+ = (body_usage, []) -- Dead code
+ | otherwise
+ = (final_usage, map ({-# SCC "occAnalBind.dofinal" #-} do_final_bind) sccs)
where
- analysed_pairs :: [Details]
- analysed_pairs = [ (bndr, rhs_usage, rhs')
- | (bndr, rhs) <- pairs,
- let (rhs_usage, rhs') = occAnalRhs env bndr rhs
- ]
+ bndrs = map fst pairs
+ bndr_set = mkVarSet bndrs
+
+ ---------------------------------------
+ -- See Note [Loop breaking]
+ ---------------------------------------
+
+ -------------Dependency analysis ------------------------------
+ occ_anald :: [(Id, (UsageDetails, CoreExpr))]
+ -- The UsageDetails here are strictly those arising from the RHS
+ -- *not* from any rules in the Id
+ occ_anald = [(bndr, occAnalRhs env bndr rhs) | (bndr,rhs) <- pairs]
+
+ total_usage = foldl add_usage body_usage occ_anald
+ add_usage body_usage (bndr, (rhs_usage, _))
+ = body_usage +++ addRuleUsage rhs_usage bndr
+
+ (final_usage, tagged_bndrs) = tagBinders total_usage bndrs
+ final_bndrs | isEmptyVarSet all_rule_fvs = tagged_bndrs
+ | otherwise = map tag_rule_var tagged_bndrs
+
+ tag_rule_var bndr | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr
+ | otherwise = bndr
+ all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars) emptyVarSet bndrs
+ -- Mark the binder with OccInfo saying "no preInlineUnconditionally" if
+ -- it is used in any rule (lhs or rhs) of the recursive group
+ ---- stuff for dependency analysis of binds -------------------------------
sccs :: [SCC (Node Details)]
- sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR edges
-
+ sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges
- ---- stuff for dependency analysis of binds -------------------------------
- edges :: [Node Details]
- edges = {-# SCC "occAnalBind.assoc" #-}
- [ (details, idUnique id, edges_from id rhs_usage)
- | details@(id, rhs_usage, rhs) <- analysed_pairs
- ]
+ rec_edges :: [Node Details] -- The binders are tagged with correct occ-info
+ rec_edges = {-# SCC "occAnalBind.assoc" #-} zipWith make_node final_bndrs occ_anald
+ make_node tagged_bndr (_bndr, (rhs_usage, rhs))
+ = ((tagged_bndr, rhs, rhs_fvs), idUnique tagged_bndr, out_edges)
+ where
+ rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
+ out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars tagged_bndr)
+
-- (a -> b) means a mentions b
-- Given the usage details (a UFM that gives occ info for each free var of
-- maybeToBool (lookupVarEnv rhs_usage bndr)]
-- which has n**2 cost, and this meant that edges_from alone
-- consumed 10% of total runtime!
- edges_from :: Id -> UsageDetails -> [Unique]
- edges_from bndr rhs_usage = {-# SCC "occAnalBind.edges_from" #-}
- keysUFM (addRuleUsage rhs_usage bndr)
---- Stuff to "re-constitute" bindings from dependency-analysis info ------
+ do_final_bind (AcyclicSCC ((bndr, rhs, _), _, _)) = NonRec bndr rhs
+ do_final_bind (CyclicSCC cycle)
+ | no_rules = Rec (reOrderCycle cycle)
+ | otherwise = Rec (concatMap reOrderRec (stronglyConnCompR loop_breaker_edges))
+ where -- See Note [Choosing loop breakers] for looop_breker_edges
+ loop_breaker_edges = map mk_node cycle
+ mk_node (details@(_bndr, _rhs, rhs_fvs), k, _) = (details, k, new_ks)
+ where
+ new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
- -- Non-recursive SCC
- do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
- | not (bndr `usedIn` body_usage)
- = (body_usage, binds_so_far) -- Dead code
- | otherwise
- = (body_usage' +++ addRuleUsage rhs_usage bndr, new_bind : binds_so_far)
- where
- (body_usage', tagged_bndr) = tagBinder body_usage bndr
- new_bind = NonRec tagged_bndr rhs'
-
- -- Recursive SCC
- do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
- | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
- = (body_usage, binds_so_far) -- Dead code
- | otherwise -- If any is used, they all are
- = (final_usage, final_bind : binds_so_far)
- where
- details = [details | (details, _, _) <- cycle]
- bndrs = [bndr | (bndr, _, _) <- details]
- bndr_usages = [addRuleUsage rhs_usage bndr | (bndr, rhs_usage, _) <- details]
- total_usage = foldr (+++) body_usage bndr_usages
- (final_usage, tagged_cycle) = mapAccumL tag_bind total_usage cycle
- tag_bind usg ((bndr,rhs_usg,rhs),k,ks) = (usg', ((bndr',rhs_usg,rhs),k,ks))
- where
- (usg', bndr') = tagBinder usg bndr
- final_bind = Rec (reOrderCycle (mkVarSet bndrs) tagged_cycle)
-
-{- An alternative; rebuild the edges. No semantic difference, but perf might change
-
- -- Hopefully 'bndrs' is a relatively small group now
- -- Now get ready for the loop-breaking phase
- -- We've done dead-code elimination already, so no worries about un-referenced binders
- keys = map idUnique bndrs
- mk_node tagged_bndr (_, rhs_usage, rhs')
- = ((tagged_bndr, rhs'), idUnique tagged_bndr, used)
- where
- used = [key | key <- keys, used_outside_rule rhs_usage key ]
-
- used_outside_rule usage uniq = case lookupUFM_Directly usage uniq of
- Nothing -> False
- Just RulesOnly -> False -- Ignore rules
- other -> True
--}
+
+ ------------------------------------
+ rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
+ -- Domain is *subset* of bound vars (others have no rule fvs)
+ rule_fv_env = rule_loop init_rule_fvs
+
+ no_rules = null init_rule_fvs
+ init_rule_fvs = [(b, rule_fvs)
+ | b <- bndrs
+ , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
+ , not (isEmptyVarSet rule_fvs)]
+
+ rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
+ rule_loop fv_list
+ | no_change = env
+ | otherwise = rule_loop new_fv_list
+ where
+ env = mkVarEnv init_rule_fvs
+ (no_change, new_fv_list) = mapAccumL bump True fv_list
+ bump no_change (b,fvs)
+ | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
+ | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
+ where
+ new_fvs = extendFvs env emptyVarSet fvs
+
+idRuleRhsVars :: Id -> VarSet
+-- Just the variables free on the *rhs* of a rule
+-- See Note [Choosing loop breakers]
+idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)
+
+extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
+-- (extendFVs env fvs s) returns (fvs `union` env(s))
+extendFvs env fvs id_set
+ = foldUFM_Directly add fvs id_set
+ where
+ add uniq _ fvs
+ = case lookupVarEnv_Directly env uniq of
+ Just fvs' -> fvs' `unionVarSet` fvs
+ Nothing -> fvs
\end{code}
@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
\begin{code}
type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
-- which is gotten from the Id.
-type Details = (Id, UsageDetails, CoreExpr)
+type Details = (Id, -- Binder
+ CoreExpr, -- RHS
+ IdSet) -- RHS free vars (*not* include rules)
-reOrderRec :: IdSet -- Binders of this group
- -> SCC (Node Details)
+reOrderRec :: SCC (Node Details)
-> [(Id,CoreExpr)]
-- Sorted into a plausible order. Enough of the Ids have
-- IAmALoopBreaker pragmas that there are no loops left.
-reOrderRec bndrs (AcyclicSCC ((bndr, _, rhs), _, _)) = [(bndr, rhs)]
-reOrderRec bndrs (CyclicSCC cycle) = reOrderCycle bndrs cycle
+reOrderRec (AcyclicSCC ((bndr, rhs, _), _, _)) = [(bndr, rhs)]
+reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
-reOrderCycle :: IdSet -> [Node Details] -> [(Id,CoreExpr)]
-reOrderCycle bndrs []
+reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
+reOrderCycle []
= panic "reOrderCycle"
-reOrderCycle bndrs [bind] -- Common case of simple self-recursion
- = [(makeLoopBreaker bndrs rhs_usg bndr, rhs)]
+reOrderCycle [bind] -- Common case of simple self-recursion
+ = [(makeLoopBreaker False bndr, rhs)]
where
- ((bndr, rhs_usg, rhs), _, _) = bind
+ ((bndr, rhs, _), _, _) = bind
-reOrderCycle bndrs (bind : binds)
+reOrderCycle (bind : binds)
= -- Choose a loop breaker, mark it no-inline,
-- do SCC analysis on the rest, and recursively sort them out
- concatMap (reOrderRec bndrs) (stronglyConnCompR unchosen) ++
- [(makeLoopBreaker bndrs rhs_usg bndr, rhs)]
+ concatMap reOrderRec (stronglyConnCompR unchosen) ++
+ [(makeLoopBreaker False bndr, rhs)]
where
(chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
- (bndr, rhs_usg, rhs) = chosen_bind
+ (bndr, rhs, _) = chosen_bind
-- This loop looks for the bind with the lowest score
-- to pick as the loop breaker. The rest accumulate in
- choose_loop_breaker (details,_,_) loop_sc acc []
+ choose_loop_breaker (details,_,_) _loop_sc acc []
= (details, acc) -- Done
choose_loop_breaker loop_bind loop_sc acc (bind : binds)
sc = score bind
score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
- score ((bndr, _, rhs), _, _)
+ score ((bndr, rhs, _), _, _)
+ | workerExists (idWorkerInfo bndr) = 10
+ -- Note [Worker inline loop]
+
| exprIsTrivial rhs = 4 -- Practically certain to be inlined
-- Used to have also: && not (isExportedId bndr)
-- But I found this sometimes cost an extra iteration when we have
-- where df is the exported dictionary. Then df makes a really
-- bad choice for loop breaker
- | idHasRules bndr = 3
- -- Avoid things with specialisations; we'd like
- -- to take advantage of them in the subsequent bindings
- -- Also vital to avoid risk of divergence:
- -- Note [Recursive rules]
+ | is_con_app rhs = 2 -- Data types help with cases
+ -- Note [conapp]
- | inlineCandidate bndr rhs = 2 -- Likely to be inlined
+ | inlineCandidate bndr rhs = 1 -- Likely to be inlined
-- Note [Inline candidates]
- | is_con_app rhs = 1 -- Data types help with cases
-
| otherwise = 0
inlineCandidate :: Id -> CoreExpr -> Bool
- inlineCandidate id (Note InlineMe _) = True
- inlineCandidate id rhs = isOneOcc (idOccInfo id)
-
- -- Real example (the Enum Ordering instance from PrelBase):
+ inlineCandidate _ (Note InlineMe _) = True
+ inlineCandidate id _ = isOneOcc (idOccInfo id)
+
+ -- Note [conapp]
+ --
+ -- It's really really important to inline dictionaries. Real
+ -- example (the Enum Ordering instance from GHC.Base):
+ --
-- rec f = \ x -> case d of (p,q,r) -> p x
-- g = \ x -> case d of (p,q,r) -> q x
-- d = (v, f, g)
-- On the other hand we *could* simplify those case expressions if
-- we didn't stupidly choose d as the loop breaker.
-- But we won't because constructor args are marked "Many".
+ -- Inlining dictionaries is really essential to unravelling
+ -- the loops in static numeric dictionaries, see GHC.Float.
-- Cheap and cheerful; the simplifer moves casts out of the way
-- The lambda case is important to spot x = /\a. C (f a)
-- Note [Closure conversion]
is_con_app (Var v) = isDataConWorkId v
is_con_app (App f _) = is_con_app f
- is_con_app (Lam b e) = is_con_app e
+ is_con_app (Lam _ e) = is_con_app e
is_con_app (Note _ e) = is_con_app e
- is_con_app other = False
-
-makeLoopBreaker :: VarSet -- Binders of this group
- -> UsageDetails -- Usage of this rhs (neglecting rules)
- -> Id -> Id
--- Set the loop-breaker flag, recording whether the thing occurs only in
--- the RHS of a RULE (in this recursive group)
-makeLoopBreaker bndrs rhs_usg bndr
- = setIdOccInfo bndr (IAmALoopBreaker rules_only)
- where
- rules_only = bndrs `intersectsUFM` rhs_usg
+ is_con_app _ = False
+
+makeLoopBreaker :: Bool -> Id -> Id
+-- Set the loop-breaker flag
+-- See Note [Weak loop breakers]
+makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
\end{code}
-Note [Inline candidates]
+Note [Worker inline loop]
~~~~~~~~~~~~~~~~~~~~~~~~
-At one point I gave is_con_app a higher score than inline-candidate,
-on the grounds that "it's *really* helpful if dictionaries get inlined fast".
-However a nofib run revealed no change if they were swapped so that
-inline-candidate has the higher score. And it's important that it does,
-else you can get a bad worker-wrapper split thus:
+Never choose a wrapper as the loop breaker! Because
+wrappers get auto-generated inlinings when importing, and
+that can lead to an infinite inlining loop. For example:
rec {
$wfoo x = ....foo x....
{-loop brk-} foo x = ...$wfoo x...
}
-But we *want* the wrapper to be inlined! If it isn't, the interface
-file sees the unfolding for $wfoo, and sees that foo is strict (and
-hence it gets an auto-generated wrapper. Result: an infinite inlining
-in the importing scope. So be a bit careful if you change this. A
-good example is Tree.repTree in nofib/spectral/minimax. If is_con_app
-has the higher score, then compiling Game.hs goes into an infinite loop.
-
-Note [Recursive rules]
-~~~~~~~~~~~~~~~~~~~~~~
-Consider this group, which is typical of what SpecConstr builds:
-
- fs a = ....f (C a)....
- f x = ....f (C a)....
- {-# RULE f (C a) = fs a #-}
-
-So 'f' and 'fs' are mutually recursive. If we choose 'fs' as the loop breaker,
-all is well; the RULE is applied, and 'fs' becomes self-recursive.
-
-But if we choose 'f' as the loop breaker, we may get an infinite loop:
- - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
- - fs is inlined (say it's small)
- - now there's another opportunity to apply the RULE
-So it's very important to choose the RULE-variable as the loop breaker.
-This showed up when compiling Control.Concurrent.Chan.getChanContents.
+The interface file sees the unfolding for $wfoo, and sees that foo is
+strict (and hence it gets an auto-generated wrapper). Result: an
+infinite inlining in the importing scope. So be a bit careful if you
+change this. A good example is Tree.repTree in
+nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
+breaker then compiling Game.hs goes into an infinite loop (this
+happened when we gave is_con_app a lower score than inline candidates).
Note [Closure conversion]
~~~~~~~~~~~~~~~~~~~~~~~~~
certainly_inline id = case idOccInfo id of
OneOcc in_lam one_br _ -> not in_lam && one_br
- other -> False
+ _ -> False
\end{code}
-Note [RulesOnly]
-~~~~~~~~~~~~~~~~~~
-If the binder has RULES inside it then we count the specialised Ids as
-"extra rhs's". That way the "parent" keeps the specialised "children"
-alive. If the parent dies (because it isn't referenced any more),
-then the children will die too unless they are already referenced
-directly.
-
-That's the basic idea. However in a recursive situation we want to be a bit
-cleverer. Example (from GHC.Enum):
-
- eftInt :: Int# -> Int# -> [Int]
- eftInt x y = ...(non-recursive)...
-
- {-# INLINE [0] eftIntFB #-}
- eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
- eftIntFB c n x y = ...(non-recursive)...
-
- {-# RULES
- "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
- "eftIntList" [1] eftIntFB (:) [] = eftInt
- #-}
-
-The two look mutually recursive only because of their RULES; we don't want
-that to inhibit inlining!
-
-So when we identify a LoopBreaker, we mark it to say whether it only mentions
-the other binders in its recursive group in a RULE. If so, we can inline it,
-because doing so will not expose new occurrences of binders in its group.
\begin{code}
-
addRuleUsage :: UsageDetails -> Id -> UsageDetails
-- Add the usage from RULES in Id to the usage
addRuleUsage usage id
-> (UsageDetails, -- Gives info only about the "interesting" Ids
CoreExpr)
-occAnal env (Type t) = (emptyDetails, Type t)
+occAnal _ (Type t) = (emptyDetails, Type t)
occAnal env (Var v) = (mkOneOcc env v False, Var v)
-- At one stage, I gathered the idRuleVars for v here too,
-- which in a way is the right thing to do.
- -- Btu that went wrong right after specialisation, when
+ -- But that went wrong right after specialisation, when
-- the *occurrences* of the overloaded function didn't have any
-- rules in them, so the *specialised* versions looked as if they
-- weren't used at all.
Constructors are rather like lambdas in this way.
\begin{code}
-occAnal env expr@(Lit lit) = (emptyDetails, expr)
+occAnal _ expr@(Lit _) = (emptyDetails, expr)
\end{code}
\begin{code}
(mapVarEnv markMany usage, Note InlineMe body')
}
-occAnal env (Note note@(SCC cc) body)
+occAnal env (Note note@(SCC _) body)
= case occAnal env body of { (usage, body') ->
(mapVarEnv markInsideSCC usage, Note note body')
}
\end{code}
\begin{code}
-occAnal env app@(App fun arg)
- = occAnalApp env (collectArgs app) False
+occAnal env app@(App _ _)
+ = occAnalApp env (collectArgs app)
-- Ignore type variables altogether
-- (a) occurrences inside type lambdas only not marked as InsideLam
-- (b) type variables not in environment
-occAnal env expr@(Lam x body) | isTyVar x
+occAnal env (Lam x body) | isTyVar x
= case occAnal env body of { (body_usage, body') ->
(body_usage, Lam x body')
}
occ_anal_scrut (Var v) (alt1 : other_alts)
| not (null other_alts) || not (isDefaultAlt alt1)
= (mkOneOcc env v True, Var v)
- occ_anal_scrut scrut alts = occAnal vanillaCtxt scrut
+ occ_anal_scrut scrut _alts = occAnal vanillaCtxt scrut
-- No need for rhsCtxt
occAnal env (Let bind body)
case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
(final_usage, mkLets new_binds body') }}
-occAnalArgs env args
+occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
+occAnalArgs _env args
= case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
(foldr (+++) emptyDetails arg_uds_s, args')}
where
the "build hack" to work.
\begin{code}
-occAnalApp env (Var fun, args) is_rhs
+occAnalApp :: OccEnv
+ -> (Expr CoreBndr, [Arg CoreBndr])
+ -> (UsageDetails, Expr CoreBndr)
+occAnalApp env (Var fun, args)
= case args_stuff of { (args_uds, args') ->
let
final_args_uds = markRhsUds env is_pap args_uds
| otherwise = occAnalArgs env args
-occAnalApp env (fun, args) is_rhs
+occAnalApp env (fun, args)
= case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
-- The addAppCtxt is a bit cunning. One iteration of the simplifier
-- often leaves behind beta redexs like
where
arg_env = vanillaCtxt
- go n [] = (emptyDetails, []) -- Too few args
+ go _ [] = (emptyDetails, []) -- Too few args
go 1 (arg:args) -- The magic arg
= case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
isDeadBinder in Simplify.mkDupableAlt
\begin{code}
-occAnalAlt env case_bndr (con, bndrs, rhs)
+occAnalAlt :: OccEnv
+ -> CoreBndr
+ -> CoreAlt
+ -> (UsageDetails, Alt IdWithOccInfo)
+occAnalAlt env _case_bndr (con, bndrs, rhs)
= case occAnal env rhs of { (rhs_usage, rhs') ->
let
(final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
initOccEnv :: OccEnv
initOccEnv = OccEnv OccRhs []
+vanillaCtxt :: OccEnv
vanillaCtxt = OccEnv OccVanilla []
+
+rhsCtxt :: OccEnv
rhsCtxt = OccEnv OccRhs []
+isRhsEnv :: OccEnv -> Bool
isRhsEnv (OccEnv OccRhs _) = True
isRhsEnv (OccEnv OccVanilla _) = False
-- linearity context knows that c,n are one-shot, and it records that fact in
-- the binder. This is useful to guide subsequent float-in/float-out tranformations
-oneShotGroup (OccEnv encl ctxt) bndrs
+oneShotGroup (OccEnv _encl ctxt) bndrs
= go ctxt bndrs []
where
- go ctxt [] rev_bndrs = reverse rev_bndrs
+ go _ [] rev_bndrs = reverse rev_bndrs
go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
| isId bndr = go ctxt bndrs (bndr':rev_bndrs)
go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
+addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
addAppCtxt (OccEnv encl ctxt) args
= OccEnv encl (replicate (valArgCount args) True ++ ctxt)
\end{code}
= plusVarEnv_C addOccInfo usage (unitVarEnv id info)
-- ToDo: make this more efficient
+emptyDetails :: UsageDetails
emptyDetails = (emptyVarEnv :: UsageDetails)
usedIn :: Id -> UsageDetails -> Bool
| isTyVar bndr = bndr
| isExportedId bndr = case idOccInfo bndr of
NoOccInfo -> bndr
- other -> setIdOccInfo bndr NoOccInfo
+ _ -> setIdOccInfo bndr NoOccInfo
-- Don't use local usage info for visible-elsewhere things
-- BUT *do* erase any IAmALoopBreaker annotation, because we're
-- about to re-generate it and it shouldn't be "sticky"
\begin{code}
mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
-mkOneOcc env id int_cxt
+mkOneOcc _env id int_cxt
| isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
| otherwise = emptyDetails
markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
markMany IAmDead = IAmDead
-markMany other = NoOccInfo
+markMany _ = NoOccInfo
markInsideSCC occ = markMany occ
addOccInfo IAmDead info2 = info2
addOccInfo info1 IAmDead = info1
-addOccInfo info1 info2 = NoOccInfo
+addOccInfo _ _ = NoOccInfo
-- (orOccInfo orig new) is used
-- when combining occurrence info from branches of a case
orOccInfo IAmDead info2 = info2
orOccInfo info1 IAmDead = info1
-orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1)
- (OneOcc in_lam2 one_branch2 int_cxt2)
+orOccInfo (OneOcc in_lam1 _ int_cxt1)
+ (OneOcc in_lam2 _ int_cxt2)
= OneOcc (in_lam1 || in_lam2)
False -- False, because it occurs in both branches
(int_cxt1 && int_cxt2)
-orOccInfo info1 info2 = NoOccInfo
+orOccInfo _ _ = NoOccInfo
\end{code}
projects / ghc-hetmet.git / blobdiff