2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplUtils]{The simplifier utilities}
8 mkLam, prepareAlts, mkCase,
11 preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
14 -- The continuation type
15 SimplCont(..), DupFlag(..), LetRhsFlag(..),
16 contIsDupable, contResultType,
17 countValArgs, countArgs, pushContArgs,
18 mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
19 getContArgs, interestingCallContext, interestingArg, isStrictType
23 #include "HsVersions.h"
26 import DynFlags ( SimplifierSwitch(..), SimplifierMode(..),
28 import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
32 import CoreFVs ( exprFreeVars )
33 import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
34 etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
35 findDefault, exprOkForSpeculation, exprIsHNF
37 import Literal ( mkStringLit )
38 import CoreUnfold ( smallEnoughToInline )
39 import MkId ( eRROR_ID )
40 import Id ( idType, isDataConWorkId, idOccInfo, isDictId,
41 mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
42 idUnfolding, idNewStrictness, idInlinePragma,
44 import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
46 import Type ( Type, splitFunTys, dropForAlls, isStrictType,
47 splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
49 import Name ( mkSysTvName )
50 import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
51 import DataCon ( dataConRepArity, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
52 import Var ( tyVarKind, mkTyVar )
54 import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
55 Activation, isAlwaysActive, isActive )
56 import Util ( lengthExceeds )
61 %************************************************************************
63 \subsection{The continuation data type}
65 %************************************************************************
68 data SimplCont -- Strict contexts
69 = Stop OutType -- Type of the result
71 Bool -- True <=> This is the RHS of a thunk whose type suggests
72 -- that update-in-place would be possible
73 -- (This makes the inliner a little keener.)
75 | CoerceIt OutType -- The To-type, simplified
78 | InlinePlease -- This continuation makes a function very
79 SimplCont -- keen to inline itelf
82 InExpr SimplEnv -- The argument, as yet unsimplified,
83 SimplCont -- and its environment
86 InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
89 | ArgOf LetRhsFlag -- An arbitrary strict context: the argument
90 -- of a strict function, or a primitive-arg fn
92 -- No DupFlag because we never duplicate it
93 OutType -- arg_ty: type of the argument itself
94 OutType -- cont_ty: the type of the expression being sought by the context
95 -- f (error "foo") ==> coerce t (error "foo")
97 -- We need to know the type t, to which to coerce.
99 (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- What to do with the result
100 -- The result expression in the OutExprStuff has type cont_ty
102 data LetRhsFlag = AnArg -- It's just an argument not a let RHS
103 | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas)
105 instance Outputable LetRhsFlag where
106 ppr AnArg = ptext SLIT("arg")
107 ppr AnRhs = ptext SLIT("rhs")
109 instance Outputable SimplCont where
110 ppr (Stop _ is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs)
111 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
112 ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
113 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
114 (nest 4 (ppr alts)) $$ ppr cont
115 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
116 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
118 data DupFlag = OkToDup | NoDup
120 instance Outputable DupFlag where
121 ppr OkToDup = ptext SLIT("ok")
122 ppr NoDup = ptext SLIT("nodup")
126 mkBoringStop, mkRhsStop :: OutType -> SimplCont
127 mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
128 mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
130 contIsRhs :: SimplCont -> Bool
131 contIsRhs (Stop _ AnRhs _) = True
132 contIsRhs (ArgOf AnRhs _ _ _) = True
133 contIsRhs other = False
135 contIsRhsOrArg (Stop _ _ _) = True
136 contIsRhsOrArg (ArgOf _ _ _ _) = True
137 contIsRhsOrArg other = False
140 contIsDupable :: SimplCont -> Bool
141 contIsDupable (Stop _ _ _) = True
142 contIsDupable (ApplyTo OkToDup _ _ _) = True
143 contIsDupable (Select OkToDup _ _ _ _) = True
144 contIsDupable (CoerceIt _ cont) = contIsDupable cont
145 contIsDupable (InlinePlease cont) = contIsDupable cont
146 contIsDupable other = False
149 discardableCont :: SimplCont -> Bool
150 discardableCont (Stop _ _ _) = False
151 discardableCont (CoerceIt _ cont) = discardableCont cont
152 discardableCont (InlinePlease cont) = discardableCont cont
153 discardableCont other = True
155 discardCont :: SimplCont -- A continuation, expecting
156 -> SimplCont -- Replace the continuation with a suitable coerce
157 discardCont cont = case cont of
158 Stop to_ty is_rhs _ -> cont
159 other -> CoerceIt to_ty (mkBoringStop to_ty)
161 to_ty = contResultType cont
164 contResultType :: SimplCont -> OutType
165 contResultType (Stop to_ty _ _) = to_ty
166 contResultType (ArgOf _ _ to_ty _) = to_ty
167 contResultType (ApplyTo _ _ _ cont) = contResultType cont
168 contResultType (CoerceIt _ cont) = contResultType cont
169 contResultType (InlinePlease cont) = contResultType cont
170 contResultType (Select _ _ _ _ cont) = contResultType cont
173 countValArgs :: SimplCont -> Int
174 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
175 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
176 countValArgs other = 0
178 countArgs :: SimplCont -> Int
179 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
183 pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
184 -- Pushes args with the specified environment
185 pushContArgs env [] cont = cont
186 pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
191 getContArgs :: SwitchChecker
192 -> OutId -> SimplCont
193 -> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
194 SimplCont, -- Remaining continuation
195 Bool) -- Whether we came across an InlineCall
196 -- getContArgs id k = (args, k', inl)
197 -- args are the leading ApplyTo items in k
198 -- (i.e. outermost comes first)
199 -- augmented with demand info from the functionn
200 getContArgs chkr fun orig_cont
202 -- Ignore strictness info if the no-case-of-case
203 -- flag is on. Strictness changes evaluation order
204 -- and that can change full laziness
205 stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
206 | otherwise = computed_stricts
208 go [] stricts False orig_cont
210 ----------------------------
213 go acc ss inl (ApplyTo _ arg@(Type _) se cont)
214 = go ((arg,se,False) : acc) ss inl cont
215 -- NB: don't bother to instantiate the function type
218 go acc (s:ss) inl (ApplyTo _ arg se cont)
219 = go ((arg,se,s) : acc) ss inl cont
221 -- An Inline continuation
222 go acc ss inl (InlinePlease cont)
223 = go acc ss True cont
225 -- We're run out of arguments, or else we've run out of demands
226 -- The latter only happens if the result is guaranteed bottom
227 -- This is the case for
228 -- * case (error "hello") of { ... }
229 -- * (error "Hello") arg
230 -- * f (error "Hello") where f is strict
232 -- Then, especially in the first of these cases, we'd like to discard
233 -- the continuation, leaving just the bottoming expression. But the
234 -- type might not be right, so we may have to add a coerce.
236 | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
237 | otherwise = (reverse acc, cont, inl)
239 ----------------------------
240 vanilla_stricts, computed_stricts :: [Bool]
241 vanilla_stricts = repeat False
242 computed_stricts = zipWith (||) fun_stricts arg_stricts
244 ----------------------------
245 (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun))
246 arg_stricts = map isStrictType val_arg_tys ++ repeat False
247 -- These argument types are used as a cheap and cheerful way to find
248 -- unboxed arguments, which must be strict. But it's an InType
249 -- and so there might be a type variable where we expect a function
250 -- type (the substitution hasn't happened yet). And we don't bother
251 -- doing the type applications for a polymorphic function.
252 -- Hence the splitFunTys*IgnoringForAlls*
254 ----------------------------
255 -- If fun_stricts is finite, it means the function returns bottom
256 -- after that number of value args have been consumed
257 -- Otherwise it's infinite, extended with False
259 = case splitStrictSig (idNewStrictness fun) of
260 (demands, result_info)
261 | not (demands `lengthExceeds` countValArgs orig_cont)
262 -> -- Enough args, use the strictness given.
263 -- For bottoming functions we used to pretend that the arg
264 -- is lazy, so that we don't treat the arg as an
265 -- interesting context. This avoids substituting
266 -- top-level bindings for (say) strings into
267 -- calls to error. But now we are more careful about
268 -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
269 if isBotRes result_info then
270 map isStrictDmd demands -- Finite => result is bottom
272 map isStrictDmd demands ++ vanilla_stricts
274 other -> vanilla_stricts -- Not enough args, or no strictness
277 interestingArg :: OutExpr -> Bool
278 -- An argument is interesting if it has *some* structure
279 -- We are here trying to avoid unfolding a function that
280 -- is applied only to variables that have no unfolding
281 -- (i.e. they are probably lambda bound): f x y z
282 -- There is little point in inlining f here.
283 interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
284 -- Was: isValueUnfolding (idUnfolding v')
285 -- But that seems over-pessimistic
287 -- This accounts for an argument like
288 -- () or [], which is definitely interesting
289 interestingArg (Type _) = False
290 interestingArg (App fn (Type _)) = interestingArg fn
291 interestingArg (Note _ a) = interestingArg a
292 interestingArg other = True
293 -- Consider let x = 3 in f x
294 -- The substitution will contain (x -> ContEx 3), and we want to
295 -- to say that x is an interesting argument.
296 -- But consider also (\x. f x y) y
297 -- The substitution will contain (x -> ContEx y), and we want to say
298 -- that x is not interesting (assuming y has no unfolding)
301 Comment about interestingCallContext
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 We want to avoid inlining an expression where there can't possibly be
304 any gain, such as in an argument position. Hence, if the continuation
305 is interesting (eg. a case scrutinee, application etc.) then we
306 inline, otherwise we don't.
308 Previously some_benefit used to return True only if the variable was
309 applied to some value arguments. This didn't work:
311 let x = _coerce_ (T Int) Int (I# 3) in
312 case _coerce_ Int (T Int) x of
315 we want to inline x, but can't see that it's a constructor in a case
316 scrutinee position, and some_benefit is False.
320 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
322 .... case dMonadST _@_ x0 of (a,b,c) -> ....
324 we'd really like to inline dMonadST here, but we *don't* want to
325 inline if the case expression is just
327 case x of y { DEFAULT -> ... }
329 since we can just eliminate this case instead (x is in WHNF). Similar
330 applies when x is bound to a lambda expression. Hence
331 contIsInteresting looks for case expressions with just a single
335 interestingCallContext :: Bool -- False <=> no args at all
336 -> Bool -- False <=> no value args
338 -- The "lone-variable" case is important. I spent ages
339 -- messing about with unsatisfactory varaints, but this is nice.
340 -- The idea is that if a variable appear all alone
341 -- as an arg of lazy fn, or rhs Stop
342 -- as scrutinee of a case Select
343 -- as arg of a strict fn ArgOf
344 -- then we should not inline it (unless there is some other reason,
345 -- e.g. is is the sole occurrence). We achieve this by making
346 -- interestingCallContext return False for a lone variable.
348 -- Why? At least in the case-scrutinee situation, turning
349 -- let x = (a,b) in case x of y -> ...
351 -- let x = (a,b) in case (a,b) of y -> ...
353 -- let x = (a,b) in let y = (a,b) in ...
354 -- is bad if the binding for x will remain.
356 -- Another example: I discovered that strings
357 -- were getting inlined straight back into applications of 'error'
358 -- because the latter is strict.
360 -- f = \x -> ...(error s)...
362 -- Fundamentally such contexts should not ecourage inlining because
363 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
364 -- so there's no gain.
366 -- However, even a type application or coercion isn't a lone variable.
368 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
369 -- We had better inline that sucker! The case won't see through it.
371 -- For now, I'm treating treating a variable applied to types
372 -- in a *lazy* context "lone". The motivating example was
374 -- g = /\a. \y. h (f a)
375 -- There's no advantage in inlining f here, and perhaps
376 -- a significant disadvantage. Hence some_val_args in the Stop case
378 interestingCallContext some_args some_val_args cont
381 interesting (InlinePlease _) = True
382 interesting (Select _ _ _ _ _) = some_args
383 interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
384 -- Perhaps True is a bit over-keen, but I've
385 -- seen (coerce f) x, where f has an INLINE prag,
386 -- So we have to give some motivaiton for inlining it
387 interesting (ArgOf _ _ _ _) = some_val_args
388 interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
389 interesting (CoerceIt _ cont) = interesting cont
390 -- If this call is the arg of a strict function, the context
391 -- is a bit interesting. If we inline here, we may get useful
392 -- evaluation information to avoid repeated evals: e.g.
394 -- Here the contIsInteresting makes the '*' keener to inline,
395 -- which in turn exposes a constructor which makes the '+' inline.
396 -- Assuming that +,* aren't small enough to inline regardless.
398 -- It's also very important to inline in a strict context for things
401 -- Here, the context of (f x) is strict, and if f's unfolding is
402 -- a build it's *great* to inline it here. So we must ensure that
403 -- the context for (f x) is not totally uninteresting.
407 canUpdateInPlace :: Type -> Bool
408 -- Consider let x = <wurble> in ...
409 -- If <wurble> returns an explicit constructor, we might be able
410 -- to do update in place. So we treat even a thunk RHS context
411 -- as interesting if update in place is possible. We approximate
412 -- this by seeing if the type has a single constructor with a
413 -- small arity. But arity zero isn't good -- we share the single copy
414 -- for that case, so no point in sharing.
417 | not opt_UF_UpdateInPlace = False
419 = case splitTyConApp_maybe ty of
421 Just (tycon, _) -> case tyConDataCons_maybe tycon of
422 Just [dc] -> arity == 1 || arity == 2
424 arity = dataConRepArity dc
430 %************************************************************************
432 \subsection{Decisions about inlining}
434 %************************************************************************
436 Inlining is controlled partly by the SimplifierMode switch. This has two
439 SimplGently (a) Simplifying before specialiser/full laziness
440 (b) Simplifiying inside INLINE pragma
441 (c) Simplifying the LHS of a rule
442 (d) Simplifying a GHCi expression or Template
445 SimplPhase n Used at all other times
447 The key thing about SimplGently is that it does no call-site inlining.
448 Before full laziness we must be careful not to inline wrappers,
449 because doing so inhibits floating
450 e.g. ...(case f x of ...)...
451 ==> ...(case (case x of I# x# -> fw x#) of ...)...
452 ==> ...(case x of I# x# -> case fw x# of ...)...
453 and now the redex (f x) isn't floatable any more.
455 The no-inling thing is also important for Template Haskell. You might be
456 compiling in one-shot mode with -O2; but when TH compiles a splice before
457 running it, we don't want to use -O2. Indeed, we don't want to inline
458 anything, because the byte-code interpreter might get confused about
459 unboxed tuples and suchlike.
463 SimplGently is also used as the mode to simplify inside an InlineMe note.
466 inlineMode :: SimplifierMode
467 inlineMode = SimplGently
470 It really is important to switch off inlinings inside such
471 expressions. Consider the following example
477 in ...g...g...g...g...g...
479 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
480 and thence copied multiple times when g is inlined.
483 This function may be inlinined in other modules, so we
484 don't want to remove (by inlining) calls to functions that have
485 specialisations, or that may have transformation rules in an importing
488 E.g. {-# INLINE f #-}
491 and suppose that g is strict *and* has specialisations. If we inline
492 g's wrapper, we deny f the chance of getting the specialised version
493 of g when f is inlined at some call site (perhaps in some other
496 It's also important not to inline a worker back into a wrapper.
498 wraper = inline_me (\x -> ...worker... )
499 Normally, the inline_me prevents the worker getting inlined into
500 the wrapper (initially, the worker's only call site!). But,
501 if the wrapper is sure to be called, the strictness analyser will
502 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
503 continuation. That's why the keep_inline predicate returns True for
504 ArgOf continuations. It shouldn't do any harm not to dissolve the
505 inline-me note under these circumstances.
507 Note that the result is that we do very little simplification
510 all xs = foldr (&&) True xs
511 any p = all . map p {-# INLINE any #-}
513 Problem: any won't get deforested, and so if it's exported and the
514 importer doesn't use the inlining, (eg passes it as an arg) then we
515 won't get deforestation at all. We havn't solved this problem yet!
518 preInlineUnconditionally
519 ~~~~~~~~~~~~~~~~~~~~~~~~
520 @preInlineUnconditionally@ examines a bndr to see if it is used just
521 once in a completely safe way, so that it is safe to discard the
522 binding inline its RHS at the (unique) usage site, REGARDLESS of how
523 big the RHS might be. If this is the case we don't simplify the RHS
524 first, but just inline it un-simplified.
526 This is much better than first simplifying a perhaps-huge RHS and then
527 inlining and re-simplifying it. Indeed, it can be at least quadratically
536 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
537 This can happen with cascades of functions too:
544 THE MAIN INVARIANT is this:
546 ---- preInlineUnconditionally invariant -----
547 IF preInlineUnconditionally chooses to inline x = <rhs>
548 THEN doing the inlining should not change the occurrence
549 info for the free vars of <rhs>
550 ----------------------------------------------
552 For example, it's tempting to look at trivial binding like
554 and inline it unconditionally. But suppose x is used many times,
555 but this is the unique occurrence of y. Then inlining x would change
556 y's occurrence info, which breaks the invariant. It matters: y
557 might have a BIG rhs, which will now be dup'd at every occurrenc of x.
560 Evne RHSs labelled InlineMe aren't caught here, because there might be
561 no benefit from inlining at the call site.
563 [Sept 01] Don't unconditionally inline a top-level thing, because that
564 can simply make a static thing into something built dynamically. E.g.
568 [Remember that we treat \s as a one-shot lambda.] No point in
569 inlining x unless there is something interesting about the call site.
571 But watch out: if you aren't careful, some useful foldr/build fusion
572 can be lost (most notably in spectral/hartel/parstof) because the
573 foldr didn't see the build. Doing the dynamic allocation isn't a big
574 deal, in fact, but losing the fusion can be. But the right thing here
575 seems to be to do a callSiteInline based on the fact that there is
576 something interesting about the call site (it's strict). Hmm. That
579 Conclusion: inline top level things gaily until Phase 0 (the last
580 phase), at which point don't.
583 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
584 preInlineUnconditionally env top_lvl bndr rhs
586 | opt_SimplNoPreInlining = False
587 | otherwise = case idOccInfo bndr of
588 IAmDead -> True -- Happens in ((\x.1) v)
589 OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
593 active = case phase of
594 SimplGently -> isAlwaysActive prag
595 SimplPhase n -> isActive n prag
596 prag = idInlinePragma bndr
598 try_once in_lam int_cxt -- There's one textual occurrence
599 | not in_lam = isNotTopLevel top_lvl || early_phase
600 | otherwise = int_cxt && canInlineInLam rhs
602 -- Be very careful before inlining inside a lambda, becuase (a) we must not
603 -- invalidate occurrence information, and (b) we want to avoid pushing a
604 -- single allocation (here) into multiple allocations (inside lambda).
605 -- Inlining a *function* with a single *saturated* call would be ok, mind you.
606 -- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
608 -- is_cheap = exprIsCheap rhs
609 -- ok = is_cheap && int_cxt
611 -- int_cxt The context isn't totally boring
612 -- E.g. let f = \ab.BIG in \y. map f xs
613 -- Don't want to substitute for f, because then we allocate
614 -- its closure every time the \y is called
615 -- But: let f = \ab.BIG in \y. map (f y) xs
616 -- Now we do want to substitute for f, even though it's not
617 -- saturated, because we're going to allocate a closure for
618 -- (f y) every time round the loop anyhow.
620 -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
621 -- so substituting rhs inside a lambda doesn't change the occ info.
622 -- Sadly, not quite the same as exprIsHNF.
623 canInlineInLam (Lit l) = True
624 canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e
625 canInlineInLam (Note _ e) = canInlineInLam e
626 canInlineInLam _ = False
628 early_phase = case phase of
629 SimplPhase 0 -> False
631 -- If we don't have this early_phase test, consider
632 -- x = length [1,2,3]
633 -- The full laziness pass carefully floats all the cons cells to
634 -- top level, and preInlineUnconditionally floats them all back in.
635 -- Result is (a) static allocation replaced by dynamic allocation
636 -- (b) many simplifier iterations because this tickles
637 -- a related problem; only one inlining per pass
639 -- On the other hand, I have seen cases where top-level fusion is
640 -- lost if we don't inline top level thing (e.g. string constants)
641 -- Hence the test for phase zero (which is the phase for all the final
642 -- simplifications). Until phase zero we take no special notice of
643 -- top level things, but then we become more leery about inlining
648 postInlineUnconditionally
649 ~~~~~~~~~~~~~~~~~~~~~~~~~
650 @postInlineUnconditionally@ decides whether to unconditionally inline
651 a thing based on the form of its RHS; in particular if it has a
652 trivial RHS. If so, we can inline and discard the binding altogether.
654 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
655 only have *forward* references Hence, it's safe to discard the binding
657 NOTE: This isn't our last opportunity to inline. We're at the binding
658 site right now, and we'll get another opportunity when we get to the
661 Note that we do this unconditional inlining only for trival RHSs.
662 Don't inline even WHNFs inside lambdas; doing so may simply increase
663 allocation when the function is called. This isn't the last chance; see
666 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
667 Because we don't even want to inline them into the RHS of constructor
668 arguments. See NOTE above
670 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
671 it's best to inline it anyway. We often get a=E; b=a from desugaring,
672 with both a and b marked NOINLINE. But that seems incompatible with
673 our new view that inlining is like a RULE, so I'm sticking to the 'active'
677 postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -> OccInfo -> OutExpr -> Unfolding -> Bool
678 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
680 | isLoopBreaker occ_info = False
681 | isExportedId bndr = False
682 | exprIsTrivial rhs = True
685 OneOcc in_lam one_br int_cxt
686 -> (one_br || smallEnoughToInline unfolding) -- Small enough to dup
687 -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
689 -- NB: Do we want to inline arbitrarily big things becuase
690 -- one_br is True? that can lead to inline cascades. But
691 -- preInlineUnconditionlly has dealt with all the common cases
692 -- so perhaps it's worth the risk. Here's an example
693 -- let f = if b then Left (\x.BIG) else Right (\y.BIG)
695 -- We can't preInlineUnconditionally because that woud invalidate
696 -- the occ info for b. Yet f is used just once, and duplicating
697 -- the case work is fine (exprIsCheap).
699 && ((isNotTopLevel top_lvl && not in_lam) ||
700 -- But outside a lambda, we want to be reasonably aggressive
701 -- about inlining into multiple branches of case
702 -- e.g. let x = <non-value>
703 -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
704 -- Inlining can be a big win if C3 is the hot-spot, even if
705 -- the uses in C1, C2 are not 'interesting'
706 -- An example that gets worse if you add int_cxt here is 'clausify'
708 (isCheapUnfolding unfolding && int_cxt))
709 -- isCheap => acceptable work duplication; in_lam may be true
710 -- int_cxt to prevent us inlining inside a lambda without some
711 -- good reason. See the notes on int_cxt in preInlineUnconditionally
714 -- The point here is that for *non-values* that occur
715 -- outside a lambda, the call-site inliner won't have
716 -- a chance (becuase it doesn't know that the thing
717 -- only occurs once). The pre-inliner won't have gotten
718 -- it either, if the thing occurs in more than one branch
719 -- So the main target is things like
722 -- True -> case x of ...
723 -- False -> case x of ...
724 -- I'm not sure how important this is in practice
726 active = case getMode env of
727 SimplGently -> isAlwaysActive prag
728 SimplPhase n -> isActive n prag
729 prag = idInlinePragma bndr
731 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
732 activeInline env id occ
733 = case getMode env of
734 SimplGently -> isOneOcc occ && isAlwaysActive prag
735 -- No inlining at all when doing gentle stuff,
736 -- except for local things that occur once
737 -- The reason is that too little clean-up happens if you
738 -- don't inline use-once things. Also a bit of inlining is *good* for
739 -- full laziness; it can expose constant sub-expressions.
740 -- Example in spectral/mandel/Mandel.hs, where the mandelset
741 -- function gets a useful let-float if you inline windowToViewport
743 -- NB: we used to have a second exception, for data con wrappers.
744 -- On the grounds that we use gentle mode for rule LHSs, and
745 -- they match better when data con wrappers are inlined.
746 -- But that only really applies to the trivial wrappers (like (:)),
747 -- and they are now constructed as Compulsory unfoldings (in MkId)
748 -- so they'll happen anyway.
750 SimplPhase n -> isActive n prag
752 prag = idInlinePragma id
754 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
755 -- Nothing => No rules at all
757 | opt_RulesOff = Nothing
759 = case getMode env of
760 SimplGently -> Just isAlwaysActive
761 -- Used to be Nothing (no rules in gentle mode)
762 -- Main motivation for changing is that I wanted
763 -- lift String ===> ...
764 -- to work in Template Haskell when simplifying
765 -- splices, so we get simpler code for literal strings
766 SimplPhase n -> Just (isActive n)
770 %************************************************************************
772 \subsection{Rebuilding a lambda}
774 %************************************************************************
777 mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
781 a) eta reduction, if that gives a trivial expression
782 b) eta expansion [only if there are some value lambdas]
783 c) floating lets out through big lambdas
784 [only if all tyvar lambdas, and only if this lambda
788 mkLam env bndrs body cont
789 = getDOptsSmpl `thenSmpl` \dflags ->
790 mkLam' dflags env bndrs body cont
792 mkLam' dflags env bndrs body cont
793 | dopt Opt_DoEtaReduction dflags,
794 Just etad_lam <- tryEtaReduce bndrs body
795 = tick (EtaReduction (head bndrs)) `thenSmpl_`
796 returnSmpl (emptyFloats env, etad_lam)
798 | dopt Opt_DoLambdaEtaExpansion dflags,
799 any isRuntimeVar bndrs
800 = tryEtaExpansion body `thenSmpl` \ body' ->
801 returnSmpl (emptyFloats env, mkLams bndrs body')
803 {- Sept 01: I'm experimenting with getting the
804 full laziness pass to float out past big lambdsa
805 | all isTyVar bndrs, -- Only for big lambdas
806 contIsRhs cont -- Only try the rhs type-lambda floating
807 -- if this is indeed a right-hand side; otherwise
808 -- we end up floating the thing out, only for float-in
809 -- to float it right back in again!
810 = tryRhsTyLam env bndrs body `thenSmpl` \ (floats, body') ->
811 returnSmpl (floats, mkLams bndrs body')
815 = returnSmpl (emptyFloats env, mkLams bndrs body)
819 %************************************************************************
821 \subsection{Eta expansion and reduction}
823 %************************************************************************
825 We try for eta reduction here, but *only* if we get all the
826 way to an exprIsTrivial expression.
827 We don't want to remove extra lambdas unless we are going
828 to avoid allocating this thing altogether
831 tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr
832 tryEtaReduce bndrs body
833 -- We don't use CoreUtils.etaReduce, because we can be more
835 -- (a) we already have the binders
836 -- (b) we can do the triviality test before computing the free vars
837 = go (reverse bndrs) body
839 go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
840 go [] fun | ok_fun fun = Just fun -- Success!
841 go _ _ = Nothing -- Failure!
843 ok_fun fun = exprIsTrivial fun
844 && not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
845 && (exprIsHNF fun || all ok_lam bndrs)
846 ok_lam v = isTyVar v || isDictId v
847 -- The exprIsHNF is because eta reduction is not
848 -- valid in general: \x. bot /= bot
849 -- So we need to be sure that the "fun" is a value.
851 -- However, we always want to reduce (/\a -> f a) to f
852 -- This came up in a RULE: foldr (build (/\a -> g a))
853 -- did not match foldr (build (/\b -> ...something complex...))
854 -- The type checker can insert these eta-expanded versions,
855 -- with both type and dictionary lambdas; hence the slightly
858 ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
862 Try eta expansion for RHSs
865 f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
868 where (in both cases)
870 * The xi can include type variables
872 * The yi are all value variables
874 * N is a NORMAL FORM (i.e. no redexes anywhere)
875 wanting a suitable number of extra args.
877 We may have to sandwich some coerces between the lambdas
878 to make the types work. exprEtaExpandArity looks through coerces
879 when computing arity; and etaExpand adds the coerces as necessary when
880 actually computing the expansion.
883 tryEtaExpansion :: OutExpr -> SimplM OutExpr
884 -- There is at least one runtime binder in the binders
886 = getUniquesSmpl `thenSmpl` \ us ->
887 returnSmpl (etaExpand fun_arity us body (exprType body))
889 fun_arity = exprEtaExpandArity body
893 %************************************************************************
895 \subsection{Floating lets out of big lambdas}
897 %************************************************************************
899 tryRhsTyLam tries this transformation, when the big lambda appears as
900 the RHS of a let(rec) binding:
902 /\abc -> let(rec) x = e in b
904 let(rec) x' = /\abc -> let x = x' a b c in e
906 /\abc -> let x = x' a b c in b
908 This is good because it can turn things like:
910 let f = /\a -> letrec g = ... g ... in g
912 letrec g' = /\a -> ... g' a ...
916 which is better. In effect, it means that big lambdas don't impede
919 This optimisation is CRUCIAL in eliminating the junk introduced by
920 desugaring mutually recursive definitions. Don't eliminate it lightly!
922 So far as the implementation is concerned:
924 Invariant: go F e = /\tvs -> F e
928 = Let x' = /\tvs -> F e
932 G = F . Let x = x' tvs
934 go F (Letrec xi=ei in b)
935 = Letrec {xi' = /\tvs -> G ei}
939 G = F . Let {xi = xi' tvs}
941 [May 1999] If we do this transformation *regardless* then we can
942 end up with some pretty silly stuff. For example,
945 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
950 st = /\s -> ...[y1 s/x1, y2 s/x2]
953 Unless the "..." is a WHNF there is really no point in doing this.
954 Indeed it can make things worse. Suppose x1 is used strictly,
957 x1* = case f y of { (a,b) -> e }
959 If we abstract this wrt the tyvar we then can't do the case inline
960 as we would normally do.
964 {- Trying to do this in full laziness
966 tryRhsTyLam :: SimplEnv -> [OutTyVar] -> OutExpr -> SimplM FloatsWithExpr
967 -- Call ensures that all the binders are type variables
969 tryRhsTyLam env tyvars body -- Only does something if there's a let
970 | not (all isTyVar tyvars)
971 || not (worth_it body) -- inside a type lambda,
972 = returnSmpl (emptyFloats env, body) -- and a WHNF inside that
975 = go env (\x -> x) body
978 worth_it e@(Let _ _) = whnf_in_middle e
981 whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
982 whnf_in_middle (Let _ e) = whnf_in_middle e
983 whnf_in_middle e = exprIsCheap e
985 main_tyvar_set = mkVarSet tyvars
987 go env fn (Let bind@(NonRec var rhs) body)
989 = go env (fn . Let bind) body
991 go env fn (Let (NonRec var rhs) body)
992 = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
993 addAuxiliaryBind env (NonRec var' (mkLams tyvars_here (fn rhs))) $ \ env ->
994 go env (fn . Let (mk_silly_bind var rhs')) body
998 tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprSomeFreeVars isTyVar rhs)
999 -- Abstract only over the type variables free in the rhs
1000 -- wrt which the new binding is abstracted. But the naive
1001 -- approach of abstract wrt the tyvars free in the Id's type
1003 -- /\ a b -> let t :: (a,b) = (e1, e2)
1006 -- Here, b isn't free in x's type, but we must nevertheless
1007 -- abstract wrt b as well, because t's type mentions b.
1008 -- Since t is floated too, we'd end up with the bogus:
1009 -- poly_t = /\ a b -> (e1, e2)
1010 -- poly_x = /\ a -> fst (poly_t a *b*)
1011 -- So for now we adopt the even more naive approach of
1012 -- abstracting wrt *all* the tyvars. We'll see if that
1013 -- gives rise to problems. SLPJ June 98
1015 go env fn (Let (Rec prs) body)
1016 = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
1018 gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
1019 pairs = vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]
1021 addAuxiliaryBind env (Rec pairs) $ \ env ->
1024 (vars,rhss) = unzip prs
1025 tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprsSomeFreeVars isTyVar (map snd prs))
1026 -- See notes with tyvars_here above
1028 go env fn body = returnSmpl (emptyFloats env, fn body)
1030 mk_poly tyvars_here var
1031 = getUniqueSmpl `thenSmpl` \ uniq ->
1033 poly_name = setNameUnique (idName var) uniq -- Keep same name
1034 poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
1035 poly_id = mkLocalId poly_name poly_ty
1037 -- In the olden days, it was crucial to copy the occInfo of the original var,
1038 -- because we were looking at occurrence-analysed but as yet unsimplified code!
1039 -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking
1040 -- at already simplified code, so it doesn't matter
1042 -- It's even right to retain single-occurrence or dead-var info:
1043 -- Suppose we started with /\a -> let x = E in B
1044 -- where x occurs once in B. Then we transform to:
1045 -- let x' = /\a -> E in /\a -> let x* = x' a in B
1046 -- where x* has an INLINE prag on it. Now, once x* is inlined,
1047 -- the occurrences of x' will be just the occurrences originally
1050 returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
1052 mk_silly_bind var rhs = NonRec var (Note InlineMe rhs)
1053 -- Suppose we start with:
1055 -- x = /\ a -> let g = G in E
1057 -- Then we'll float to get
1059 -- x = let poly_g = /\ a -> G
1060 -- in /\ a -> let g = poly_g a in E
1062 -- But now the occurrence analyser will see just one occurrence
1063 -- of poly_g, not inside a lambda, so the simplifier will
1064 -- PreInlineUnconditionally poly_g back into g! Badk to square 1!
1065 -- (I used to think that the "don't inline lone occurrences" stuff
1066 -- would stop this happening, but since it's the *only* occurrence,
1067 -- PreInlineUnconditionally kicks in first!)
1069 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
1070 -- to appear many times. (NB: mkInlineMe eliminates
1071 -- such notes on trivial RHSs, so do it manually.)
1075 %************************************************************************
1077 \subsection{Case alternative filtering
1079 %************************************************************************
1081 prepareAlts does two things:
1083 1. Eliminate alternatives that cannot match, including the
1084 DEFAULT alternative.
1086 2. If the DEFAULT alternative can match only one possible constructor,
1087 then make that constructor explicit.
1089 case e of x { DEFAULT -> rhs }
1091 case e of x { (a,b) -> rhs }
1092 where the type is a single constructor type. This gives better code
1093 when rhs also scrutinises x or e.
1095 It's a good idea do do this stuff before simplifying the alternatives, to
1096 avoid simplifying alternatives we know can't happen, and to come up with
1097 the list of constructors that are handled, to put into the IdInfo of the
1098 case binder, for use when simplifying the alternatives.
1100 Eliminating the default alternative in (1) isn't so obvious, but it can
1103 data Colour = Red | Green | Blue
1112 DEFAULT -> [ case y of ... ]
1114 If we inline h into f, the default case of the inlined h can't happen.
1115 If we don't notice this, we may end up filtering out *all* the cases
1116 of the inner case y, which give us nowhere to go!
1120 prepareAlts :: OutExpr -- Scrutinee
1121 -> InId -- Case binder (passed only to use in statistics)
1122 -> [InAlt] -- Increasing order
1123 -> SimplM ([InAlt], -- Better alternatives, still incresaing order
1124 [AltCon]) -- These cases are handled
1126 prepareAlts scrut case_bndr alts
1128 (alts_wo_default, maybe_deflt) = findDefault alts
1130 impossible_cons = case scrut of
1131 Var v -> otherCons (idUnfolding v)
1134 -- Filter out alternatives that can't possibly match
1135 better_alts | null impossible_cons = alts_wo_default
1136 | otherwise = [alt | alt@(con,_,_) <- alts_wo_default,
1137 not (con `elem` impossible_cons)]
1139 -- "handled_cons" are handled either by the context,
1140 -- or by a branch in this case expression
1141 -- (Don't add DEFAULT to the handled_cons!!)
1142 handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
1144 -- Filter out the default, if it can't happen,
1145 -- or replace it with "proper" alternative if there
1146 -- is only one constructor left
1147 prepareDefault scrut case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
1149 returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
1150 -- We need the mergeAlts in case the new default_alt
1151 -- has turned into a constructor alternative.
1153 prepareDefault scrut case_bndr handled_cons (Just rhs)
1154 | Just (tycon, inst_tys) <- splitTyConApp_maybe (exprType scrut),
1155 -- Use exprType scrut here, rather than idType case_bndr, because
1156 -- case_bndr is an InId, so exprType scrut may have more information
1157 -- Test simpl013 is an example
1158 isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
1159 not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
1160 -- case x of { DEFAULT -> e }
1161 -- and we don't want to fill in a default for them!
1162 Just all_cons <- tyConDataCons_maybe tycon,
1163 not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
1164 -- which GHC allows, then the case expression will have at most a default
1165 -- alternative. We don't want to eliminate that alternative, because the
1166 -- invariant is that there's always one alternative. It's more convenient
1168 -- case x of { DEFAULT -> e }
1169 -- as it is, rather than transform it to
1170 -- error "case cant match"
1171 -- which would be quite legitmate. But it's a really obscure corner, and
1172 -- not worth wasting code on.
1173 let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
1174 let missing_cons = [con | con <- all_cons,
1175 not (con `elem` handled_data_cons)]
1176 = case missing_cons of
1177 [] -> returnSmpl [] -- Eliminate the default alternative
1178 -- if it can't match
1180 [con] -> -- It matches exactly one constructor, so fill it in
1181 tick (FillInCaseDefault case_bndr) `thenSmpl_`
1182 mk_args con inst_tys `thenSmpl` \ args ->
1183 returnSmpl [(DataAlt con, args, rhs)]
1185 two_or_more -> returnSmpl [(DEFAULT, [], rhs)]
1188 = returnSmpl [(DEFAULT, [], rhs)]
1190 prepareDefault scrut case_bndr handled_cons Nothing
1193 mk_args missing_con inst_tys
1194 = mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
1195 getUniquesSmpl `thenSmpl` \ id_uniqs ->
1196 let arg_tys = dataConInstArgTys missing_con inst_tys'
1197 arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
1199 returnSmpl (tv_bndrs ++ arg_ids)
1201 mk_tv_bndrs missing_con inst_tys
1202 | isVanillaDataCon missing_con
1203 = returnSmpl ([], inst_tys)
1205 = getUniquesSmpl `thenSmpl` \ tv_uniqs ->
1206 let new_tvs = zipWith mk tv_uniqs (dataConTyVars missing_con)
1207 mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
1209 returnSmpl (new_tvs, mkTyVarTys new_tvs)
1213 %************************************************************************
1215 \subsection{Case absorption and identity-case elimination}
1217 %************************************************************************
1219 mkCase puts a case expression back together, trying various transformations first.
1222 mkCase :: OutExpr -> OutId -> OutType
1223 -> [OutAlt] -- Increasing order
1226 mkCase scrut case_bndr ty alts
1227 = getDOptsSmpl `thenSmpl` \dflags ->
1228 mkAlts dflags scrut case_bndr alts `thenSmpl` \ better_alts ->
1229 mkCase1 scrut case_bndr ty better_alts
1233 mkAlts tries these things:
1235 1. If several alternatives are identical, merge them into
1236 a single DEFAULT alternative. I've occasionally seen this
1237 making a big difference:
1239 case e of =====> case e of
1240 C _ -> f x D v -> ....v....
1241 D v -> ....v.... DEFAULT -> f x
1244 The point is that we merge common RHSs, at least for the DEFAULT case.
1245 [One could do something more elaborate but I've never seen it needed.]
1246 To avoid an expensive test, we just merge branches equal to the *first*
1247 alternative; this picks up the common cases
1248 a) all branches equal
1249 b) some branches equal to the DEFAULT (which occurs first)
1252 case e of b { ==> case e of b {
1253 p1 -> rhs1 p1 -> rhs1
1255 pm -> rhsm pm -> rhsm
1256 _ -> case b of b' { pn -> let b'=b in rhsn
1258 ... po -> let b'=b in rhso
1259 po -> rhso _ -> let b'=b in rhsd
1263 which merges two cases in one case when -- the default alternative of
1264 the outer case scrutises the same variable as the outer case This
1265 transformation is called Case Merging. It avoids that the same
1266 variable is scrutinised multiple times.
1269 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
1275 where @is@ was something like
1277 p `is` n = p /= (-1) && p == n
1279 This gave rise to a horrible sequence of cases
1286 and similarly in cascade for all the join points!
1291 --------------------------------------------------
1292 -- 1. Merge identical branches
1293 --------------------------------------------------
1294 mkAlts dflags scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
1295 | all isDeadBinder bndrs1, -- Remember the default
1296 length filtered_alts < length con_alts -- alternative comes first
1297 = tick (AltMerge case_bndr) `thenSmpl_`
1298 returnSmpl better_alts
1300 filtered_alts = filter keep con_alts
1301 keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
1302 better_alts = (DEFAULT, [], rhs1) : filtered_alts
1305 --------------------------------------------------
1306 -- 2. Merge nested cases
1307 --------------------------------------------------
1309 mkAlts dflags scrut outer_bndr outer_alts
1310 | dopt Opt_CaseMerge dflags,
1311 (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
1312 Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt,
1313 scruting_same_var scrut_var
1315 munged_inner_alts = [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts]
1316 munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
1318 new_alts = mergeAlts outer_alts_without_deflt munged_inner_alts
1319 -- The merge keeps the inner DEFAULT at the front, if there is one
1320 -- and eliminates any inner_alts that are shadowed by the outer_alts
1322 tick (CaseMerge outer_bndr) `thenSmpl_`
1324 -- Warning: don't call mkAlts recursively!
1325 -- Firstly, there's no point, because inner alts have already had
1326 -- mkCase applied to them, so they won't have a case in their default
1327 -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
1328 -- in munge_rhs may put a case into the DEFAULT branch!
1330 -- We are scrutinising the same variable if it's
1331 -- the outer case-binder, or if the outer case scrutinises a variable
1332 -- (and it's the same). Testing both allows us not to replace the
1333 -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
1334 scruting_same_var = case scrut of
1335 Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
1336 other -> \ v -> v == outer_bndr
1338 ------------------------------------------------
1340 ------------------------------------------------
1342 mkAlts dflags scrut case_bndr other_alts = returnSmpl other_alts
1345 ---------------------------------
1346 mergeAlts :: [OutAlt] -> [OutAlt] -> [OutAlt]
1347 -- Merge preserving order; alternatives in the first arg
1348 -- shadow ones in the second
1349 mergeAlts [] as2 = as2
1350 mergeAlts as1 [] = as1
1351 mergeAlts (a1:as1) (a2:as2)
1352 = case a1 `cmpAlt` a2 of
1353 LT -> a1 : mergeAlts as1 (a2:as2)
1354 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
1355 GT -> a2 : mergeAlts (a1:as1) as2
1360 =================================================================================
1362 mkCase1 tries these things
1364 1. Eliminate the case altogether if possible
1372 and similar friends.
1375 Start with a simple situation:
1377 case x# of ===> e[x#/y#]
1380 (when x#, y# are of primitive type, of course). We can't (in general)
1381 do this for algebraic cases, because we might turn bottom into
1384 Actually, we generalise this idea to look for a case where we're
1385 scrutinising a variable, and we know that only the default case can
1390 other -> ...(case x of
1394 Here the inner case can be eliminated. This really only shows up in
1395 eliminating error-checking code.
1397 We also make sure that we deal with this very common case:
1402 Here we are using the case as a strict let; if x is used only once
1403 then we want to inline it. We have to be careful that this doesn't
1404 make the program terminate when it would have diverged before, so we
1406 - x is used strictly, or
1407 - e is already evaluated (it may so if e is a variable)
1409 Lastly, we generalise the transformation to handle this:
1415 We only do this for very cheaply compared r's (constructors, literals
1416 and variables). If pedantic bottoms is on, we only do it when the
1417 scrutinee is a PrimOp which can't fail.
1419 We do it *here*, looking at un-simplified alternatives, because we
1420 have to check that r doesn't mention the variables bound by the
1421 pattern in each alternative, so the binder-info is rather useful.
1423 So the case-elimination algorithm is:
1425 1. Eliminate alternatives which can't match
1427 2. Check whether all the remaining alternatives
1428 (a) do not mention in their rhs any of the variables bound in their pattern
1429 and (b) have equal rhss
1431 3. Check we can safely ditch the case:
1432 * PedanticBottoms is off,
1433 or * the scrutinee is an already-evaluated variable
1434 or * the scrutinee is a primop which is ok for speculation
1435 -- ie we want to preserve divide-by-zero errors, and
1436 -- calls to error itself!
1438 or * [Prim cases] the scrutinee is a primitive variable
1440 or * [Alg cases] the scrutinee is a variable and
1441 either * the rhs is the same variable
1442 (eg case x of C a b -> x ===> x)
1443 or * there is only one alternative, the default alternative,
1444 and the binder is used strictly in its scope.
1445 [NB this is helped by the "use default binder where
1446 possible" transformation; see below.]
1449 If so, then we can replace the case with one of the rhss.
1451 Further notes about case elimination
1452 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1453 Consider: test :: Integer -> IO ()
1456 Turns out that this compiles to:
1459 eta1 :: State# RealWorld ->
1460 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1462 (PrelNum.jtos eta ($w[] @ Char))
1464 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1466 Notice the strange '<' which has no effect at all. This is a funny one.
1467 It started like this:
1469 f x y = if x < 0 then jtos x
1470 else if y==0 then "" else jtos x
1472 At a particular call site we have (f v 1). So we inline to get
1474 if v < 0 then jtos x
1475 else if 1==0 then "" else jtos x
1477 Now simplify the 1==0 conditional:
1479 if v<0 then jtos v else jtos v
1481 Now common-up the two branches of the case:
1483 case (v<0) of DEFAULT -> jtos v
1485 Why don't we drop the case? Because it's strict in v. It's technically
1486 wrong to drop even unnecessary evaluations, and in practice they
1487 may be a result of 'seq' so we *definitely* don't want to drop those.
1488 I don't really know how to improve this situation.
1492 --------------------------------------------------
1493 -- 0. Check for empty alternatives
1494 --------------------------------------------------
1496 -- This isn't strictly an error. It's possible that the simplifer might "see"
1497 -- that an inner case has no accessible alternatives before it "sees" that the
1498 -- entire branch of an outer case is inaccessible. So we simply
1499 -- put an error case here insteadd
1500 mkCase1 scrut case_bndr ty []
1501 = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
1502 return (mkApps (Var eRROR_ID)
1503 [Type ty, Lit (mkStringLit "Impossible alternative")])
1505 --------------------------------------------------
1506 -- 1. Eliminate the case altogether if poss
1507 --------------------------------------------------
1509 mkCase1 scrut case_bndr ty [(con,bndrs,rhs)]
1510 -- See if we can get rid of the case altogether
1511 -- See the extensive notes on case-elimination above
1512 -- mkCase made sure that if all the alternatives are equal,
1513 -- then there is now only one (DEFAULT) rhs
1514 | all isDeadBinder bndrs,
1516 -- Check that the scrutinee can be let-bound instead of case-bound
1517 exprOkForSpeculation scrut
1518 -- OK not to evaluate it
1519 -- This includes things like (==# a# b#)::Bool
1520 -- so that we simplify
1521 -- case ==# a# b# of { True -> x; False -> x }
1524 -- This particular example shows up in default methods for
1525 -- comparision operations (e.g. in (>=) for Int.Int32)
1526 || exprIsHNF scrut -- It's already evaluated
1527 || var_demanded_later scrut -- It'll be demanded later
1529 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1530 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1531 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1532 -- its argument: case x of { y -> dataToTag# y }
1533 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1534 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1536 -- Also we don't want to discard 'seq's
1537 = tick (CaseElim case_bndr) `thenSmpl_`
1538 returnSmpl (bindCaseBndr case_bndr scrut rhs)
1541 -- The case binder is going to be evaluated later,
1542 -- and the scrutinee is a simple variable
1543 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1544 var_demanded_later other = False
1547 --------------------------------------------------
1549 --------------------------------------------------
1551 mkCase1 scrut case_bndr ty alts -- Identity case
1552 | all identity_alt alts
1553 = tick (CaseIdentity case_bndr) `thenSmpl_`
1554 returnSmpl (re_note scrut)
1556 identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
1558 identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
1559 identity_rhs (LitAlt lit) _ = Lit lit
1560 identity_rhs DEFAULT _ = Var case_bndr
1562 arg_tys = map Type (tyConAppArgs (idType case_bndr))
1565 -- case coerce T e of x { _ -> coerce T' x }
1566 -- And we definitely want to eliminate this case!
1567 -- So we throw away notes from the RHS, and reconstruct
1568 -- (at least an approximation) at the other end
1569 de_note (Note _ e) = de_note e
1572 -- re_note wraps a coerce if it might be necessary
1573 re_note scrut = case head alts of
1574 (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
1578 --------------------------------------------------
1580 --------------------------------------------------
1581 mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
1585 When adding auxiliary bindings for the case binder, it's worth checking if
1586 its dead, because it often is, and occasionally these mkCase transformations
1587 cascade rather nicely.
1590 bindCaseBndr bndr rhs body
1591 | isDeadBinder bndr = body
1592 | otherwise = bindNonRec bndr rhs body