import CoreUtils ( exprIsTrivial, isDefaultAlt )
import Coercion ( mkSymCoercion )
import Id
+import Name ( localiseName )
+import IdInfo
import BasicTypes
import VarSet
----------------------------
-- Now reconstruct the cycle
- pairs | no_rules = reOrderCycle tagged_nodes
- | otherwise = concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR loop_breaker_edges)
+ pairs | no_rules = reOrderCycle 0 tagged_nodes []
+ | otherwise = foldr (reOrderRec 0) [] $
+ stronglyConnCompFromEdgedVerticesR loop_breaker_edges
-- See Note [Choosing loop breakers] for looop_breaker_edges
loop_breaker_edges = map mk_node tagged_nodes
where
new_fvs = extendFvs env emptyVarSet fvs
+idRuleRhsVars :: Id -> VarSet
+-- Just the variables free on the *rhs* of a rule
+-- See Note [Choosing loop breakers]
+idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)
+
extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
-- (extendFVs env fvs s) returns (fvs `union` env(s))
extendFvs env fvs id_set
IdSet -- Other binders from this Rec group mentioned on RHS
-- (derivable from UsageDetails but cached here)
-reOrderRec :: SCC (Node Details)
- -> [(Id,CoreExpr)]
+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 _ _, _, _)) = [(bndr, rhs)]
-reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
+reOrderRec _ (AcyclicSCC (ND bndr rhs _ _, _, _)) pairs = (bndr, rhs) : pairs
+reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs
-reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
-reOrderCycle []
+reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
+reOrderCycle _ [] _
= panic "reOrderCycle"
-reOrderCycle [bind] -- Common case of simple self-recursion
- = [(makeLoopBreaker False bndr, rhs)]
+reOrderCycle _ [bind] pairs -- Common case of simple self-recursion
+ = (makeLoopBreaker False bndr, rhs) : pairs
where
(ND bndr rhs _ _, _, _) = bind
-reOrderCycle (bind : binds)
+reOrderCycle depth (bind : binds) pairs
= -- Choose a loop breaker, mark it no-inline,
-- do SCC analysis on the rest, and recursively sort them out
- concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR unchosen) ++
- [(makeLoopBreaker False bndr, rhs)]
-
+-- pprTrace "reOrderCycle" (ppr [b | (ND b _ _ _, _, _) <- bind:binds]) $
+ foldr (reOrderRec new_depth)
+ ([ (makeLoopBreaker False bndr, rhs)
+ | (ND bndr rhs _ _, _, _) <- chosen_binds] ++ pairs)
+ (stronglyConnCompFromEdgedVerticesR unchosen)
where
- (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
- ND bndr rhs _ _ = chosen_bind
+ (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] 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
-- This loop looks for the bind with the lowest score
-- to pick as the loop breaker. The rest accumulate in
- choose_loop_breaker (details,_,_) _loop_sc acc []
- = (details, acc) -- Done
+ choose_loop_breaker loop_binds _loop_sc acc []
+ = (loop_binds, acc) -- Done
- choose_loop_breaker loop_bind loop_sc acc (bind : binds)
+ -- 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_binds loop_sc acc (bind : binds)
| sc < loop_sc -- Lower score so pick this new one
- = choose_loop_breaker bind sc (loop_bind : acc) binds
+ = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds
- | otherwise -- No lower so don't pick it
- = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
+ | approximate_loop_breaker && sc == loop_sc
+ = choose_loop_breaker (bind : loop_binds) loop_sc acc binds
+
+ | otherwise -- Higher score so don't pick it
+ = choose_loop_breaker loop_binds loop_sc (bind : acc) binds
where
sc = score bind
score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
score (ND bndr rhs _ _, _, _)
- | isInlineRule (idUnfolding bndr) = 10
- -- Note [INLINE pragmas]
+ | workerExists (idWorkerInfo bndr) = 10
+ -- Note [Worker inline loop]
| exprIsTrivial rhs = 5 -- Practically certain to be inlined
-- Used to have also: && not (isExportedId bndr)
-- so it probably isn't worth the time to test on every binder
-- | isNeverActive (idInlinePragma bndr) = -10
- | isOneOcc (idOccInfo bndr) = 1 -- Likely to be inlined
+ | inlineCandidate bndr rhs = 2 -- Likely to be inlined
+ -- Note [Inline candidates]
- | canUnfold (idUnfolding bndr) = 1
+ | not (neverUnfold (idUnfolding bndr)) = 1
-- the Id has some kind of unfolding
| otherwise = 0
- -- Checking for a constructor application
+ inlineCandidate :: Id -> CoreExpr -> Bool
+ inlineCandidate _ (Note InlineMe _) = True
+ inlineCandidate id _ = isOneOcc (idOccInfo id)
+
+ -- Note [conapp]
+ --
+ -- It's really really important to inline dictionaries. Real
+ -- example (the Enum Ordering instance from GHC.Base):
+ --
+ -- rec f = \ x -> case d of (p,q,r) -> p x
+ -- g = \ x -> case d of (p,q,r) -> q x
+ -- d = (v, f, g)
+ --
+ -- Here, f and g occur just once; but we can't inline them into d.
+ -- On the other hand we *could* simplify those case expressions if
+ -- we didn't stupidly choose d as the loop breaker.
+ -- But we won't because constructor args are marked "Many".
+ -- Inlining dictionaries is really essential to unravelling
+ -- the loops in static numeric dictionaries, see GHC.Float.
+
-- Cheap and cheerful; the simplifer moves casts out of the way
-- The lambda case is important to spot x = /\a. C (f a)
-- which comes up when C is a dictionary constructor and
makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
\end{code}
+Note [Complexity of loop breaking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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
+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
+ Plan B: pick *all* binders with the lowest score, make them
+ 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.
+
+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 }
+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
+linear in the number of instance declarations.
+
Note [INLINE pragmas]
~~~~~~~~~~~~~~~~~~~~~
Never choose a function with an INLINE pramga as the loop breaker!
\end{code}
\begin{code}
+occAnal env (Note InlineMe body)
+ = case occAnal env body of { (usage, body') ->
+ (mapVarEnv markMany usage, Note InlineMe body')
+ }
+
occAnal env (Note note@(SCC _) body)
= case occAnal env body of { (usage, body') ->
(mapVarEnv markInsideSCC usage, Note note body')
where
fun_uniq = idUnique fun
fun_uds = mkOneOcc env fun (valArgCount args > 0)
- is_pap = isDataConWorkId fun || valArgCount args < idArity fun
+ is_pap = isConLikeId fun || valArgCount args < idArity fun
-- Hack for build, fold, runST
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
{x=b}; it's Nothing if the binder-swap doesn't happen.
+There is a danger though. Consider
+ let v = x +# y
+ 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
+same simplifier pass that reduced (f v) to v.
+
+I think this is just too bad. CSE will recover some of it.
+
Note [Binder swap on GlobalId scrutinees]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the scrutinee is a GlobalId we must take care in two ways
has an External Name. See, for example, SimplEnv Note [Global Ids in
the substitution].
+Historical note [no-case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We *used* to suppress the binder-swap in case expressoins 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:
+ f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
+ If we eliminate the inner case, we trap it inside the I# v -> arm,
+ which might prevent some full laziness happening. I've seen this
+ in action in spectral/cichelli/Prog.hs:
+ [(m,n) | m <- [1..max], n <- [1..max]]
+ Hence the check for NoCaseOfCase."
+However, now the full-laziness pass itself reverses the binder-swap, so this
+check is no longer necessary.
+
+Historical note [Suppressing the case binder-swap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This old note describes a problem that is also fixed by doing the
+binder-swap in OccAnal:
+
+ There is another situation when it might make sense to suppress the
+ case-expression binde-swap. If we have
+
+ case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
+ ...other cases .... }
+
+ We'll perform the binder-swap for the outer case, giving
+
+ case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
+ ...other cases .... }
+
+ But there is no point in doing it for the inner case, because w1 can't
+ be inlined anyway. Furthermore, doing the case-swapping involves
+ zapping w2's occurrence info (see paragraphs that follow), and that
+ forces us to bind w2 when doing case merging. So we get
+
+ case x of w1 { A -> let w2 = w1 in e1
+ B -> let w2 = w1 in e2
+ ...other cases .... }
+
+ This is plain silly in the common case where w2 is dead.
+
+ Even so, I can't see a good way to implement this idea. I tried
+ not doing the binder-swap if the scrutinee was already evaluated
+ but that failed big-time:
+
+ data T = MkT !Int
+
+ case v of w { MkT x ->
+ case x of x1 { I# y1 ->
+ case x of x2 { I# y2 -> ...
+
+ Notice that because MkT is strict, x is marked "evaluated". But to
+ eliminate the last case, we must either make sure that x (as well as
+ x1) has unfolding MkT y1. THe straightforward thing to do is to do
+ the binder-swap. So this whole note is a no-op.
+
+It's fixed by doing the binder-swap in OccAnal because we can do the
+binder-swap unconditionally and still get occurrence analysis
+information right.
+
Note [Case of cast]
~~~~~~~~~~~~~~~~~~~
Consider case (x `cast` co) of b { I# ->
, 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'))
+ (con, bndrs', Let (NonRec scrut_var2 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
+ scrut_var1 = mkLocalId (localiseName (idName scrut_var)) (idType scrut_var)
+ -- 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!
+
+ (usg_wo_scrut, scrut_var2) = tagBinder alt_usg scrut_var1
shadowing bndr = bndr `elemVarSet` rhs_fvs
rhs_fvs = exprFreeVars scrut_rhs
projects / ghc-hetmet.git / blobdiff