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
import CoreUtils ( exprIsTrivial, isDefaultAlt )
+import Coercion ( mkSymCoercion )
import Id
import IdInfo
import BasicTypes
import VarEnv
import Maybes ( orElse )
-import Digraph ( stronglyConnCompR, SCC(..) )
+import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import Unique ( Unique )
import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )
[CoreBind])
occAnalBind env (NonRec binder rhs) body_usage
- | not (binder `usedIn` body_usage) -- It's not mentioned
+ | 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
\begin{code}
occAnalBind env (Rec pairs) body_usage
- | 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)
+ = foldr occAnalRec (body_usage, []) sccs
+ -- For a recursive group, we
+ -- * occ-analyse all the RHSs
+ -- * compute strongly-connected components
+ -- * feed those components to occAnalRec
where
- 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 rec_edges
-
- 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)
-
+ bndr_set = mkVarSet (map fst pairs)
+ sccs :: [SCC (Node Details)]
+ sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges
+
+ rec_edges :: [Node Details]
+ rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
+
+ make_node (bndr, rhs)
+ = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges)
+ where
+ (rhs_usage, rhs') = occAnalRhs env bndr rhs
+ rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
+ out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
-- (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 --
-- which has n**2 cost, and this meant that edges_from alone
-- consumed 10% of total runtime!
- ---- 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)
+-----------------------------
+occAnalRec :: 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)
+ | not (bndr `usedIn` body_usage)
+ = (body_usage, binds)
+
+ | otherwise -- It's mentioned in the body
+ = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs]
+ NonRec tagged_bndr rhs : binds)
+ where
+ (body_usage', tagged_bndr) = tagBinder body_usage bndr
+
+
+ -- The Rec case is the interesting one
+ -- See Note [Loop breaking]
+occAnalRec (CyclicSCC nodes) (body_usage, binds)
+ | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
+ = (body_usage, binds) -- Dead code
+
+ | otherwise -- At this point we always build a single Rec
+ = (final_usage, Rec pairs : binds)
+
+ where
+ bndrs = [b | (ND b _ _ _, _, _) <- nodes]
+ bndr_set = mkVarSet bndrs
+ ----------------------------
+ -- Tag the binders with their occurrence info
+ total_usage = foldl add_usage body_usage nodes
+ add_usage body_usage (ND bndr _ rhs_usage _, _, _)
+ = body_usage +++ addRuleUsage rhs_usage bndr
+ (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
+
+ tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
+ -- (a) Tag the binders in the details with occ info
+ -- (b) Mark the binder with "weak loop-breaker" OccInfo
+ -- 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))
+ where
+ bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
+ | otherwise = bndr1
+ bndr1 = setBinderOcc usage bndr
+ all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
+ emptyVarSet bndrs
+
+ ----------------------------
+ -- Now reconstruct the cycle
+ pairs | no_rules = reOrderCycle tagged_nodes
+ | otherwise = concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR loop_breaker_edges)
+
+ -- See Note [Choosing loop breakers] for looop_breaker_edges
+ loop_breaker_edges = map mk_node tagged_nodes
+ mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
+ where
+ new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
------------------------------------
rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
\begin{code}
-type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
- -- which is gotten from the Id.
-type Details = (Id, -- Binder
- CoreExpr, -- RHS
- IdSet) -- RHS free vars (*not* include rules)
+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
+ UsageDetails -- Full usage from RHS (*not* including rules)
+ IdSet -- Other binders from this Rec group mentioned on RHS
+ -- (derivable from UsageDetails but cached here)
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 (AcyclicSCC ((bndr, rhs, _), _, _)) = [(bndr, rhs)]
-reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
+reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)]
+reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
reOrderCycle []
reOrderCycle [bind] -- Common case of simple self-recursion
= [(makeLoopBreaker False bndr, rhs)]
where
- ((bndr, rhs, _), _, _) = bind
+ (ND bndr rhs _ _, _, _) = bind
reOrderCycle (bind : binds)
= -- Choose a loop breaker, mark it no-inline,
-- do SCC analysis on the rest, and recursively sort them out
- concatMap reOrderRec (stronglyConnCompR unchosen) ++
+ concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR unchosen) ++
[(makeLoopBreaker False bndr, rhs)]
where
(chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
- (bndr, rhs, _) = chosen_bind
+ ND bndr rhs _ _ = chosen_bind
-- This loop looks for the bind with the lowest score
-- to pick as the loop breaker. The rest accumulate in
sc = score bind
score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
- score ((bndr, rhs, _), _, _)
+ score (ND bndr rhs _ _, _, _)
| workerExists (idWorkerInfo bndr) = 10
-- Note [Worker inline loop]
- | exprIsTrivial rhs = 4 -- Practically certain to be inlined
+ | exprIsTrivial rhs = 5 -- Practically certain to be inlined
-- Used to have also: && not (isExportedId bndr)
-- But I found this sometimes cost an extra iteration when we have
-- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
-- where df is the exported dictionary. Then df makes a really
-- bad choice for loop breaker
- | is_con_app rhs = 2 -- Data types help with cases
+ | is_con_app rhs = 3 -- Data types help with cases
-- Note [conapp]
- | inlineCandidate bndr rhs = 1 -- Likely to be inlined
+-- If an Id is marked "never inline" then it makes a great loop breaker
+-- The only reason for not checking that here is that it is rare
+-- and I've never seen a situation where it makes a difference,
+-- so it probably isn't worth the time to test on every binder
+-- | isNeverActive (idInlinePragma bndr) = -10
+
+ | inlineCandidate bndr rhs = 2 -- Likely to be inlined
-- Note [Inline candidates]
+ | not (neverUnfold (idUnfolding bndr)) = 1
+ -- the Id has some kind of unfolding
+
| otherwise = 0
inlineCandidate :: Id -> CoreExpr -> Bool
is_one_shot b = isId b && isOneShotBndr b
occAnal env (Case scrut bndr ty alts)
- = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
- case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
+ = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
+ case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') ->
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
alts_usage' = addCaseBndrUsage alts_usage
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
+ -- Note [Case binder usage]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~
-- The case binder gets a usage of either "many" or "dead", never "one".
-- Reason: we like to inline single occurrences, to eliminate a binding,
-- but inlining a case binder *doesn't* eliminate a binding.
-- into
-- case x of w { (p,q) -> f (p,q) }
addCaseBndrUsage usage = case lookupVarEnv usage bndr of
- Nothing -> usage
- Just occ -> extendVarEnv usage bndr (markMany occ)
+ Nothing -> usage
+ Just _ -> extendVarEnv usage bndr NoOccInfo
alt_env = setVanillaCtxt env
-- Consider x = case v of { True -> (p,q); ... }
-- Then it's fine to inline p and q
+ bndr_swap = case scrut of
+ Var v -> Just (v, Var bndr)
+ Cast (Var v) co -> Just (v, Cast (Var bndr) (mkSymCoercion co))
+ _other -> Nothing
+
+ occ_anal_alt = occAnalAlt alt_env bndr bndr_swap
+
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
- -- No need for rhsCtxt
+ | not (null other_alts) || not (isDefaultAlt alt1)
+ = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs
+ -- in an interesting context; the case has
+ -- at least one non-default alternative
+ occ_anal_scrut scrut _alts
+ = occAnal vanillaCtxt scrut -- No need for rhsCtxt
occAnal env (Let bind body)
= case occAnal env body of { (body_usage, body') ->
\end{code}
-Case alternatives
-~~~~~~~~~~~~~~~~~
-If the case binder occurs at all, the other binders effectively do too.
-For example
- case e of x { (a,b) -> rhs }
-is rather like
- let x = (a,b) in rhs
-If e turns out to be (e1,e2) we indeed get something like
- let a = e1; b = e2; x = (a,b) in rhs
-
-Note [Aug 06]: I don't think this is necessary any more, and it helpe
- to know when binders are unused. See esp the call to
- isDeadBinder in Simplify.mkDupableAlt
+Note [Binder swap]
+~~~~~~~~~~~~~~~~~~
+We do these two transformations right here:
+
+ (1) case x of b { pi -> ri }
+ ==>
+ case x of b { pi -> let x=b in ri }
+
+ (2) case (x |> co) of b { pi -> ri }
+ ==>
+ case (x |> co) of b { pi -> let x = b |> sym co in ri }
+
+ Why (2)? See Note [Ccase of cast]
+
+In both cases, in a particular alternative (pi -> ri), we only
+add the binding if
+ (a) x occurs free in (pi -> ri)
+ (ie it occurs in ri, but is not bound in pi)
+ (b) the pi does not bind b (or the free vars of co)
+ (c) x is not a
+We need (a) and (b) for the inserted binding to be correct.
+
+Notice that (a) rapidly becomes false, so no bindings are injected.
+
+Notice the deliberate shadowing of 'x'. But we must call localiseId
+on 'x' first, in case it's a GlobalId, or has an External Name.
+See, for example, SimplEnv Note [Global Ids in the substitution].
+
+For the alternatives where we inject the binding, we can transfer
+all x's OccInfo to b. And that is the point.
+
+The reason for doing these transformations here is because it allows
+us to adjust the OccInfo for 'x' and 'b' as we go.
+
+ * Suppose the only occurrences of 'x' are the scrutinee and in the
+ ri; then this transformation makes it occur just once, and hence
+ get inlined right away.
+
+ * If we do this in the Simplifier, we don't know whether 'x' is used
+ in ri, so we are forced to pessimistically zap b's OccInfo even
+ though it is typically dead (ie neither it nor x appear in the
+ ri). There's nothing actually wrong with zapping it, except that
+ it's kind of nice to know which variables are dead. My nose
+ tells me to keep this information as robustly as possible.
+
+The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
+{x=b}; it's Nothing if the binder-swap doesn't happen.
+
+Note [Case of cast]
+~~~~~~~~~~~~~~~~~~~
+Consider case (x `cast` co) of b { I# ->
+ ... (case (x `cast` co) of {...}) ...
+We'd like to eliminate the inner case. That is the motivation for
+equation (2) in Note [Binder swap]. When we get to the inner case, we
+inline x, cancel the casts, and away we go.
+
+Note [Binders in case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ case x of y { (a,b) -> f y }
+We treat 'a', 'b' as dead, because they don't physically occur in the
+case alternative. (Indeed, a variable is dead iff it doesn't occur in
+its scope in the output of OccAnal.) This invariant is It really
+helpe to know when binders are unused. See esp the call to
+isDeadBinder in Simplify.mkDupableAlt
+
+In this example, though, the Simplifier will bring 'a' and 'b' back to
+life, beause it binds 'y' to (a,b) (imagine got inlined and
+scrutinised y).
\begin{code}
occAnalAlt :: OccEnv
-> CoreBndr
+ -> Maybe (Id, CoreExpr) -- Note [Binder swap]
-> CoreAlt
-> (UsageDetails, Alt IdWithOccInfo)
-occAnalAlt env _case_bndr (con, bndrs, rhs)
+occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs)
= case occAnal env rhs of { (rhs_usage, rhs') ->
let
- (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
- final_bndrs = tagged_bndrs -- See Note [Aug06] above
-{-
- final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
- | otherwise = tagged_bndrs
- -- Leave the binders untagged if the case
- -- binder occurs at all; see note above
--}
+ (alt_usg, tagged_bndrs) = tagBinders rhs_usage bndrs
+ bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
in
- (final_usage, (con, final_bndrs, rhs')) }
+ case mb_scrut_var of
+ Just (scrut_var, scrut_rhs) -- See Note [Binder swap]
+ | scrut_var `localUsedIn` alt_usg -- (a) Fast path, usually false
+ , not (any shadowing bndrs) -- (b)
+ -> (addOneOcc usg_wo_scrut case_bndr NoOccInfo,
+ -- See Note [Case binder usage] for the NoOccInfo
+ (con, bndrs', Let (NonRec scrut_var' scrut_rhs) rhs'))
+ where
+ (usg_wo_scrut, scrut_var') = tagBinder alt_usg (localiseId scrut_var)
+ -- Note the localiseId; we're making a new binding
+ -- for it, and it might have an External Name, or
+ -- even be a GlobalId
+ shadowing bndr = bndr `elemVarSet` rhs_fvs
+ rhs_fvs = exprFreeVars scrut_rhs
+
+ _other -> (alt_usg, (con, bndrs', rhs')) }
\end{code}
\begin{code}
type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
+ -- INVARIANT: never IAmDead
+ -- (Deadness is signalled by not being in the map at all)
(+++), combineAltsUsageDetails
:: UsageDetails -> UsageDetails -> UsageDetails
emptyDetails :: UsageDetails
emptyDetails = (emptyVarEnv :: UsageDetails)
-usedIn :: Id -> UsageDetails -> Bool
-v `usedIn` details = isExportedId v || v `elemVarEnv` details
+localUsedIn, usedIn :: Id -> UsageDetails -> Bool
+v `localUsedIn` details = v `elemVarEnv` details
+v `usedIn` details = isExportedId v || v `localUsedIn` details
type IdWithOccInfo = Id
markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
-markMany IAmDead = IAmDead
-markMany _ = NoOccInfo
+markMany _ = NoOccInfo
markInsideSCC occ = markMany occ
addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
-addOccInfo IAmDead info2 = info2
-addOccInfo info1 IAmDead = info1
-addOccInfo _ _ = NoOccInfo
+addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
+ NoOccInfo -- Both branches are at least One
+ -- (Argument is never IAmDead)
-- (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 _ 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 _ _ = NoOccInfo
+orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
+ NoOccInfo
\end{code}
projects / ghc-hetmet.git / blobdiff