import CoreSyn
import CoreFVs
-import Type ( tyVarsOfType )
-import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp )
-import Coercion ( CoercionI(..), mkSymCoI )
+import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )
import Id
-import Name ( localiseName )
+import NameEnv
+import NameSet
+import Name ( Name, localiseName )
import BasicTypes
+import Coercion
import VarSet
import VarEnv
-import Var ( Var, varUnique )
+import Var
import Maybes ( orElse )
import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
-import Unique ( Unique )
-import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )
+import Unique
+import UniqFM
import Util ( mapAndUnzip, filterOut )
import Bag
import Outputable
Here's the externally-callable interface:
\begin{code}
-occurAnalysePgm :: [CoreBind] -> [CoreRule] -> [CoreBind]
-occurAnalysePgm binds rules
- = snd (go initOccEnv binds)
+occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] -> [CoreVect]
+ -> [CoreBind] -> [CoreBind]
+occurAnalysePgm active_rule imp_rules vects binds
+ = snd (go (initOccEnv active_rule imp_rules) binds)
where
- initial_details = addIdOccs emptyDetails (rulesFreeVars rules)
- -- The RULES keep things alive!
+ initial_uds = addIdOccs emptyDetails
+ (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects)
+ -- The RULES and VECTORISE declarations keep things alive!
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
go _ []
- = (initial_details, [])
+ = (initial_uds, [])
go env (bind:binds)
= (final_usage, bind' ++ binds')
where
occurAnalyseExpr :: CoreExpr -> CoreExpr
-- Do occurrence analysis, and discard occurence info returned
-occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
+occurAnalyseExpr expr
+ = snd (occAnal (initOccEnv all_active_rules []) expr)
+ where
+ -- To be conservative, we say that all inlines and rules are active
+ all_active_rules = Just (\_ -> True)
\end{code}
[CoreBind])
occAnalBind env _ (NonRec binder rhs) body_usage
- | isTyCoVar binder -- A type let; we don't gather usage info
+ | isTyVar binder -- A type let; we don't gather usage info
= (body_usage, [NonRec binder rhs])
| not (binder `usedIn` body_usage) -- It's not mentioned
= (body_usage, [])
| otherwise -- It's mentioned in the body
- = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
- [NonRec tagged_binder rhs'])
+ = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs'])
where
(body_usage', tagged_binder) = tagBinder body_usage binder
- (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
+ (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs
+ rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder)
+ rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder)
+ -- See Note [Rules are extra RHSs] and Note [Rule dependency info]
\end{code}
Note [Dead code]
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.
+ 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
+ These are rec_edges.
+
+ Under (b) 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
[Rules for recursive functions] in Simplify.lhs
Hence, if
- f's RHS mentions g, and
+ f's RHS (or its INLINE template if it has one) mentions g, and
g has a RULE that mentions h, and
h has a RULE that mentions f
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.)
+ See also Note [Finding rule RHS free vars]
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 if 'g' has RHS that mentions 'w', we should add w to
+ g's loop-breaker edges. More concretely there is an edge from f -> g
+ iff
+ (a) g is mentioned in f's RHS
+ (b) h is mentioned in f's RHS, and
+ g appears in the RHS of a RULE of h
+ or a transitive sequence of rules starting with h
+
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.
rec_edges for the Rec block analysis
loop_breaker_edges for the loop breaker analysis
-
+ * Note [Finding rule RHS free vars]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ Consider this real example from Data Parallel Haskell
+ tagZero :: Array Int -> Array Tag
+ {-# INLINE [1] tagZeroes #-}
+ tagZero xs = pmap (\x -> fromBool (x==0)) xs
+
+ {-# RULES "tagZero" [~1] forall xs n.
+ pmap fromBool <blah blah> = tagZero xs #-}
+ So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.
+ However, tagZero can only be inlined in phase 1 and later, while
+ the RULE is only active *before* phase 1. So there's no problem.
+
+ To make this work, we look for the RHS free vars only for
+ *active* rules. That's the reason for the is_active argument
+ to idRhsRuleVars, and the occ_rule_act field of the OccEnv.
+
* Note [Weak loop breakers]
~~~~~~~~~~~~~~~~~~~~~~~~~
There is a last nasty wrinkle. Suppose we have
...more...
}
- Remmber that we simplify the RULES before any RHS (see Note
+ Remember 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
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The VarSet in a SpecInfo is used for dependency analysis in the
occurrence analyser. We must track free vars in *both* lhs and rhs.
- Hence use of idRuleVars, rather than idRuleRhsVars in addRuleUsage.
+ Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.
Why both? Consider
x = y
RULE f x = 4
at the same time as the regular RHS of the function, so it should
be treated *exactly* like an extra RHS.
+ There is a danger that we'll be sub-optimal if we see this
+ f = ...f...
+ [INLINE f = ..no f...]
+ where f is recursive, but the INLINE is not. This can just about
+ happen with a sufficiently odd set of rules; eg
+
+ foo :: Int -> Int
+ {-# INLINE [1] foo #-}
+ foo x = x+1
+
+ bar :: Int -> Int
+ {-# INLINE [1] bar #-}
+ bar x = foo x + 1
+
+ {-# RULES "foo" [~1] forall x. foo x = bar x #-}
+
+ Here the RULE makes bar recursive; but it's INLINE pragma remains
+ non-recursive. It's tempting to then say that 'bar' should not be
+ a loop breaker, but an attempt to do so goes wrong in two ways:
+ a) We may get
+ $df = ...$cfoo...
+ $cfoo = ...$df....
+ [INLINE $cfoo = ...no-$df...]
+ But we want $cfoo to depend on $df explicitly so that we
+ put the bindings in the right order to inline $df in $cfoo
+ and perhaps break the loop altogether. (Maybe this
+ b)
+
+
Example [eftInt]
~~~~~~~~~~~~~~~
\begin{code}
occAnalBind _ env (Rec pairs) body_usage
- = foldr occAnalRec (body_usage, []) sccs
+ = foldr (occAnalRec env) (body_usage, []) sccs
-- For a recursive group, we
-- * occ-analyse all the RHSs
-- * compute strongly-connected components
rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
make_node (bndr, rhs)
- = (ND bndr rhs' all_rhs_usage rhs_fvs, varUnique bndr, out_edges)
- where
- (rhs_usage, rhs') = occAnalRhs env bndr rhs
- all_rhs_usage = addIdOccs rhs_usage rule_vars -- Note [Rules are extra RHSs]
- rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
- out_edges = keysUFM (rhs_fvs `unionVarSet` rule_vars)
- rule_vars = idRuleVars bndr -- See Note [Rule dependency info]
+ = (details, varUnique bndr, keysUFM out_edges)
+ where
+ details = ND { nd_bndr = bndr, nd_rhs = rhs'
+ , nd_uds = rhs_usage3, nd_inl = inl_fvs}
+
+ (rhs_usage1, rhs') = occAnalRhs env Nothing rhs
+ rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs]
+ rhs_usage3 = addIdOccs rhs_usage2 unf_fvs
+ unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag
+ unf_fvs = stableUnfoldingVars unf
+ rule_fvs = idRuleVars bndr -- See Note [Rule dependency info]
+
+ inl_fvs = rhs_fvs `unionVarSet` unf_fvs
+ rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1
+ out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3
-- (a -> b) means a mentions b
-- Given the usage details (a UFM that gives occ info for each free var of
-- the RHS) we can get the list of free vars -- or rather their Int keys --
-- consumed 10% of total runtime!
-----------------------------
-occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
- -> (UsageDetails, [CoreBind])
+occAnalRec :: OccEnv -> SCC (Node Details)
+ -> (UsageDetails, [CoreBind])
+ -> (UsageDetails, [CoreBind])
-- The NonRec case is just like a Let (NonRec ...) above
-occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
+occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _))
+ (body_usage, binds)
| not (bndr `usedIn` body_usage)
= (body_usage, binds)
-- The Rec case is the interesting one
-- See Note [Loop breaking]
-occAnalRec (CyclicSCC nodes) (body_usage, binds)
+occAnalRec env (CyclicSCC nodes) (body_usage, binds)
| not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
= (body_usage, binds) -- Dead code
= (final_usage, Rec pairs : binds)
where
- bndrs = [b | (ND b _ _ _, _, _) <- nodes]
+ bndrs = [b | (ND { nd_bndr = b }, _, _) <- nodes]
bndr_set = mkVarSet bndrs
+ non_boring bndr = isId bndr &&
+ (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr)
----------------------------
-- Tag the binders with their occurrence info
total_usage = foldl add_usage body_usage nodes
- add_usage usage_so_far (ND _ _ rhs_usage _, _, _) = usage_so_far +++ rhs_usage
+ add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage
(final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
-- saying "no preInlineUnconditionally" if it is used
-- in any rule (lhs or rhs) of the recursive group
-- See Note [Weak loop breakers]
- tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
- = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
+ tag_node usage (details@ND { nd_bndr = bndr }, k, ks)
+ = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks))
where
bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
| otherwise = bndr1
----------------------------
-- Now reconstruct the cycle
- pairs | no_rules = reOrderCycle 0 tagged_nodes []
- | otherwise = foldr (reOrderRec 0) [] $
- stronglyConnCompFromEdgedVerticesR loop_breaker_edges
+ pairs | any non_boring bndrs
+ = foldr (reOrderRec 0) [] $
+ stronglyConnCompFromEdgedVerticesR loop_breaker_edges
+ | otherwise
+ = reOrderCycle 0 tagged_nodes []
-- See Note [Choosing loop breakers] for loop_breaker_edges
loop_breaker_edges = map mk_node tagged_nodes
- mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
+ mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks)
where
- new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
+ new_ks = keysUFM (fst (extendFvs rule_fv_env inl_fvs))
------------------------------------
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
- , isId b
- , 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
-
-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
+ rule_fv_env = transClosureFV init_rule_fvs
+ init_rule_fvs
+ | Just is_active <- occ_rule_act env -- See Note [Finding rule RHS free vars]
+ = [ (b, rule_fvs)
+ | b <- bndrs
+ , isId b
+ , let rule_fvs = idRuleRhsVars is_active b
+ `intersectVarSet` bndr_set
+ , not (isEmptyVarSet rule_fvs)]
+ | otherwise
+ = []
\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.
-data Details = ND Id -- Binder
- CoreExpr -- RHS
+data Details
+ = ND { nd_bndr :: Id -- Binder
+ , nd_rhs :: CoreExpr -- RHS
- UsageDetails -- Full usage from RHS,
- -- including *both* RULES *and* InlineRule unfolding
+ , nd_uds :: UsageDetails -- Usage from RHS,
+ -- including RULES and InlineRule unfolding
- IdSet -- Other binders *from this Rec group* mentioned in
- -- * the RHS
- -- * any InlineRule unfolding
- -- but *excluding* any RULES
+ , nd_inl :: IdSet -- Other binders *from this Rec group* mentioned in
+ } -- its InlineRule unfolding (if present)
+ -- AND the RHS
+ -- but *excluding* any RULES
+ -- This is the IdSet that may be used if the Id is inlined
reOrderRec :: Int -> SCC (Node Details)
-> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
-- Sorted into a plausible order. Enough of the Ids have
-- IAmALoopBreaker pragmas that there are no loops left.
-reOrderRec _ (AcyclicSCC (ND bndr rhs _ _, _, _)) pairs = (bndr, rhs) : pairs
-reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs
+reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _))
+ pairs = (bndr, rhs) : pairs
+reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs
reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
reOrderCycle _ [] _
= panic "reOrderCycle"
-reOrderCycle _ [bind] pairs -- Common case of simple self-recursion
- = (makeLoopBreaker False bndr, rhs) : pairs
- where
- (ND bndr rhs _ _, _, _) = bind
+reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs
+ = -- Common case of simple self-recursion
+ (makeLoopBreaker False bndr, rhs) : pairs
reOrderCycle depth (bind : binds) pairs
= -- Choose a loop breaker, mark it no-inline,
-- do SCC analysis on the rest, and recursively sort them out
--- pprTrace "reOrderCycle" (ppr [b | (ND b _ _ _, _, _) <- bind:binds]) $
+-- pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $
foldr (reOrderRec new_depth)
([ (makeLoopBreaker False bndr, rhs)
- | (ND bndr rhs _ _, _, _) <- chosen_binds] ++ pairs)
+ | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs)
(stronglyConnCompFromEdgedVerticesR unchosen)
where
(chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds
sc = score bind
score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
- score (ND bndr rhs _ _, _, _)
- | not (isId bndr) = 100 -- A type or cercion varialbe is never a loop breaker
+ score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)
+ | not (isId bndr) = 100 -- A type or cercion variable is never a loop breaker
| isDFunId bndr = 9 -- Never choose a DFun as a loop breaker
-- Note [DFuns should not be loop breakers]
- | Just (inl_source, _) <- isInlineRule_maybe (idUnfolding bndr)
+ | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)
= case inl_source of
InlineWrapper {} -> 10 -- Note [INLINE pragmas]
_other -> 3 -- Data structures are more important than this
\begin{code}
occAnalRhs :: OccEnv
- -> Id -> CoreExpr -- Binder and rhs
- -- For non-recs the binder is alrady tagged
- -- with occurrence info
+ -> Maybe Id -> CoreExpr -- Binder and rhs
+ -- Just b => non-rec, and alrady tagged with occurrence info
+ -- Nothing => Rec, no occ info
-> (UsageDetails, CoreExpr)
- -- Returned usage details includes any INLINE rhs
-
-occAnalRhs env id rhs
- | isId id = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
- | otherwise = (rhs_usage, rhs')
- -- Include occurrences for the "extra RHS" from a CoreUnfolding
+ -- Returned usage details covers only the RHS,
+ -- and *not* the RULE or INLINE template for the Id
+occAnalRhs env mb_bndr rhs
+ = occAnal ctxt rhs
where
- (rhs_usage, rhs') = occAnal ctxt rhs
- ctxt | certainly_inline id = env
- | otherwise = rhsCtxt env
- -- Note that we generally use an rhsCtxt. This tells the occ anal n
- -- that it's looking at an RHS, which has an effect in occAnalApp
- --
- -- But there's a problem. Consider
- -- x1 = a0 : []
- -- x2 = a1 : x1
- -- x3 = a2 : x2
- -- g = f x3
- -- First time round, it looks as if x1 and x2 occur as an arg of a
- -- let-bound constructor ==> give them a many-occurrence.
- -- But then x3 is inlined (unconditionally as it happens) and
- -- next time round, x2 will be, and the next time round x1 will be
- -- Result: multiple simplifier iterations. Sigh.
- -- Crude solution: use rhsCtxt for things that occur just once...
-
- certainly_inline id = case idOccInfo id of
- OneOcc in_lam one_br _ -> not in_lam && one_br
- _ -> False
-\end{code}
-
-
-
-\begin{code}
-addRuleUsage :: UsageDetails -> Var -> UsageDetails
--- Add the usage from RULES in Id to the usage
-addRuleUsage usage var
- | isId var = addIdOccs usage (idRuleVars var)
- | otherwise = usage
- -- idRuleVars here: see Note [Rule dependency info]
+ -- See Note [Cascading inlines]
+ ctxt = case mb_bndr of
+ Just b | certainly_inline b -> env
+ _other -> rhsCtxt env
+
+ certainly_inline bndr -- See Note [Cascading inlines]
+ = case idOccInfo bndr of
+ OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable
+ _ -> False
+ where
+ active = isAlwaysActive (idInlineActivation bndr)
+ not_stable = not (isStableUnfolding (idUnfolding bndr))
addIdOccs :: UsageDetails -> VarSet -> UsageDetails
addIdOccs usage id_set = foldVarSet add usage id_set
-- (Same goes for INLINE.)
\end{code}
+Note [Cascading inlines]
+~~~~~~~~~~~~~~~~~~~~~~~~
+By default we use an rhsCtxt for the RHS of a binding. This tells the
+occ anal n that it's looking at an RHS, which has an effect in
+occAnalApp. In particular, for constructor applications, it makes
+the arguments appear to have NoOccInfo, so that we don't inline into
+them. Thus x = f y
+ k = Just x
+we do not want to inline x.
+
+But there's a problem. Consider
+ x1 = a0 : []
+ x2 = a1 : x1
+ x3 = a2 : x2
+ g = f x3
+First time round, it looks as if x1 and x2 occur as an arg of a
+let-bound constructor ==> give them a many-occurrence.
+But then x3 is inlined (unconditionally as it happens) and
+next time round, x2 will be, and the next time round x1 will be
+Result: multiple simplifier iterations. Sigh.
+
+So, when analysing the RHS of x3 we notice that x3 will itself
+definitely inline the next time round, and so we analyse x3's rhs in
+an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff.
+
+Annoyingly, we have to approximiate SimplUtils.preInlineUnconditionally.
+If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates
+indefinitely:
+ x = f y
+ k = Just x
+inline ==>
+ k = Just (f y)
+float ==>
+ x1 = f y
+ k = Just x1
+
+This is worse than the slow cascade, so we only want to say "certainly_inline"
+if it really is certain. Look at the note with preInlineUnconditionally
+for the various clauses.
+
Expressions
~~~~~~~~~~~
\begin{code}
-> (UsageDetails, -- Gives info only about the "interesting" Ids
CoreExpr)
-occAnal _ (Type t) = (emptyDetails, Type t)
-occAnal env (Var v) = (mkOneOcc env v False, Var v)
+occAnal _ expr@(Type _) = (emptyDetails, expr)
+occAnal _ expr@(Lit _) = (emptyDetails, expr)
+occAnal env expr@(Var v) = (mkOneOcc env v False, expr)
-- At one stage, I gathered the idRuleVars for v here too,
-- which in a way is the right thing to do.
-- 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.
-\end{code}
-We regard variables that occur as constructor arguments as "dangerousToDup":
-
-\begin{verbatim}
-module A where
-f x = let y = expensive x in
- let z = (True,y) in
- (case z of {(p,q)->q}, case z of {(p,q)->q})
-\end{verbatim}
-
-We feel free to duplicate the WHNF (True,y), but that means
-that y may be duplicated thereby.
+occAnal _ (Coercion co)
+ = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
+ -- See Note [Gather occurrences of coercion veriables]
+\end{code}
-If we aren't careful we duplicate the (expensive x) call!
-Constructors are rather like lambdas in this way.
+Note [Gather occurrences of coercion veriables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to gather info about what coercion variables appear, so that
+we can sort them into the right place when doing dependency analysis.
\begin{code}
-occAnal _ expr@(Lit _) = (emptyDetails, expr)
\end{code}
\begin{code}
occAnal env (Cast expr co)
= case occAnal env expr of { (usage, expr') ->
- (markManyIf (isRhsEnv env) usage, Cast expr' co)
+ let usage1 = markManyIf (isRhsEnv env) usage
+ usage2 = addIdOccs usage1 (coVarsOfCo co)
+ -- See Note [Gather occurrences of coercion veriables]
+ in (usage2, Cast expr' co)
-- If we see let x = y `cast` co
-- then mark y as 'Many' so that we don't
-- immediately inline y again.
-- (a) occurrences inside type lambdas only not marked as InsideLam
-- (b) type variables not in environment
-occAnal env (Lam x body) | isTyCoVar x
+occAnal env (Lam x body) | isTyVar x
= case occAnal env body of { (body_usage, body') ->
(body_usage, Lam x body')
}
Applications are dealt with specially because we want
the "build hack" to work.
+Note [Arguments of let-bound constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ f x = let y = expensive x in
+ let z = (True,y) in
+ (case z of {(p,q)->q}, case z of {(p,q)->q})
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
+
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
+
\begin{code}
occAnalApp :: OccEnv
-> (Expr CoreBndr, [Arg CoreBndr])
-- arguments are just variables, or trivial expressions.
--
-- This is the *whole point* of the isRhsEnv predicate
+ -- See Note [Arguments of let-bound constructors]
in
(fun_uds +++ final_args_uds, mkApps (Var fun) args') }
where
where
(body_usg', tagged_bndr) = tagBinder body_usg bndr
rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
- rhs = mkCoerceI co (Var rhs_var)
+ rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
\end{code}
\begin{code}
data OccEnv
- = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
- , occ_ctxt :: !CtxtTy -- Tells about linearity
- , occ_proxy :: ProxyEnv }
+ = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
+ , occ_ctxt :: !CtxtTy -- Tells about linearity
+ , occ_proxy :: ProxyEnv
+ , occ_rule_fvs :: ImpRuleUsage
+ , occ_rule_act :: Maybe (Activation -> Bool) -- Nothing => Rules are inactive
+ -- See Note [Finding rule RHS free vars]
+ }
-----------------------------
-- be applied many times; but when it is,
-- the CtxtTy inside applies
-initOccEnv :: OccEnv
-initOccEnv = OccEnv { occ_encl = OccVanilla
- , occ_ctxt = []
- , occ_proxy = PE emptyVarEnv emptyVarSet }
+initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule]
+ -> OccEnv
+initOccEnv active_rule imp_rules
+ = OccEnv { occ_encl = OccVanilla
+ , occ_ctxt = []
+ , occ_proxy = PE emptyVarEnv emptyVarSet
+ , occ_rule_fvs = findImpRuleUsage active_rule imp_rules
+ , occ_rule_act = active_rule }
vanillaCtxt :: OccEnv -> OccEnv
-vanillaCtxt env = OccEnv { occ_encl = OccVanilla
- , occ_ctxt = []
- , occ_proxy = occ_proxy env }
+vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] }
rhsCtxt :: OccEnv -> OccEnv
-rhsCtxt env = OccEnv { occ_encl = OccRhs, occ_ctxt = []
- , occ_proxy = occ_proxy env }
+rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] }
setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
setCtxtTy env ctxt = env { occ_ctxt = ctxt }
%************************************************************************
%* *
+ ImpRuleUsage
+%* *
+%************************************************************************
+
+\begin{code}
+type ImpRuleUsage = NameEnv UsageDetails
+ -- Maps an *imported* Id f to the UsageDetails for *local* Ids
+ -- used on the RHS for a *local* rule for f.
+\end{code}
+
+Note [ImpRuleUsage]
+~~~~~~~~~~~~~~~~
+Consider this, where A.g is an imported Id
+
+ f x = A.g x
+ {-# RULE "foo" forall x. A.g x = f x #-}
+
+Obviously there's a loop, but the danger is that the occurrence analyser
+will say that 'f' is not a loop breaker. Then the simplifier will
+optimise 'f' to
+ f x = f x
+and then gaily inline 'f'. Result infinite loop. More realistically,
+these kind of rules are generated when specialising imported INLINABLE Ids.
+
+Solution: treat an occurrence of A.g as an occurrence of all the local Ids
+that occur on the RULE's RHS. This mapping from imported Id to local Ids
+is held in occ_rule_fvs.
+
+\begin{code}
+findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage
+-- Find the *local* Ids that can be reached transitively,
+-- via local rules, from each *imported* Id.
+-- Sigh: this function seems more complicated than it is really worth
+findImpRuleUsage Nothing _ = emptyNameEnv
+findImpRuleUsage (Just is_active) rules
+ = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls)
+ | f <- rule_names
+ , let ls = find_lcl_deps f
+ , not (isEmptyVarSet ls) ]
+ where
+ rule_names = map ru_fn rules
+ rule_name_set = mkNameSet rule_names
+
+ imp_deps :: NameEnv VarSet
+ -- (f,g) means imported Id 'g' appears in RHS of
+ -- rule for imported Id 'f', *or* does so transitively
+ imp_deps = foldr add_imp emptyNameEnv rules
+ add_imp rule acc
+ | is_active (ruleActivation rule)
+ = extendNameEnv_C unionVarSet acc (ru_fn rule)
+ (exprSomeFreeVars keep_imp (ru_rhs rule))
+ | otherwise = acc
+ keep_imp v = isId v && (idName v `elemNameSet` rule_name_set)
+ full_imp_deps = transClosureFV (ufmToList imp_deps)
+
+ lcl_deps :: NameEnv VarSet
+ -- (f, l) means localId 'l' appears immediately
+ -- in the RHS of a rule for imported Id 'f'
+ -- Remember, many rules might have the same ru_fn
+ -- so we do need to fold
+ lcl_deps = foldr add_lcl emptyNameEnv rules
+ add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule)
+ (exprFreeIds (ru_rhs rule))
+
+ find_lcl_deps :: Name -> VarSet
+ find_lcl_deps f
+ = foldVarSet (unionVarSet . lookup_lcl . idName) (lookup_lcl f)
+ (lookupNameEnv full_imp_deps f `orElse` emptyVarSet)
+ lookup_lcl :: Name -> VarSet
+ lookup_lcl g = lookupNameEnv lcl_deps g `orElse` emptyVarSet
+
+-------------
+transClosureFV :: Uniquable a => [(a, VarSet)] -> UniqFM VarSet
+-- If (f,g), (g,h) are in the input, then (f,h) is in the output
+transClosureFV fv_list
+ | no_change = env
+ | otherwise = transClosureFV new_fv_list
+ where
+ env = listToUFM fv_list
+ (no_change, new_fv_list) = mapAccumL bump True fv_list
+ bump no_change (b,fvs)
+ | no_change_here = (no_change, (b,fvs))
+ | otherwise = (False, (b,new_fvs))
+ where
+ (new_fvs, no_change_here) = extendFvs env fvs
+
+-------------
+extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
+-- (extendFVs env s) returns
+-- (s `union` env(s), env(s) `subset` s)
+extendFvs env s
+ = foldVarSet add (s, True) s
+ where
+ add v (vs, no_change_so_far)
+ = case lookupUFM env v of
+ Just fvs | not (fvs `subVarSet` s)
+ -> (vs `unionVarSet` fvs, False)
+ _ -> (vs, no_change_so_far)
+\end{code}
+
+
+%************************************************************************
+%* *
ProxyEnv
%* *
%************************************************************************
\begin{code}
-data ProxyEnv
- = PE (IdEnv (Id, [(Id,CoercionI)])) VarSet
- -- Main env, and its free variables (of both range and domain)
+data ProxyEnv -- See Note [ProxyEnv]
+ = PE (IdEnv -- Domain = scrutinee variables
+ (Id, -- The scrutinee variable again
+ [(Id,Coercion)])) -- The case binders that it maps to
+ VarSet -- Free variables of both range and domain
\end{code}
Note [ProxyEnv]
element without losing correctness. And we do so when pushing
it inside a binding (see trimProxyEnv).
- * Once scrutinee might map to many case binders: Eg
+ * One scrutinee might map to many case binders: Eg
case sc of cb1 { DEFAULT -> ....case sc of cb2 { ... } .. }
INVARIANTS
The Main Reason for having a ProxyEnv is so that when we encounter
case e of cb { pi -> ri }
we can find all the in-scope variables derivable from 'cb',
-and effectively add let-bindings for them thus:
+and effectively add let-bindings for them (or at least for the
+ones *mentioned* in ri) thus:
case e of cb { pi -> let { x = ..cb..; y = ...cb.. }
in ri }
+In this way we'll replace occurrences of 'x', 'y' with 'cb',
+which implements the Binder-swap idea (see Note [Binder swap])
+
The function getProxies finds these bindings; then we
add just the necessary ones, using wrapProxy.
-More info under Note [Binder swap]
-
Note [Binder swap]
~~~~~~~~~~~~~~~~~~
We do these two transformations right here:
Notice that later bindings may mention earlier ones, and that
we need to go "both ways".
+Note [Zap case binders in proxy bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+From the original
+ case x of cb(dead) { p -> ...x... }
+we will get
+ case x of cb(live) { p -> let x = cb in ...x... }
+
+Core Lint never expects to find an *occurence* of an Id marked
+as Dead, so we must zap the OccInfo on cb before making the
+binding x = cb. See Trac #5028.
+
Historical note [no-case-of-case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We *used* to suppress the binder-swap in case expressions when
information right.
\begin{code}
-extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv
+extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv
-- (extendPE x co y) typically arises from
-- case (x |> co) of y { ... }
-- It extends the proxy env with the binding
env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
single cb_co = (scrut1, [cb_co])
add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
- fvs2 = fvs1 `unionVarSet` freeVarsCoI co
+ fvs2 = fvs1 `unionVarSet` tyCoVarsOfCo co
`extendVarSet` case_bndr
`extendVarSet` scrut1
-- Localise the scrut_var before shadowing it; we're making a
-- new binding for it, and it might have an External Name, or
-- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
- -- Also we don't want any INLILNE or NOINLINE pragmas!
+ -- Also we don't want any INLINE or NOINLINE pragmas!
-----------
-type ProxyBind = (Id, Id, CoercionI)
+type ProxyBind = (Id, Id, Coercion)
+ -- (scrut variable, case-binder variable, coercion)
getProxies :: OccEnv -> Id -> Bag ProxyBind
-- Return a bunch of bindings [...(xi,ei)...]
= -- pprTrace "wrapProxies" (ppr case_bndr) $
go_fwd case_bndr
where
- fwd_pe :: IdEnv (Id, CoercionI)
+ fwd_pe :: IdEnv (Id, Coercion)
fwd_pe = foldVarEnv add1 emptyVarEnv pe
where
add1 (x,ycos) env = foldr (add2 x) env ycos
go_fwd' case_bndr
| Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
- = unitBag (scrut, case_bndr, mkSymCoI co)
+ = unitBag (scrut, case_bndr, mkSymCo co)
`unionBags` go_fwd scrut
`unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
, cb /= case_bndr]
| otherwise
= emptyBag
- lookup_bwd :: Id -> [(Id, CoercionI)]
+ lookup_bwd :: Id -> [(Id, Coercion)]
-- Return case_bndrs that are connected to scrut
lookup_bwd scrut = case lookupVarEnv pe scrut of
Nothing -> []
Just (_, cb_cos) -> cb_cos
- go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind
+ go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind
go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
- go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind
+ go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind
go_bwd1 scrut (case_bndr, co)
= -- pprTrace "go_bwd1" (ppr case_bndr) $
unitBag (case_bndr, scrut, co)
where
pe = occ_proxy env
pe' = case scrut of
- Var v -> extendProxyEnv pe v (IdCo (idType v)) cb
- Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb
- _other -> trimProxyEnv pe [cb]
+ Var v -> extendProxyEnv pe v (mkReflCo (idType v)) cb
+ Cast (Var v) co -> extendProxyEnv pe v co cb
+ _other -> trimProxyEnv pe [cb]
-----------
trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv
trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
| otherwise = (scrut, filterOut discard cb_cos)
discard (cb,co) = bndr_set `intersectsVarSet`
- extendVarSet (freeVarsCoI co) cb
-
------------
-freeVarsCoI :: CoercionI -> VarSet
-freeVarsCoI (IdCo t) = tyVarsOfType t
-freeVarsCoI (ACo co) = tyVarsOfType co
+ extendVarSet (tyCoVarsOfCo co) cb
\end{code}
setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
setBinderOcc usage bndr
- | isTyCoVar bndr = bndr
+ | isTyVar bndr = bndr
| isExportedId bndr = case idOccInfo bndr of
NoOccInfo -> bndr
_ -> setIdOccInfo bndr NoOccInfo
| isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
| PE env _ <- occ_proxy env
, id `elemVarEnv` env = unitVarEnv id NoOccInfo
+ | Just uds <- lookupNameEnv (occ_rule_fvs env) (idName id)
+ = uds
| otherwise = emptyDetails
markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
projects / ghc-hetmet.git / blobdiff