summaryrefslogtreecommitdiff
path: root/compiler/simplCore/OccurAnal.lhs
diff options
context:
space:
mode:
authorIan Lynagh <ian@well-typed.com>2012-10-19 20:56:30 +0100
committerIan Lynagh <ian@well-typed.com>2012-10-19 20:56:30 +0100
commitbca2e47d3a8c474c1ef5c56df17a79855dee1057 (patch)
tree22a23da765bda8ab0e990e8715c94eea4c1c5919 /compiler/simplCore/OccurAnal.lhs
parent6c547271343be0620503f07508b109b170562af6 (diff)
downloadhaskell-bca2e47d3a8c474c1ef5c56df17a79855dee1057.tar.gz
Whitespace only in simplCore/OccurAnal.lhs
Diffstat (limited to 'compiler/simplCore/OccurAnal.lhs')
-rw-r--r--compiler/simplCore/OccurAnal.lhs505
1 files changed, 249 insertions, 256 deletions
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 5a204f46b5..bf696e906d 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -12,13 +12,6 @@ The occurrence analyser re-typechecks a core expression, returning a new
core expression with (hopefully) improved usage information.
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
{-# LANGUAGE BangPatterns #-}
module OccurAnal (
occurAnalysePgm, occurAnalyseExpr
@@ -61,21 +54,21 @@ import Data.List
Here's the externally-callable interface:
\begin{code}
-occurAnalysePgm :: Module -- Used only in debug output
- -> (Activation -> Bool)
+occurAnalysePgm :: Module -- Used only in debug output
+ -> (Activation -> Bool)
-> [CoreRule] -> [CoreVect]
-> CoreProgram -> CoreProgram
occurAnalysePgm this_mod active_rule imp_rules vects binds
| isEmptyVarEnv final_usage
= binds'
- | otherwise -- See Note [Glomming]
+ | otherwise -- See Note [Glomming]
= WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)
2 (ppr final_usage ) )
- [Rec (flattenBinds binds')]
+ [Rec (flattenBinds binds')]
where
(final_usage, binds') = go (initOccEnv active_rule) binds
- initial_uds = addIdOccs emptyDetails
+ initial_uds = addIdOccs emptyDetails
(rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects)
-- The RULES and VECTORISE declarations keep things alive!
@@ -98,7 +91,7 @@ occurAnalysePgm this_mod active_rule imp_rules vects binds
occurAnalyseExpr :: CoreExpr -> CoreExpr
-- Do occurrence analysis, and discard occurence info returned
-occurAnalyseExpr expr
+occurAnalyseExpr expr
= snd (occAnal (initOccEnv all_active_rules) expr)
where
-- To be conservative, we say that all inlines and rules are active
@@ -116,8 +109,8 @@ Bindings
~~~~~~~~
\begin{code}
-occAnalBind :: OccEnv -- The incoming OccEnv
- -> OccEnv -- Same, but trimmed by (binderOf bind)
+occAnalBind :: OccEnv -- The incoming OccEnv
+ -> OccEnv -- Same, but trimmed by (binderOf bind)
-> IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs
-> CoreBind
-> UsageDetails -- Usage details of scope
@@ -125,7 +118,7 @@ occAnalBind :: OccEnv -- The incoming OccEnv
[CoreBind])
occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage
- | isTyVar 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
@@ -144,10 +137,10 @@ occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage
occAnalBind _ env imp_rules_edges (Rec pairs) body_usage
= foldr occAnalRec (body_usage, []) sccs
- -- For a recursive group, we
- -- * occ-analyse all the RHSs
- -- * compute strongly-connected components
- -- * feed those components to occAnalRec
+ -- For a recursive group, we
+ -- * occ-analyse all the RHSs
+ -- * compute strongly-connected components
+ -- * feed those components to occAnalRec
where
bndr_set = mkVarSet (map fst pairs)
@@ -235,7 +228,7 @@ always in scope.
* 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.
+ occurrence analyser. We must track free vars in *both* lhs and rhs.
Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.
Why both? Consider
x = y
@@ -261,10 +254,10 @@ Note [Choosing loop breakers]
Loop breaking is surprisingly subtle. First read the section 4 of
"Secrets of the GHC inliner". This describes our basic plan.
We avoid infinite inlinings by choosing loop breakers, and
-ensuring that a loop breaker cuts each loop.
+ensuring that a loop breaker cuts each loop.
Fundamentally, we do SCC analysis on a graph. For each recursive
-group we choose a loop breaker, delete all edges to that node,
+group we choose a loop breaker, delete all edges to that node,
re-analyse the SCC, and iterate.
But what is the graph? NOT the same graph as was used for Note
@@ -293,14 +286,14 @@ 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
+g's loop-breaker edges. More concretely there is an edge from f -> g
iff
- (a) g is mentioned in f's RHS `xor` f's INLINE rhs
- (see Note [Inline rules])
- (b) or h is mentioned in f's RHS, and
+ (a) g is mentioned in f's RHS `xor` f's INLINE rhs
+ (see Note [Inline rules])
+ (b) or h is mentioned in f's RHS, and
g appears in the RHS of an active RULE of h
or a transitive sequence of active rules starting with h
-
+
Why "active rules"? See Note [Finding rule RHS free vars]
Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
@@ -317,20 +310,20 @@ That's why we compute
* 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
+ 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 #-}
+ {-# 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 occ_rule_act field
+ *active* rules. That's the reason for the occ_rule_act field
of the OccEnv.
-
+
* Note [Weak loop breakers]
~~~~~~~~~~~~~~~~~~~~~~~~~
There is a last nasty wrinkle. Suppose we have
@@ -351,7 +344,7 @@ That's why we compute
not choosen as a loop breaker.) Why not? Because then we
drop the binding for 'g', which leaves it out of scope in the
RULE!
-
+
Here's a somewhat different example of the same thing
Rec { g = h
; h = ...f...
@@ -359,9 +352,9 @@ That's why we compute
RULE f [] = g }
Here the RULE is "below" g, but we *still* can't postInlineUnconditionally
g, because the RULE for f is active throughout. So the RHS of h
- might rewrite to h = ...g...
+ might rewrite to h = ...g...
So g must remain in scope in the output program!
-
+
We "solve" this by:
Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True)
@@ -389,14 +382,14 @@ Note [Rules for imported functions]
Consider this
f = /\a. B.g a
RULE B.g Int = 1 + f Int
-Note that
- * The RULE is for an imported function.
+Note that
+ * The RULE is for an imported function.
* f is non-recursive
Now we
can get
- f Int --> B.g Int Inlining f
+ f Int --> B.g Int Inlining f
--> 1 + f Int Firing RULE
-and so the simplifier goes into an infinite loop. This
+and so the simplifier goes into an infinite loop. This
would not happen if the RULE was for a local function,
because we keep track of dependencies through rules. But
that is pretty much impossible to do for imported Ids. Suppose
@@ -413,13 +406,13 @@ occur a lot in the libraries.
We regard this potential infinite loop as a *programmer* error.
It's up the programmer not to write silly rules like
RULE f x = f x
-and the example above is just a more complicated version.
+and the example above is just a more complicated version.
Note [Preventing loops due to imported functions rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider:
import GHC.Base (foldr)
-
+
{-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}
filter p xs = build (\c n -> foldr (filterFB c p) n xs)
filterFB c p = ...
@@ -438,20 +431,20 @@ A more elaborate example (that I actually saw in practice when I went to
mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:
{-# LANGUAGE Rank2Types #-}
module GHCList where
-
+
import Prelude hiding (filter)
import GHC.Base (build)
-
+
{-# INLINABLE filter #-}
filter :: (a -> Bool) -> [a] -> [a]
filter p [] = []
filter p (x:xs) = if p x then x : filter p xs else filter p xs
-
+
{-# NOINLINE [0] filterFB #-}
filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b
filterFB c p x r | p x = x `c` r
| otherwise = r
-
+
{-# RULES
"filter" [~1] forall p xs. filter p xs = build (\c n -> foldr
(filterFB c p) n xs)
@@ -503,23 +496,23 @@ responsible for the "programmer error" in Note [Rules for imported
functions]. In paricular, consider specialising a recursive function
defined in another module. If we specialise a recursive function B.g,
we get
- g_spec = .....(B.g Int).....
- RULE B.g Int = g_spec
+ g_spec = .....(B.g Int).....
+ RULE B.g Int = g_spec
Here, g_spec doesn't look recursive, but when the rule fires, it
becomes so. And if B.g was mutually recursive, the loop might
not be as obvious as it is here.
-To avoid this,
- * When specialising a function that is a loop breaker,
+To avoid this,
+ * When specialising a function that is a loop breaker,
give a NOINLINE pragma to the specialised function
Note [Glomming]
~~~~~~~~~~~~~~~
RULES for imported Ids can make something at the top refer to something at the bottom:
- f = \x -> B.g (q x)
- h = \y -> 3
-
- RULE: B.g (q x) = h x
+ f = \x -> B.g (q x)
+ h = \y -> 3
+
+ RULE: B.g (q x) = h x
Applying this rule makes f refer to h, although f doesn't appear to
depend on h. (And, as in Note [Rules for imported functions], the
@@ -533,7 +526,7 @@ function (B.g in the example above).
Solution:
- When simplifying, bring all top level identifiers into
- scope at the start, ignoring the Rec/NonRec structure, so
+ scope at the start, ignoring the Rec/NonRec structure, so
that when 'h' pops up in f's rhs, we find it in the in-scope set
(as the simplifier generally expects). This happens in simplTopBinds.
@@ -542,7 +535,7 @@ Solution:
firing the rule: f = \x -> h x
h = \y -> 3
then just glom all the bindings into a single Rec, so that
- the *next* iteration of the occurrence analyser will sort
+ the *next* iteration of the occurrence analyser will sort
them all out. This part happens in occurAnalysePgm.
------------------------------------------------------------
@@ -567,15 +560,15 @@ There is a danger that we'll be sub-optimal if we see this
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
+ foo :: Int -> Int
+ {-# INLINE [1] foo #-}
+ foo x = x+1
- bar :: Int -> Int
- {-# INLINE [1] bar #-}
- bar x = foo x + 1
+ bar :: Int -> Int
+ {-# INLINE [1] bar #-}
+ bar x = foo x + 1
- {-# RULES "foo" [~1] forall x. foo x = bar x #-}
+ {-# 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
@@ -625,15 +618,15 @@ This showed up when compiling Control.Concurrent.Chan.getChanContents.
\begin{code}
-type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
- -- which is gotten from the Id.
+type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
+ -- which is gotten from the Id.
data Details
= ND { nd_bndr :: Id -- Binder
, nd_rhs :: CoreExpr -- RHS, already occ-analysed
, nd_uds :: UsageDetails -- Usage from RHS, and RULES, and InlineRule unfolding
- -- ignoring phase (ie assuming all are active)
- -- See Note [Forming Rec groups]
+ -- ignoring phase (ie assuming all are active)
+ -- See Note [Forming Rec groups]
, nd_inl :: IdSet -- Free variables of
-- the InlineRule (if present and active)
@@ -642,21 +635,21 @@ data Details
-- This is the IdSet that may be used if the Id is inlined
, nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds
- -- but are *not* in nd_inl. These are the ones whose
- -- dependencies might not be respected by loop_breaker_edges
- -- See Note [Weak loop breakers]
-
+ -- but are *not* in nd_inl. These are the ones whose
+ -- dependencies might not be respected by loop_breaker_edges
+ -- See Note [Weak loop breakers]
+
, nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES
}
instance Outputable Details where
- ppr nd = ptext (sLit "ND") <> braces
+ ppr nd = ptext (sLit "ND") <> braces
(sep [ ptext (sLit "bndr =") <+> ppr (nd_bndr nd)
, ptext (sLit "uds =") <+> ppr (nd_uds nd)
, ptext (sLit "inl =") <+> ppr (nd_inl nd)
, ptext (sLit "weak =") <+> ppr (nd_weak nd)
, ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd)
- ])
+ ])
makeNode :: OccEnv -> IdEnv IdSet -> VarSet -> (Var, CoreExpr) -> Node Details
makeNode env imp_rules_edges bndr_set (bndr, rhs)
@@ -665,7 +658,7 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs)
details = ND { nd_bndr = bndr
, nd_rhs = rhs'
, nd_uds = rhs_usage3
- , nd_weak = node_fvs `minusVarSet` inl_fvs
+ , nd_weak = node_fvs `minusVarSet` inl_fvs
, nd_inl = inl_fvs
, nd_active_rule_fvs = active_rule_fvs }
@@ -688,7 +681,7 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs)
[ (ru_act rule, fvs)
| rule <- rules
, let fvs = exprFreeVars (ru_rhs rule)
- `delVarSetList` ru_bndrs rule
+ `delVarSetList` ru_bndrs rule
, not (isEmptyVarSet fvs) ]
all_rule_fvs = foldr (unionVarSet . snd) rule_lhs_fvs rules_w_fvs
rule_lhs_fvs = foldr (unionVarSet . (\ru -> exprsFreeVars (ru_args ru)
@@ -702,37 +695,37 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs)
-- Find the "nd_inl" free vars; for the loop-breaker phase
inl_fvs = case mb_unf_fvs of
- Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS
- Just unf_fvs -> unf_fvs
+ Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS
+ Just unf_fvs -> unf_fvs
-- We could check for an *active* INLINE (returning
- -- emptyVarSet for an inactive one), but is_active
- -- isn't the right thing (it tells about
- -- RULE activation), so we'd need more plumbing
+ -- emptyVarSet for an inactive one), but is_active
+ -- isn't the right thing (it tells about
+ -- RULE activation), so we'd need more plumbing
-----------------------------
occAnalRec :: SCC (Node Details)
-> (UsageDetails, [CoreBind])
- -> (UsageDetails, [CoreBind])
+ -> (UsageDetails, [CoreBind])
- -- The NonRec case is just like a Let (NonRec ...) above
+ -- The NonRec case is just like a Let (NonRec ...) above
occAnalRec (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_uds}, _, _))
(body_uds, binds)
- | not (bndr `usedIn` body_uds)
+ | not (bndr `usedIn` body_uds)
= (body_uds, binds)
- | otherwise -- It's mentioned in the body
- = (body_uds' +++ rhs_uds,
+ | otherwise -- It's mentioned in the body
+ = (body_uds' +++ rhs_uds,
NonRec tagged_bndr rhs : binds)
where
(body_uds', tagged_bndr) = tagBinder body_uds bndr
- -- The Rec case is the interesting one
- -- See Note [Loop breaking]
+ -- The Rec case is the interesting one
+ -- See Note [Loop breaking]
occAnalRec (CyclicSCC nodes) (body_uds, binds)
- | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds
- = (body_uds, binds) -- Dead code
+ | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds
+ = (body_uds, binds) -- Dead code
- | otherwise -- At this point we always build a single Rec
+ | otherwise -- At this point we always build a single Rec
= -- pprTrace "occAnalRec" (vcat
-- [ text "tagged nodes" <+> ppr tagged_nodes
-- , text "lb edges" <+> ppr loop_breaker_edges])
@@ -742,8 +735,8 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds)
bndrs = [b | (ND { nd_bndr = b }, _, _) <- nodes]
bndr_set = mkVarSet bndrs
- ----------------------------
- -- Tag the binders with their occurrence info
+ ----------------------------
+ -- Tag the binders with their occurrence info
tagged_nodes = map tag_node nodes
total_uds = foldl add_uds body_uds nodes
final_uds = total_uds `minusVarEnv` bndr_set
@@ -758,21 +751,21 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds)
pairs :: [(Id,CoreExpr)]
pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs tagged_nodes []
| otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_edges []
- -- If weak_fvs is empty, the loop_breaker_edges will include all
- -- the edges in tagged_nodes, so there isn't any point in doing
- -- a fresh SCC computation that will yield a single CyclicSCC result.
+ -- If weak_fvs is empty, the loop_breaker_edges will include all
+ -- the edges in tagged_nodes, so there isn't any point in doing
+ -- a fresh SCC computation that will yield a single CyclicSCC result.
weak_fvs :: VarSet
weak_fvs = foldr (unionVarSet . nd_weak . fstOf3) emptyVarSet nodes
- -- See Note [Choosing loop breakers] for loop_breaker_edges
+ -- See Note [Choosing loop breakers] for loop_breaker_edges
loop_breaker_edges = map mk_node tagged_nodes
- mk_node (details@(ND { nd_inl = inl_fvs }), k, _)
+ mk_node (details@(ND { nd_inl = inl_fvs }), k, _)
= (details, k, keysUFM (extendFvs_ rule_fv_env inl_fvs))
------------------------------------
- rule_fv_env :: IdEnv IdSet
- -- Maps a variable f to the variables from this group
+ rule_fv_env :: IdEnv IdSet
+ -- Maps a variable f to the variables from this group
-- 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)
@@ -802,12 +795,12 @@ recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
type Binding = (Id,CoreExpr)
mk_loop_breaker :: Node Details -> Binding
-mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
+mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
= (setIdOccInfo bndr strongLoopBreaker, rhs)
mk_non_loop_breaker :: VarSet -> Node Details -> Binding
-- See Note [Weak loop breakers]
-mk_non_loop_breaker used_in_rules (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
+mk_non_loop_breaker used_in_rules (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
| bndr `elemVarSet` used_in_rules = (setIdOccInfo bndr weakLoopBreaker, rhs)
| otherwise = (bndr, rhs)
@@ -815,14 +808,14 @@ udFreeVars :: VarSet -> UsageDetails -> VarSet
-- Find the subset of bndrs that are mentioned in uds
udFreeVars bndrs uds = intersectUFM_C (\b _ -> b) bndrs uds
-loopBreakNodes :: Int
- -> VarSet -- All binders
- -> VarSet -- Binders whose dependencies may be "missing"
- -- See Note [Weak loop breakers]
+loopBreakNodes :: Int
+ -> VarSet -- All binders
+ -> VarSet -- Binders whose dependencies may be "missing"
+ -- See Note [Weak loop breakers]
-> [Node Details]
- -> [Binding] -- Append these to the end
+ -> [Binding] -- Append these to the end
-> [Binding]
--- Return the bindings sorted into a plausible order, and marked with loop breakers.
+-- Return the bindings sorted into a plausible order, and marked with loop breakers.
loopBreakNodes depth bndr_set weak_fvs nodes binds
= go (stronglyConnCompFromEdgedVerticesR nodes) binds
where
@@ -840,7 +833,7 @@ reOrderNodes :: Int -> VarSet -> VarSet -> [Node Details] -> [Binding] -> [Bindi
-- do SCC analysis on the rest, and recursively sort them out
reOrderNodes _ _ _ [] _ = panic "reOrderNodes"
reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
- = -- pprTrace "reOrderNodes" (text "unchosen" <+> ppr unchosen $$
+ = -- pprTrace "reOrderNodes" (text "unchosen" <+> ppr unchosen $$
-- text "chosen" <+> ppr chosen_nodes) $
loopBreakNodes new_depth bndr_set weak_fvs unchosen $
(map mk_loop_breaker chosen_nodes ++ binds)
@@ -849,30 +842,30 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
approximate_loop_breaker = depth >= 2
new_depth | approximate_loop_breaker = 0
- | otherwise = depth+1
- -- After two iterations (d=0, d=1) give up
- -- and approximate, returning to d=0
-
- choose_loop_breaker :: Int -- Best score so far
- -> [Node Details] -- Nodes with this score
- -> [Node Details] -- Nodes with higher scores
- -> [Node Details] -- Unprocessed nodes
+ | otherwise = depth+1
+ -- After two iterations (d=0, d=1) give up
+ -- and approximate, returning to d=0
+
+ choose_loop_breaker :: Int -- Best score so far
+ -> [Node Details] -- Nodes with this score
+ -> [Node Details] -- Nodes with higher scores
+ -> [Node Details] -- Unprocessed nodes
-> ([Node Details], [Node Details])
-- This loop looks for the bind with the lowest score
-- to pick as the loop breaker. The rest accumulate in
choose_loop_breaker _ loop_nodes acc []
= (loop_nodes, acc) -- Done
- -- If approximate_loop_breaker is True, we pick *all*
- -- nodes with lowest score, else just one
- -- See Note [Complexity of loop breaking]
+ -- If approximate_loop_breaker is True, we pick *all*
+ -- nodes with lowest score, else just one
+ -- See Note [Complexity of loop breaking]
choose_loop_breaker loop_sc loop_nodes acc (node : nodes)
| sc < loop_sc -- Lower score so pick this new one
= choose_loop_breaker sc [node] (loop_nodes ++ acc) nodes
- | approximate_loop_breaker && sc == loop_sc
- = choose_loop_breaker loop_sc (node : loop_nodes) acc nodes
-
+ | approximate_loop_breaker && sc == loop_sc
+ = choose_loop_breaker loop_sc (node : loop_nodes) acc nodes
+
| otherwise -- Higher score so don't pick it
= choose_loop_breaker loop_sc loop_nodes (node : acc) nodes
where
@@ -880,22 +873,22 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)
- | not (isId bndr) = 100 -- A type or cercion variable is never a loop breaker
+ | 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]
+ -- Note [DFuns should not be loop breakers]
| 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
- -- so that dictionary/method recursion unravels
- -- Note that this case hits all InlineRule things, so we
- -- never look at 'rhs' for InlineRule stuff. That's right, because
- -- 'rhs' is irrelevant for inlining things with an InlineRule
-
+ = case inl_source of
+ InlineWrapper {} -> 10 -- Note [INLINE pragmas]
+ _other -> 3 -- Data structures are more important than this
+ -- so that dictionary/method recursion unravels
+ -- Note that this case hits all InlineRule things, so we
+ -- never look at 'rhs' for InlineRule stuff. That's right, because
+ -- 'rhs' is irrelevant for inlining things with an InlineRule
+
| is_con_app rhs = 5 -- Data types help with cases: Note [Constructor applications]
-
+
| exprIsTrivial rhs = 10 -- Practically certain to be inlined
-- Used to have also: && not (isExportedId bndr)
-- But I found this sometimes cost an extra iteration when we have
@@ -903,22 +896,22 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
-- where df is the exported dictionary. Then df makes a really
-- bad choice for loop breaker
-
+
-- 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
+-- | isNeverActive (idInlinePragma bndr) = -10
| isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined
| canUnfold (realIdUnfolding bndr) = 1
-- The Id has some kind of unfolding
- -- Ignore loop-breaker-ness here because that is what we are setting!
+ -- Ignore loop-breaker-ness here because that is what we are setting!
| otherwise = 0
- -- Checking for a constructor application
+ -- Checking for a constructor application
-- Cheap and cheerful; the simplifer moves casts out of the way
-- The lambda case is important to spot x = /\a. C (f a)
-- which comes up when C is a dictionary constructor and
@@ -936,7 +929,7 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
Note [Complexity of loop breaking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The loop-breaking algorithm knocks out one binder at a time, and
+The loop-breaking algorithm knocks out one binder at a time, and
performs a new SCC analysis on the remaining binders. That can
behave very badly in tightly-coupled groups of bindings; in the
worst case it can be (N**2)*log N, because it does a full SCC
@@ -944,9 +937,9 @@ on N, then N-1, then N-2 and so on.
To avoid this, we switch plans after 2 (or whatever) attempts:
Plan A: pick one binder with the lowest score, make it
- a loop breaker, and try again
+ a loop breaker, and try again
Plan B: pick *all* binders with the lowest score, make them
- all loop breakers, and try again
+ all loop breakers, and try again
Since there are only a small finite number of scores, this will
terminate in a constant number of iterations, rather than O(N)
iterations.
@@ -954,16 +947,16 @@ iterations.
You might thing that it's very unlikely, but RULES make it much
more likely. Here's a real example from Trac #1969:
Rec { $dm = \d.\x. op d
- {-# RULES forall d. $dm Int d = $s$dm1
- forall d. $dm Bool d = $s$dm2 #-}
-
- dInt = MkD .... opInt ...
- dInt = MkD .... opBool ...
- opInt = $dm dInt
- opBool = $dm dBool
-
- $s$dm1 = \x. op dInt
- $s$dm2 = \x. op dBool }
+ {-# RULES forall d. $dm Int d = $s$dm1
+ forall d. $dm Bool d = $s$dm2 #-}
+
+ dInt = MkD .... opInt ...
+ dInt = MkD .... opBool ...
+ opInt = $dm dInt
+ opBool = $dm dBool
+
+ $s$dm1 = \x. op dInt
+ $s$dm2 = \x. op dBool }
The RULES stuff means that we can't choose $dm as a loop breaker
(Note [Choosing loop breakers]), so we must choose at least (say)
opInt *and* opBool, and so on. The number of loop breakders is
@@ -971,7 +964,7 @@ linear in the number of instance declarations.
Note [INLINE pragmas]
~~~~~~~~~~~~~~~~~~~~~
-Avoid choosing a function with an INLINE pramga as the loop breaker!
+Avoid choosing a function with an INLINE pramga as the loop breaker!
If such a function is mutually-recursive with a non-INLINE thing,
then the latter should be the loop-breaker.
@@ -993,11 +986,11 @@ breaker then compiling Game.hs goes into an infinite loop. This
happened when we gave is_con_app a lower score than inline candidates:
Tree.repTree
- = __inline_me (/\a. \w w1 w2 ->
+ = __inline_me (/\a. \w w1 w2 ->
case Tree.$wrepTree @ a w w1 w2 of
{ (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
Tree.$wrepTree
- = /\a w w1 w2 ->
+ = /\a w w1 w2 ->
(# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
Here we do *not* want to choose 'repTree' as the loop breaker.
@@ -1007,9 +1000,9 @@ Note [DFuns should not be loop breakers]
It's particularly bad to make a DFun into a loop breaker. See
Note [How instance declarations are translated] in TcInstDcls
-We give DFuns a higher score than ordinary CONLIKE things because
+We give DFuns a higher score than ordinary CONLIKE things because
if there's a choice we want the DFun to be the non-looop breker. Eg
-
+
rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)
$fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)
@@ -1099,11 +1092,11 @@ addIdOccs usage id_set = foldVarSet add usage id_set
where
add v u | isId v = addOneOcc u v NoOccInfo
| otherwise = u
- -- Give a non-committal binder info (i.e NoOccInfo) because
- -- a) Many copies of the specialised thing can appear
- -- b) We don't want to substitute a BIG expression inside a RULE
- -- even if that's the only occurrence of the thing
- -- (Same goes for INLINE.)
+ -- Give a non-committal binder info (i.e NoOccInfo) because
+ -- a) Many copies of the specialised thing can appear
+ -- b) We don't want to substitute a BIG expression inside a RULE
+ -- even if that's the only occurrence of the thing
+ -- (Same goes for INLINE.)
\end{code}
Note [Cascading inlines]
@@ -1154,8 +1147,8 @@ occAnal :: OccEnv
-> (UsageDetails, -- Gives info only about the "interesting" Ids
CoreExpr)
-occAnal _ expr@(Type _) = (emptyDetails, expr)
-occAnal _ expr@(Lit _) = (emptyDetails, expr)
+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.
@@ -1164,9 +1157,9 @@ occAnal env expr@(Var v) = (mkOneOcc env v False, expr)
-- rules in them, so the *specialised* versions looked as if they
-- weren't used at all.
-occAnal _ (Coercion co)
+occAnal _ (Coercion co)
= (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
- -- See Note [Gather occurrences of coercion veriables]
+ -- See Note [Gather occurrences of coercion veriables]
\end{code}
Note [Gather occurrences of coercion veriables]
@@ -1227,7 +1220,7 @@ occAnal env expr@(Lam _ _)
= case occAnal env_body body of { (body_usage, body') ->
let
(final_usage, tagged_binders) = tagLamBinders body_usage binders'
- -- Use binders' to put one-shot info on the lambdas
+ -- Use binders' to put one-shot info on the lambdas
-- URGH! Sept 99: we don't seem to be able to use binders' here, because
-- we get linear-typed things in the resulting program that we can't handle yet.
@@ -1242,7 +1235,7 @@ occAnal env expr@(Lam _ _)
mkLams tagged_binders body') }
where
env_body = vanillaCtxt (trimOccEnv env binders)
- -- Body is (no longer) an RhsContext
+ -- Body is (no longer) an RhsContext
(binders, body) = collectBinders expr
binders' = oneShotGroup env binders
linear = all is_one_shot binders'
@@ -1258,8 +1251,8 @@ occAnal env (Case scrut bndr ty alts)
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
- -- Note [Case binder usage]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~
+ -- 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.
@@ -1277,11 +1270,11 @@ occAnal env (Case scrut bndr ty alts)
occ_anal_scrut (Var v) (alt1 : other_alts)
| 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 env) scrut -- No need for rhsCtxt
+ = (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 env) scrut -- No need for rhsCtxt
occAnal env (Let bind body)
= case occAnal env_body body of { (body_usage, body') ->
@@ -1321,23 +1314,23 @@ occAnalApp env (Var fun, args)
= case args_stuff of { (args_uds, args') ->
let
final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
- -- We mark the free vars of the argument of a constructor or PAP
- -- as "many", if it is the RHS of a let(rec).
- -- This means that nothing gets inlined into a constructor argument
- -- position, which is what we want. Typically those constructor
- -- arguments are just variables, or trivial expressions.
- --
- -- This is the *whole point* of the isRhsEnv predicate
- -- See Note [Arguments of let-bound constructors]
+ -- We mark the free vars of the argument of a constructor or PAP
+ -- as "many", if it is the RHS of a let(rec).
+ -- This means that nothing gets inlined into a constructor argument
+ -- position, which is what we want. Typically those constructor
+ -- 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
fun_uniq = idUnique fun
fun_uds = mkOneOcc env fun (valArgCount args > 0)
is_exp = isExpandableApp fun (valArgCount args)
- -- See Note [CONLIKE pragma] in BasicTypes
- -- The definition of is_exp should match that in
- -- Simplify.prepareRhs
+ -- See Note [CONLIKE pragma] in BasicTypes
+ -- The definition of is_exp should match that in
+ -- Simplify.prepareRhs
-- Hack for build, fold, runST
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
@@ -1418,13 +1411,13 @@ occAnalAlt :: OccEnv
-> CoreAlt
-> (UsageDetails, Alt IdWithOccInfo)
occAnalAlt env case_bndr (con, bndrs, rhs)
- = let
+ = let
env' = trimOccEnv env bndrs
- in
+ in
case occAnal env' rhs of { (rhs_usage1, rhs1) ->
let
- proxies = getProxies env' case_bndr
- (rhs_usage2, rhs2) = foldrBag wrapProxy (rhs_usage1, rhs1) proxies
+ proxies = getProxies env' case_bndr
+ (rhs_usage2, rhs2) = foldrBag wrapProxy (rhs_usage1, rhs1) proxies
(alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs
bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
in
@@ -1432,28 +1425,28 @@ occAnalAlt env case_bndr (con, bndrs, rhs)
wrapProxy :: ProxyBind -> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
wrapProxy (bndr, rhs_var, co) (body_usg, body)
- | not (bndr `usedIn` body_usg)
+ | not (bndr `usedIn` body_usg)
= (body_usg, body)
| otherwise
= (body_usg' +++ rhs_usg, Let (NonRec tagged_bndr rhs) body)
where
(body_usg', tagged_bndr) = tagBinder body_usg bndr
- rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
+ rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
rhs = mkCast (Var (zapIdOccInfo rhs_var)) co -- See Note [Zap case binders in proxy bindings]
\end{code}
%************************************************************************
%* *
- OccEnv
+ OccEnv
%* *
%************************************************************************
\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_act :: Activation -> Bool -- Which rules are active
-- See Note [Finding rule RHS free vars]
}
@@ -1488,10 +1481,10 @@ type CtxtTy = [Bool]
-- the CtxtTy inside applies
initOccEnv :: (Activation -> Bool) -> OccEnv
-initOccEnv active_rule
+initOccEnv active_rule
= OccEnv { occ_encl = OccVanilla
- , occ_ctxt = []
- , occ_proxy = PE emptyVarEnv emptyVarSet
+ , occ_ctxt = []
+ , occ_proxy = PE emptyVarEnv emptyVarSet
, occ_rule_act = active_rule }
vanillaCtxt :: OccEnv -> OccEnv
@@ -1552,15 +1545,15 @@ extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet
extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag
extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
--- (extendFVs env s) returns
+-- (extendFVs env s) returns
-- (s `union` env(s), env(s) `subset` s)
extendFvs env s
- | isNullUFM env
+ | isNullUFM env
= (s, True)
| otherwise
= (s `unionVarSet` extras, extras `subVarSet` s)
where
- extras :: VarSet -- env(s)
+ extras :: VarSet -- env(s)
extras = foldUFM unionVarSet emptyVarSet $
intersectUFM_C (\x _ -> x) env s
\end{code}
@@ -1568,16 +1561,16 @@ extendFvs env s
%************************************************************************
%* *
- ProxyEnv
+ ProxyEnv
%* *
%************************************************************************
\begin{code}
-data ProxyEnv -- See Note [ProxyEnv]
- = PE (IdEnv -- Domain = scrutinee variables
+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
+ [(Id,Coercion)])) -- The case binders that it maps to
+ VarSet -- Free variables of both range and domain
\end{code}
Note [ProxyEnv]
@@ -1591,12 +1584,12 @@ Typically we add such a binding when encountering the case expression
case (sc |> coi) of cb { ... }
Things to note:
- * The domain of the ProxyEnv is the variable (or casted variable)
+ * The domain of the ProxyEnv is the variable (or casted variable)
scrutinees of enclosing cases. This is additionally used
to ensure we gather occurrence info even for GlobalId scrutinees;
see Note [Binder swap for GlobalId scrutinee]
- * The ProxyEnv is just an optimisation; you can throw away any
+ * The ProxyEnv is just an optimisation; you can throw away any
element without losing correctness. And we do so when pushing
it inside a binding (see trimProxyEnv).
@@ -1613,7 +1606,7 @@ 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',
+we can find all the in-scope variables derivable from 'cb',
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.. }
@@ -1621,8 +1614,8 @@ ones *mentioned* in ri) thus:
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.
+The function getProxies finds these bindings; then we
+add just the necessary ones, using wrapProxy.
Note [Binder swap]
~~~~~~~~~~~~~~~~~~
@@ -1638,18 +1631,18 @@ We do these two transformations right here:
Why (2)? See Note [Case of cast]
-In both cases, in a particular alternative (pi -> ri), we only
+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)
+ (ie it occurs in ri, but is not bound in pi)
(b) the pi does not bind b (or the free vars of co)
We need (a) and (b) for the inserted binding to be correct.
For the alternatives where we inject the binding, we can transfer
all x's OccInfo to b. And that is the point.
-Notice that
- * The deliberate shadowing of 'x'.
+Notice that
+ * The deliberate shadowing of 'x'.
* That (a) rapidly becomes false, so no bindings are injected.
The reason for doing these transformations here is because it allows
@@ -1674,7 +1667,7 @@ There is a danger though. Consider
in case (f v) of w -> ...v...v...
And suppose that (f v) expands to just v. Then we'd like to
use 'w' instead of 'v' in the alternative. But it may be too
-late; we may have substituted the (cheap) x+#y for v in the
+late; we may have substituted the (cheap) x+#y for v in the
same simplifier pass that reduced (f v) to v.
I think this is just too bad. CSE will recover some of it.
@@ -1728,12 +1721,12 @@ 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
+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
+We *used* to suppress the binder-swap in case expressions when
-fno-case-of-case is on. Old remarks:
"This happens in the first simplifier pass,
and enhances full laziness. Here's the bad case:
@@ -1794,34 +1787,34 @@ information right.
\begin{code}
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
--- y = x |> co
+-- (extendPE x co y) typically arises from
+-- case (x |> co) of y { ... }
+-- It extends the proxy env with the binding
+-- y = x |> co
extendProxyEnv pe scrut co case_bndr
- | scrut == case_bndr = PE env1 fvs1 -- If case_bndr shadows scrut,
- | otherwise = PE env2 fvs2 -- don't extend
+ | scrut == case_bndr = PE env1 fvs1 -- If case_bndr shadows scrut,
+ | otherwise = PE env2 fvs2 -- don't extend
where
PE env1 fvs1 = trimProxyEnv pe [case_bndr]
env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
- single cb_co = (scrut1, [cb_co])
+ single cb_co = (scrut1, [cb_co])
add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
fvs2 = fvs1 `unionVarSet` tyCoVarsOfCo co
- `extendVarSet` case_bndr
- `extendVarSet` scrut1
+ `extendVarSet` case_bndr
+ `extendVarSet` scrut1
scrut1 = mkLocalId (localiseName (idName scrut)) (idType scrut)
- -- 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 INLINE or NOINLINE pragmas!
+ -- 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 INLINE or NOINLINE pragmas!
-----------
type ProxyBind = (Id, Id, Coercion)
-- (scrut variable, case-binder variable, coercion)
getProxies :: OccEnv -> Id -> Bag ProxyBind
--- Return a bunch of bindings [...(xi,ei)...]
+-- Return a bunch of bindings [...(xi,ei)...]
-- such that let { ...; xi=ei; ... } binds the xi using y alone
-- See Note [getProxies is subtle]
getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
@@ -1835,39 +1828,39 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
add2 x (y,co) env = extendVarEnv env y (x,co)
go_fwd :: Id -> Bag ProxyBind
- -- Return bindings derivable from case_bndr
- go_fwd case_bndr = -- pprTrace "go_fwd" (vcat [ppr case_bndr, text "fwd_pe =" <+> ppr fwd_pe,
- -- text "pe =" <+> ppr pe]) $
+ -- Return bindings derivable from case_bndr
+ go_fwd case_bndr = -- pprTrace "go_fwd" (vcat [ppr case_bndr, text "fwd_pe =" <+> ppr fwd_pe,
+ -- text "pe =" <+> ppr pe]) $
go_fwd' case_bndr
go_fwd' case_bndr
| Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
= unitBag (scrut, case_bndr, mkSymCo co)
- `unionBags` go_fwd scrut
+ `unionBags` go_fwd scrut
`unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
, cb /= case_bndr]
- | otherwise
+ | otherwise
= emptyBag
lookup_bwd :: Id -> [(Id, Coercion)]
- -- Return case_bndrs that are connected to scrut
+ -- Return case_bndrs that are connected to scrut
lookup_bwd scrut = case lookupVarEnv pe scrut of
- Nothing -> []
- Just (_, cb_cos) -> cb_cos
+ Nothing -> []
+ Just (_, cb_cos) -> cb_cos
go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind
go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind
- go_bwd1 scrut (case_bndr, co)
+ go_bwd1 scrut (case_bndr, co)
= -- pprTrace "go_bwd1" (ppr case_bndr) $
unitBag (case_bndr, scrut, co)
- `unionBags` go_bwd case_bndr (lookup_bwd case_bndr)
+ `unionBags` go_bwd case_bndr (lookup_bwd case_bndr)
-----------
mkAltEnv :: OccEnv -> CoreExpr -> Id -> OccEnv
-- Does two things: a) makes the occ_ctxt = OccVanilla
--- b) extends the ProxyEnv if possible
+-- b) extends the ProxyEnv if possible
mkAltEnv env scrut cb
= env { occ_encl = OccVanilla, occ_proxy = pe' }
where
@@ -1885,8 +1878,8 @@ trimOccEnv env bndrs = env { occ_proxy = trimProxyEnv (occ_proxy env) bndrs }
trimProxyEnv :: ProxyEnv -> [CoreBndr] -> ProxyEnv
-- We are about to push this ProxyEnv inside a binding for 'bndrs'
-- So dump any ProxyEnv bindings which mention any of the bndrs
-trimProxyEnv (PE pe fvs) bndrs
- | not (bndr_set `intersectsVarSet` fvs)
+trimProxyEnv (PE pe fvs) bndrs
+ | not (bndr_set `intersectsVarSet` fvs)
= PE pe fvs
| otherwise
= PE pe' (fvs `minusVarSet` bndr_set)
@@ -1894,8 +1887,8 @@ trimProxyEnv (PE pe fvs) bndrs
pe' = mapVarEnv trim pe
bndr_set = mkVarSet bndrs
trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
- | otherwise = (scrut, filterOut discard cb_cos)
- discard (cb,co) = bndr_set `intersectsVarSet`
+ | otherwise = (scrut, filterOut discard cb_cos)
+ discard (cb,co) = bndr_set `intersectsVarSet`
extendVarSet (tyCoVarsOfCo co) cb
\end{code}
@@ -1908,8 +1901,8 @@ trimProxyEnv (PE pe fvs) bndrs
\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)
+ -- INVARIANT: never IAmDead
+ -- (Deadness is signalled by not being in the map at all)
(+++), combineAltsUsageDetails
:: UsageDetails -> UsageDetails -> UsageDetails
@@ -1938,7 +1931,7 @@ tagLamBinders :: UsageDetails -- Of scope
-> (UsageDetails, -- Details with binders removed
[IdWithOccInfo]) -- Tagged binders
-- Used for lambda and case binders
--- It copes with the fact that lambda bindings can have InlineRule
+-- It copes with the fact that lambda bindings can have InlineRule
-- unfoldings, used for join points
tagLamBinders usage binders = usage' `seq` (usage', bndrs')
where
@@ -1986,11 +1979,11 @@ setBinderOcc usage bndr
\begin{code}
mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
mkOneOcc env id int_cxt
- | isLocalId id
+ | isLocalId id
= unitVarEnv id (OneOcc False True int_cxt)
| PE env _ <- occ_proxy env
- , id `elemVarEnv` env
+ , id `elemVarEnv` env
= unitVarEnv id NoOccInfo
| otherwise
@@ -2009,8 +2002,8 @@ markInsideLam occ = occ
addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
- NoOccInfo -- Both branches are at least One
- -- (Argument is never IAmDead)
+ 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
@@ -2021,5 +2014,5 @@ orOccInfo (OneOcc in_lam1 _ int_cxt1)
False -- False, because it occurs in both branches
(int_cxt1 && int_cxt2)
orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
- NoOccInfo
+ NoOccInfo
\end{code}