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,
31 import CoreFVs ( exprFreeVars )
32 import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
33 etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
34 findDefault, exprOkForSpeculation, exprIsHNF
36 import Literal ( mkStringLit )
37 import CoreUnfold ( smallEnoughToInline )
38 import MkId ( eRROR_ID )
39 import Id ( idType, isDataConWorkId, idOccInfo, isDictId,
40 mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
41 idUnfolding, idNewStrictness, idInlinePragma,
43 import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
45 import Type ( Type, splitFunTys, dropForAlls, isStrictType,
46 splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
48 import Name ( mkSysTvName )
49 import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
50 import DataCon ( dataConRepArity, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
51 import Var ( tyVarKind, mkTyVar )
53 import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
54 Activation, isAlwaysActive, isActive )
55 import Util ( lengthExceeds )
60 %************************************************************************
62 \subsection{The continuation data type}
64 %************************************************************************
67 data SimplCont -- Strict contexts
68 = Stop OutType -- Type of the result
70 Bool -- True <=> This is the RHS of a thunk whose type suggests
71 -- that update-in-place would be possible
72 -- (This makes the inliner a little keener.)
74 | CoerceIt OutType -- The To-type, simplified
77 | InlinePlease -- This continuation makes a function very
78 SimplCont -- keen to inline itelf
81 InExpr SimplEnv -- The argument, as yet unsimplified,
82 SimplCont -- and its environment
85 InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
88 | ArgOf LetRhsFlag -- An arbitrary strict context: the argument
89 -- of a strict function, or a primitive-arg fn
91 -- No DupFlag because we never duplicate it
92 OutType -- arg_ty: type of the argument itself
93 OutType -- cont_ty: the type of the expression being sought by the context
94 -- f (error "foo") ==> coerce t (error "foo")
96 -- We need to know the type t, to which to coerce.
98 (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- What to do with the result
99 -- The result expression in the OutExprStuff has type cont_ty
101 data LetRhsFlag = AnArg -- It's just an argument not a let RHS
102 | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas)
104 instance Outputable LetRhsFlag where
105 ppr AnArg = ptext SLIT("arg")
106 ppr AnRhs = ptext SLIT("rhs")
108 instance Outputable SimplCont where
109 ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
110 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
111 ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
112 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
113 (nest 4 (ppr alts)) $$ ppr cont
114 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
115 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
117 data DupFlag = OkToDup | NoDup
119 instance Outputable DupFlag where
120 ppr OkToDup = ptext SLIT("ok")
121 ppr NoDup = ptext SLIT("nodup")
125 mkBoringStop, mkRhsStop :: OutType -> SimplCont
126 mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
127 mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
129 contIsRhs :: SimplCont -> Bool
130 contIsRhs (Stop _ AnRhs _) = True
131 contIsRhs (ArgOf AnRhs _ _ _) = True
132 contIsRhs other = False
134 contIsRhsOrArg (Stop _ _ _) = True
135 contIsRhsOrArg (ArgOf _ _ _ _) = True
136 contIsRhsOrArg other = False
139 contIsDupable :: SimplCont -> Bool
140 contIsDupable (Stop _ _ _) = True
141 contIsDupable (ApplyTo OkToDup _ _ _) = True
142 contIsDupable (Select OkToDup _ _ _ _) = True
143 contIsDupable (CoerceIt _ cont) = contIsDupable cont
144 contIsDupable (InlinePlease cont) = contIsDupable cont
145 contIsDupable other = False
148 discardableCont :: SimplCont -> Bool
149 discardableCont (Stop _ _ _) = False
150 discardableCont (CoerceIt _ cont) = discardableCont cont
151 discardableCont (InlinePlease cont) = discardableCont cont
152 discardableCont other = True
154 discardCont :: SimplCont -- A continuation, expecting
155 -> SimplCont -- Replace the continuation with a suitable coerce
156 discardCont cont = case cont of
157 Stop to_ty is_rhs _ -> cont
158 other -> CoerceIt to_ty (mkBoringStop to_ty)
160 to_ty = contResultType cont
163 contResultType :: SimplCont -> OutType
164 contResultType (Stop to_ty _ _) = to_ty
165 contResultType (ArgOf _ _ to_ty _) = to_ty
166 contResultType (ApplyTo _ _ _ cont) = contResultType cont
167 contResultType (CoerceIt _ cont) = contResultType cont
168 contResultType (InlinePlease cont) = contResultType cont
169 contResultType (Select _ _ _ _ cont) = contResultType cont
172 countValArgs :: SimplCont -> Int
173 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
174 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
175 countValArgs other = 0
177 countArgs :: SimplCont -> Int
178 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
182 pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
183 -- Pushes args with the specified environment
184 pushContArgs env [] cont = cont
185 pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
190 getContArgs :: SwitchChecker
191 -> OutId -> SimplCont
192 -> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
193 SimplCont, -- Remaining continuation
194 Bool) -- Whether we came across an InlineCall
195 -- getContArgs id k = (args, k', inl)
196 -- args are the leading ApplyTo items in k
197 -- (i.e. outermost comes first)
198 -- augmented with demand info from the functionn
199 getContArgs chkr fun orig_cont
201 -- Ignore strictness info if the no-case-of-case
202 -- flag is on. Strictness changes evaluation order
203 -- and that can change full laziness
204 stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
205 | otherwise = computed_stricts
207 go [] stricts False orig_cont
209 ----------------------------
212 go acc ss inl (ApplyTo _ arg@(Type _) se cont)
213 = go ((arg,se,False) : acc) ss inl cont
214 -- NB: don't bother to instantiate the function type
217 go acc (s:ss) inl (ApplyTo _ arg se cont)
218 = go ((arg,se,s) : acc) ss inl cont
220 -- An Inline continuation
221 go acc ss inl (InlinePlease cont)
222 = go acc ss True cont
224 -- We're run out of arguments, or else we've run out of demands
225 -- The latter only happens if the result is guaranteed bottom
226 -- This is the case for
227 -- * case (error "hello") of { ... }
228 -- * (error "Hello") arg
229 -- * f (error "Hello") where f is strict
231 -- Then, especially in the first of these cases, we'd like to discard
232 -- the continuation, leaving just the bottoming expression. But the
233 -- type might not be right, so we may have to add a coerce.
235 | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
236 | otherwise = (reverse acc, cont, inl)
238 ----------------------------
239 vanilla_stricts, computed_stricts :: [Bool]
240 vanilla_stricts = repeat False
241 computed_stricts = zipWith (||) fun_stricts arg_stricts
243 ----------------------------
244 (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun))
245 arg_stricts = map isStrictType val_arg_tys ++ repeat False
246 -- These argument types are used as a cheap and cheerful way to find
247 -- unboxed arguments, which must be strict. But it's an InType
248 -- and so there might be a type variable where we expect a function
249 -- type (the substitution hasn't happened yet). And we don't bother
250 -- doing the type applications for a polymorphic function.
251 -- Hence the splitFunTys*IgnoringForAlls*
253 ----------------------------
254 -- If fun_stricts is finite, it means the function returns bottom
255 -- after that number of value args have been consumed
256 -- Otherwise it's infinite, extended with False
258 = case splitStrictSig (idNewStrictness fun) of
259 (demands, result_info)
260 | not (demands `lengthExceeds` countValArgs orig_cont)
261 -> -- Enough args, use the strictness given.
262 -- For bottoming functions we used to pretend that the arg
263 -- is lazy, so that we don't treat the arg as an
264 -- interesting context. This avoids substituting
265 -- top-level bindings for (say) strings into
266 -- calls to error. But now we are more careful about
267 -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
268 if isBotRes result_info then
269 map isStrictDmd demands -- Finite => result is bottom
271 map isStrictDmd demands ++ vanilla_stricts
273 other -> vanilla_stricts -- Not enough args, or no strictness
276 interestingArg :: OutExpr -> Bool
277 -- An argument is interesting if it has *some* structure
278 -- We are here trying to avoid unfolding a function that
279 -- is applied only to variables that have no unfolding
280 -- (i.e. they are probably lambda bound): f x y z
281 -- There is little point in inlining f here.
282 interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
283 -- Was: isValueUnfolding (idUnfolding v')
284 -- But that seems over-pessimistic
286 -- This accounts for an argument like
287 -- () or [], which is definitely interesting
288 interestingArg (Type _) = False
289 interestingArg (App fn (Type _)) = interestingArg fn
290 interestingArg (Note _ a) = interestingArg a
291 interestingArg other = True
292 -- Consider let x = 3 in f x
293 -- The substitution will contain (x -> ContEx 3), and we want to
294 -- to say that x is an interesting argument.
295 -- But consider also (\x. f x y) y
296 -- The substitution will contain (x -> ContEx y), and we want to say
297 -- that x is not interesting (assuming y has no unfolding)
300 Comment about interestingCallContext
301 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
302 We want to avoid inlining an expression where there can't possibly be
303 any gain, such as in an argument position. Hence, if the continuation
304 is interesting (eg. a case scrutinee, application etc.) then we
305 inline, otherwise we don't.
307 Previously some_benefit used to return True only if the variable was
308 applied to some value arguments. This didn't work:
310 let x = _coerce_ (T Int) Int (I# 3) in
311 case _coerce_ Int (T Int) x of
314 we want to inline x, but can't see that it's a constructor in a case
315 scrutinee position, and some_benefit is False.
319 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
321 .... case dMonadST _@_ x0 of (a,b,c) -> ....
323 we'd really like to inline dMonadST here, but we *don't* want to
324 inline if the case expression is just
326 case x of y { DEFAULT -> ... }
328 since we can just eliminate this case instead (x is in WHNF). Similar
329 applies when x is bound to a lambda expression. Hence
330 contIsInteresting looks for case expressions with just a single
334 interestingCallContext :: Bool -- False <=> no args at all
335 -> Bool -- False <=> no value args
337 -- The "lone-variable" case is important. I spent ages
338 -- messing about with unsatisfactory varaints, but this is nice.
339 -- The idea is that if a variable appear all alone
340 -- as an arg of lazy fn, or rhs Stop
341 -- as scrutinee of a case Select
342 -- as arg of a strict fn ArgOf
343 -- then we should not inline it (unless there is some other reason,
344 -- e.g. is is the sole occurrence). We achieve this by making
345 -- interestingCallContext return False for a lone variable.
347 -- Why? At least in the case-scrutinee situation, turning
348 -- let x = (a,b) in case x of y -> ...
350 -- let x = (a,b) in case (a,b) of y -> ...
352 -- let x = (a,b) in let y = (a,b) in ...
353 -- is bad if the binding for x will remain.
355 -- Another example: I discovered that strings
356 -- were getting inlined straight back into applications of 'error'
357 -- because the latter is strict.
359 -- f = \x -> ...(error s)...
361 -- Fundamentally such contexts should not ecourage inlining because
362 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
363 -- so there's no gain.
365 -- However, even a type application or coercion isn't a lone variable.
367 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
368 -- We had better inline that sucker! The case won't see through it.
370 -- For now, I'm treating treating a variable applied to types
371 -- in a *lazy* context "lone". The motivating example was
373 -- g = /\a. \y. h (f a)
374 -- There's no advantage in inlining f here, and perhaps
375 -- a significant disadvantage. Hence some_val_args in the Stop case
377 interestingCallContext some_args some_val_args cont
380 interesting (InlinePlease _) = True
381 interesting (Select _ _ _ _ _) = some_args
382 interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
383 -- Perhaps True is a bit over-keen, but I've
384 -- seen (coerce f) x, where f has an INLINE prag,
385 -- So we have to give some motivaiton for inlining it
386 interesting (ArgOf _ _ _ _) = some_val_args
387 interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
388 interesting (CoerceIt _ cont) = interesting cont
389 -- If this call is the arg of a strict function, the context
390 -- is a bit interesting. If we inline here, we may get useful
391 -- evaluation information to avoid repeated evals: e.g.
393 -- Here the contIsInteresting makes the '*' keener to inline,
394 -- which in turn exposes a constructor which makes the '+' inline.
395 -- Assuming that +,* aren't small enough to inline regardless.
397 -- It's also very important to inline in a strict context for things
400 -- Here, the context of (f x) is strict, and if f's unfolding is
401 -- a build it's *great* to inline it here. So we must ensure that
402 -- the context for (f x) is not totally uninteresting.
406 canUpdateInPlace :: Type -> Bool
407 -- Consider let x = <wurble> in ...
408 -- If <wurble> returns an explicit constructor, we might be able
409 -- to do update in place. So we treat even a thunk RHS context
410 -- as interesting if update in place is possible. We approximate
411 -- this by seeing if the type has a single constructor with a
412 -- small arity. But arity zero isn't good -- we share the single copy
413 -- for that case, so no point in sharing.
416 | not opt_UF_UpdateInPlace = False
418 = case splitTyConApp_maybe ty of
420 Just (tycon, _) -> case tyConDataCons_maybe tycon of
421 Just [dc] -> arity == 1 || arity == 2
423 arity = dataConRepArity dc
429 %************************************************************************
431 \subsection{Decisions about inlining}
433 %************************************************************************
435 Inlining is controlled partly by the SimplifierMode switch. This has two
438 SimplGently (a) Simplifying before specialiser/full laziness
439 (b) Simplifiying inside INLINE pragma
440 (c) Simplifying the LHS of a rule
441 (d) Simplifying a GHCi expression or Template
444 SimplPhase n Used at all other times
446 The key thing about SimplGently is that it does no call-site inlining.
447 Before full laziness we must be careful not to inline wrappers,
448 because doing so inhibits floating
449 e.g. ...(case f x of ...)...
450 ==> ...(case (case x of I# x# -> fw x#) of ...)...
451 ==> ...(case x of I# x# -> case fw x# of ...)...
452 and now the redex (f x) isn't floatable any more.
454 The no-inling thing is also important for Template Haskell. You might be
455 compiling in one-shot mode with -O2; but when TH compiles a splice before
456 running it, we don't want to use -O2. Indeed, we don't want to inline
457 anything, because the byte-code interpreter might get confused about
458 unboxed tuples and suchlike.
462 SimplGently is also used as the mode to simplify inside an InlineMe note.
465 inlineMode :: SimplifierMode
466 inlineMode = SimplGently
469 It really is important to switch off inlinings inside such
470 expressions. Consider the following example
476 in ...g...g...g...g...g...
478 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
479 and thence copied multiple times when g is inlined.
482 This function may be inlinined in other modules, so we
483 don't want to remove (by inlining) calls to functions that have
484 specialisations, or that may have transformation rules in an importing
487 E.g. {-# INLINE f #-}
490 and suppose that g is strict *and* has specialisations. If we inline
491 g's wrapper, we deny f the chance of getting the specialised version
492 of g when f is inlined at some call site (perhaps in some other
495 It's also important not to inline a worker back into a wrapper.
497 wraper = inline_me (\x -> ...worker... )
498 Normally, the inline_me prevents the worker getting inlined into
499 the wrapper (initially, the worker's only call site!). But,
500 if the wrapper is sure to be called, the strictness analyser will
501 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
502 continuation. That's why the keep_inline predicate returns True for
503 ArgOf continuations. It shouldn't do any harm not to dissolve the
504 inline-me note under these circumstances.
506 Note that the result is that we do very little simplification
509 all xs = foldr (&&) True xs
510 any p = all . map p {-# INLINE any #-}
512 Problem: any won't get deforested, and so if it's exported and the
513 importer doesn't use the inlining, (eg passes it as an arg) then we
514 won't get deforestation at all. We havn't solved this problem yet!
517 preInlineUnconditionally
518 ~~~~~~~~~~~~~~~~~~~~~~~~
519 @preInlineUnconditionally@ examines a bndr to see if it is used just
520 once in a completely safe way, so that it is safe to discard the
521 binding inline its RHS at the (unique) usage site, REGARDLESS of how
522 big the RHS might be. If this is the case we don't simplify the RHS
523 first, but just inline it un-simplified.
525 This is much better than first simplifying a perhaps-huge RHS and then
526 inlining and re-simplifying it. Indeed, it can be at least quadratically
535 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
536 This can happen with cascades of functions too:
543 THE MAIN INVARIANT is this:
545 ---- preInlineUnconditionally invariant -----
546 IF preInlineUnconditionally chooses to inline x = <rhs>
547 THEN doing the inlining should not change the occurrence
548 info for the free vars of <rhs>
549 ----------------------------------------------
551 For example, it's tempting to look at trivial binding like
553 and inline it unconditionally. But suppose x is used many times,
554 but this is the unique occurrence of y. Then inlining x would change
555 y's occurrence info, which breaks the invariant. It matters: y
556 might have a BIG rhs, which will now be dup'd at every occurrenc of x.
559 Evne RHSs labelled InlineMe aren't caught here, because there might be
560 no benefit from inlining at the call site.
562 [Sept 01] Don't unconditionally inline a top-level thing, because that
563 can simply make a static thing into something built dynamically. E.g.
567 [Remember that we treat \s as a one-shot lambda.] No point in
568 inlining x unless there is something interesting about the call site.
570 But watch out: if you aren't careful, some useful foldr/build fusion
571 can be lost (most notably in spectral/hartel/parstof) because the
572 foldr didn't see the build. Doing the dynamic allocation isn't a big
573 deal, in fact, but losing the fusion can be. But the right thing here
574 seems to be to do a callSiteInline based on the fact that there is
575 something interesting about the call site (it's strict). Hmm. That
578 Conclusion: inline top level things gaily until Phase 0 (the last
579 phase), at which point don't.
582 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
583 preInlineUnconditionally env top_lvl bndr rhs
585 | opt_SimplNoPreInlining = False
586 | otherwise = case idOccInfo bndr of
587 IAmDead -> True -- Happens in ((\x.1) v)
588 OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
592 active = case phase of
593 SimplGently -> isAlwaysActive prag
594 SimplPhase n -> isActive n prag
595 prag = idInlinePragma bndr
597 try_once in_lam int_cxt -- There's one textual occurrence
598 | not in_lam = isNotTopLevel top_lvl || early_phase
599 | otherwise = int_cxt && canInlineInLam rhs
601 -- Be very careful before inlining inside a lambda, becuase (a) we must not
602 -- invalidate occurrence information, and (b) we want to avoid pushing a
603 -- single allocation (here) into multiple allocations (inside lambda).
604 -- Inlining a *function* with a single *saturated* call would be ok, mind you.
605 -- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
607 -- is_cheap = exprIsCheap rhs
608 -- ok = is_cheap && int_cxt
610 -- int_cxt The context isn't totally boring
611 -- E.g. let f = \ab.BIG in \y. map f xs
612 -- Don't want to substitute for f, because then we allocate
613 -- its closure every time the \y is called
614 -- But: let f = \ab.BIG in \y. map (f y) xs
615 -- Now we do want to substitute for f, even though it's not
616 -- saturated, because we're going to allocate a closure for
617 -- (f y) every time round the loop anyhow.
619 -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
620 -- so substituting rhs inside a lambda doesn't change the occ info.
621 -- Sadly, not quite the same as exprIsHNF.
622 canInlineInLam (Lit l) = True
623 canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e
624 canInlineInLam (Note _ e) = canInlineInLam e
625 canInlineInLam _ = False
627 early_phase = case phase of
628 SimplPhase 0 -> False
630 -- If we don't have this early_phase test, consider
631 -- x = length [1,2,3]
632 -- The full laziness pass carefully floats all the cons cells to
633 -- top level, and preInlineUnconditionally floats them all back in.
634 -- Result is (a) static allocation replaced by dynamic allocation
635 -- (b) many simplifier iterations because this tickles
636 -- a related problem; only one inlining per pass
638 -- On the other hand, I have seen cases where top-level fusion is
639 -- lost if we don't inline top level thing (e.g. string constants)
640 -- Hence the test for phase zero (which is the phase for all the final
641 -- simplifications). Until phase zero we take no special notice of
642 -- top level things, but then we become more leery about inlining
647 postInlineUnconditionally
648 ~~~~~~~~~~~~~~~~~~~~~~~~~
649 @postInlineUnconditionally@ decides whether to unconditionally inline
650 a thing based on the form of its RHS; in particular if it has a
651 trivial RHS. If so, we can inline and discard the binding altogether.
653 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
654 only have *forward* references Hence, it's safe to discard the binding
656 NOTE: This isn't our last opportunity to inline. We're at the binding
657 site right now, and we'll get another opportunity when we get to the
660 Note that we do this unconditional inlining only for trival RHSs.
661 Don't inline even WHNFs inside lambdas; doing so may simply increase
662 allocation when the function is called. This isn't the last chance; see
665 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
666 Because we don't even want to inline them into the RHS of constructor
667 arguments. See NOTE above
669 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
670 it's best to inline it anyway. We often get a=E; b=a from desugaring,
671 with both a and b marked NOINLINE. But that seems incompatible with
672 our new view that inlining is like a RULE, so I'm sticking to the 'active'
676 postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -> OccInfo -> OutExpr -> Unfolding -> Bool
677 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
679 | isLoopBreaker occ_info = False
680 | isExportedId bndr = False
681 | exprIsTrivial rhs = True
684 OneOcc in_lam one_br int_cxt
685 -> (one_br || smallEnoughToInline unfolding) -- Small enough to dup
686 -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
688 -- NB: Do we want to inline arbitrarily big things becuase
689 -- one_br is True? that can lead to inline cascades. But
690 -- preInlineUnconditionlly has dealt with all the common cases
691 -- so perhaps it's worth the risk. Here's an example
692 -- let f = if b then Left (\x.BIG) else Right (\y.BIG)
694 -- We can't preInlineUnconditionally because that woud invalidate
695 -- the occ info for b. Yet f is used just once, and duplicating
696 -- the case work is fine (exprIsCheap).
698 && ((isNotTopLevel top_lvl && not in_lam) ||
699 -- But outside a lambda, we want to be reasonably aggressive
700 -- about inlining into multiple branches of case
701 -- e.g. let x = <non-value>
702 -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
703 -- Inlining can be a big win if C3 is the hot-spot, even if
704 -- the uses in C1, C2 are not 'interesting'
705 -- An example that gets worse if you add int_cxt here is 'clausify'
707 (isCheapUnfolding unfolding && int_cxt))
708 -- isCheap => acceptable work duplication; in_lam may be true
709 -- int_cxt to prevent us inlining inside a lambda without some
710 -- good reason. See the notes on int_cxt in preInlineUnconditionally
713 -- The point here is that for *non-values* that occur
714 -- outside a lambda, the call-site inliner won't have
715 -- a chance (becuase it doesn't know that the thing
716 -- only occurs once). The pre-inliner won't have gotten
717 -- it either, if the thing occurs in more than one branch
718 -- So the main target is things like
721 -- True -> case x of ...
722 -- False -> case x of ...
723 -- I'm not sure how important this is in practice
725 active = case getMode env of
726 SimplGently -> isAlwaysActive prag
727 SimplPhase n -> isActive n prag
728 prag = idInlinePragma bndr
730 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
731 activeInline env id occ
732 = case getMode env of
733 SimplGently -> isOneOcc occ && isAlwaysActive prag
734 -- No inlining at all when doing gentle stuff,
735 -- except for local things that occur once
736 -- The reason is that too little clean-up happens if you
737 -- don't inline use-once things. Also a bit of inlining is *good* for
738 -- full laziness; it can expose constant sub-expressions.
739 -- Example in spectral/mandel/Mandel.hs, where the mandelset
740 -- function gets a useful let-float if you inline windowToViewport
742 -- NB: we used to have a second exception, for data con wrappers.
743 -- On the grounds that we use gentle mode for rule LHSs, and
744 -- they match better when data con wrappers are inlined.
745 -- But that only really applies to the trivial wrappers (like (:)),
746 -- and they are now constructed as Compulsory unfoldings (in MkId)
747 -- so they'll happen anyway.
749 SimplPhase n -> isActive n prag
751 prag = idInlinePragma id
753 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
754 -- Nothing => No rules at all
756 | opt_RulesOff = Nothing
758 = case getMode env of
759 SimplGently -> Just isAlwaysActive
760 -- Used to be Nothing (no rules in gentle mode)
761 -- Main motivation for changing is that I wanted
762 -- lift String ===> ...
763 -- to work in Template Haskell when simplifying
764 -- splices, so we get simpler code for literal strings
765 SimplPhase n -> Just (isActive n)
769 %************************************************************************
771 \subsection{Rebuilding a lambda}
773 %************************************************************************
776 mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
780 a) eta reduction, if that gives a trivial expression
781 b) eta expansion [only if there are some value lambdas]
782 c) floating lets out through big lambdas
783 [only if all tyvar lambdas, and only if this lambda
787 mkLam env bndrs body cont
788 = getDOptsSmpl `thenSmpl` \dflags ->
789 mkLam' dflags env bndrs body cont
791 mkLam' dflags env bndrs body cont
792 | dopt Opt_DoEtaReduction dflags,
793 Just etad_lam <- tryEtaReduce bndrs body
794 = tick (EtaReduction (head bndrs)) `thenSmpl_`
795 returnSmpl (emptyFloats env, etad_lam)
797 | dopt Opt_DoLambdaEtaExpansion dflags,
798 any isRuntimeVar bndrs
799 = tryEtaExpansion body `thenSmpl` \ body' ->
800 returnSmpl (emptyFloats env, mkLams bndrs body')
802 {- Sept 01: I'm experimenting with getting the
803 full laziness pass to float out past big lambdsa
804 | all isTyVar bndrs, -- Only for big lambdas
805 contIsRhs cont -- Only try the rhs type-lambda floating
806 -- if this is indeed a right-hand side; otherwise
807 -- we end up floating the thing out, only for float-in
808 -- to float it right back in again!
809 = tryRhsTyLam env bndrs body `thenSmpl` \ (floats, body') ->
810 returnSmpl (floats, mkLams bndrs body')
814 = returnSmpl (emptyFloats env, mkLams bndrs body)
818 %************************************************************************
820 \subsection{Eta expansion and reduction}
822 %************************************************************************
824 We try for eta reduction here, but *only* if we get all the
825 way to an exprIsTrivial expression.
826 We don't want to remove extra lambdas unless we are going
827 to avoid allocating this thing altogether
830 tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr
831 tryEtaReduce bndrs body
832 -- We don't use CoreUtils.etaReduce, because we can be more
834 -- (a) we already have the binders
835 -- (b) we can do the triviality test before computing the free vars
836 = go (reverse bndrs) body
838 go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
839 go [] fun | ok_fun fun = Just fun -- Success!
840 go _ _ = Nothing -- Failure!
842 ok_fun fun = exprIsTrivial fun
843 && not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
844 && (exprIsHNF fun || all ok_lam bndrs)
845 ok_lam v = isTyVar v || isDictId v
846 -- The exprIsHNF is because eta reduction is not
847 -- valid in general: \x. bot /= bot
848 -- So we need to be sure that the "fun" is a value.
850 -- However, we always want to reduce (/\a -> f a) to f
851 -- This came up in a RULE: foldr (build (/\a -> g a))
852 -- did not match foldr (build (/\b -> ...something complex...))
853 -- The type checker can insert these eta-expanded versions,
854 -- with both type and dictionary lambdas; hence the slightly
857 ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
861 Try eta expansion for RHSs
864 f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
867 where (in both cases)
869 * The xi can include type variables
871 * The yi are all value variables
873 * N is a NORMAL FORM (i.e. no redexes anywhere)
874 wanting a suitable number of extra args.
876 We may have to sandwich some coerces between the lambdas
877 to make the types work. exprEtaExpandArity looks through coerces
878 when computing arity; and etaExpand adds the coerces as necessary when
879 actually computing the expansion.
882 tryEtaExpansion :: OutExpr -> SimplM OutExpr
883 -- There is at least one runtime binder in the binders
885 = getUniquesSmpl `thenSmpl` \ us ->
886 returnSmpl (etaExpand fun_arity us body (exprType body))
888 fun_arity = exprEtaExpandArity body
892 %************************************************************************
894 \subsection{Floating lets out of big lambdas}
896 %************************************************************************
898 tryRhsTyLam tries this transformation, when the big lambda appears as
899 the RHS of a let(rec) binding:
901 /\abc -> let(rec) x = e in b
903 let(rec) x' = /\abc -> let x = x' a b c in e
905 /\abc -> let x = x' a b c in b
907 This is good because it can turn things like:
909 let f = /\a -> letrec g = ... g ... in g
911 letrec g' = /\a -> ... g' a ...
915 which is better. In effect, it means that big lambdas don't impede
918 This optimisation is CRUCIAL in eliminating the junk introduced by
919 desugaring mutually recursive definitions. Don't eliminate it lightly!
921 So far as the implementation is concerned:
923 Invariant: go F e = /\tvs -> F e
927 = Let x' = /\tvs -> F e
931 G = F . Let x = x' tvs
933 go F (Letrec xi=ei in b)
934 = Letrec {xi' = /\tvs -> G ei}
938 G = F . Let {xi = xi' tvs}
940 [May 1999] If we do this transformation *regardless* then we can
941 end up with some pretty silly stuff. For example,
944 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
949 st = /\s -> ...[y1 s/x1, y2 s/x2]
952 Unless the "..." is a WHNF there is really no point in doing this.
953 Indeed it can make things worse. Suppose x1 is used strictly,
956 x1* = case f y of { (a,b) -> e }
958 If we abstract this wrt the tyvar we then can't do the case inline
959 as we would normally do.
963 {- Trying to do this in full laziness
965 tryRhsTyLam :: SimplEnv -> [OutTyVar] -> OutExpr -> SimplM FloatsWithExpr
966 -- Call ensures that all the binders are type variables
968 tryRhsTyLam env tyvars body -- Only does something if there's a let
969 | not (all isTyVar tyvars)
970 || not (worth_it body) -- inside a type lambda,
971 = returnSmpl (emptyFloats env, body) -- and a WHNF inside that
974 = go env (\x -> x) body
977 worth_it e@(Let _ _) = whnf_in_middle e
980 whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
981 whnf_in_middle (Let _ e) = whnf_in_middle e
982 whnf_in_middle e = exprIsCheap e
984 main_tyvar_set = mkVarSet tyvars
986 go env fn (Let bind@(NonRec var rhs) body)
988 = go env (fn . Let bind) body
990 go env fn (Let (NonRec var rhs) body)
991 = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
992 addAuxiliaryBind env (NonRec var' (mkLams tyvars_here (fn rhs))) $ \ env ->
993 go env (fn . Let (mk_silly_bind var rhs')) body
997 tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprSomeFreeVars isTyVar rhs)
998 -- Abstract only over the type variables free in the rhs
999 -- wrt which the new binding is abstracted. But the naive
1000 -- approach of abstract wrt the tyvars free in the Id's type
1002 -- /\ a b -> let t :: (a,b) = (e1, e2)
1005 -- Here, b isn't free in x's type, but we must nevertheless
1006 -- abstract wrt b as well, because t's type mentions b.
1007 -- Since t is floated too, we'd end up with the bogus:
1008 -- poly_t = /\ a b -> (e1, e2)
1009 -- poly_x = /\ a -> fst (poly_t a *b*)
1010 -- So for now we adopt the even more naive approach of
1011 -- abstracting wrt *all* the tyvars. We'll see if that
1012 -- gives rise to problems. SLPJ June 98
1014 go env fn (Let (Rec prs) body)
1015 = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
1017 gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
1018 pairs = vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]
1020 addAuxiliaryBind env (Rec pairs) $ \ env ->
1023 (vars,rhss) = unzip prs
1024 tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprsSomeFreeVars isTyVar (map snd prs))
1025 -- See notes with tyvars_here above
1027 go env fn body = returnSmpl (emptyFloats env, fn body)
1029 mk_poly tyvars_here var
1030 = getUniqueSmpl `thenSmpl` \ uniq ->
1032 poly_name = setNameUnique (idName var) uniq -- Keep same name
1033 poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
1034 poly_id = mkLocalId poly_name poly_ty
1036 -- In the olden days, it was crucial to copy the occInfo of the original var,
1037 -- because we were looking at occurrence-analysed but as yet unsimplified code!
1038 -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking
1039 -- at already simplified code, so it doesn't matter
1041 -- It's even right to retain single-occurrence or dead-var info:
1042 -- Suppose we started with /\a -> let x = E in B
1043 -- where x occurs once in B. Then we transform to:
1044 -- let x' = /\a -> E in /\a -> let x* = x' a in B
1045 -- where x* has an INLINE prag on it. Now, once x* is inlined,
1046 -- the occurrences of x' will be just the occurrences originally
1049 returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
1051 mk_silly_bind var rhs = NonRec var (Note InlineMe rhs)
1052 -- Suppose we start with:
1054 -- x = /\ a -> let g = G in E
1056 -- Then we'll float to get
1058 -- x = let poly_g = /\ a -> G
1059 -- in /\ a -> let g = poly_g a in E
1061 -- But now the occurrence analyser will see just one occurrence
1062 -- of poly_g, not inside a lambda, so the simplifier will
1063 -- PreInlineUnconditionally poly_g back into g! Badk to square 1!
1064 -- (I used to think that the "don't inline lone occurrences" stuff
1065 -- would stop this happening, but since it's the *only* occurrence,
1066 -- PreInlineUnconditionally kicks in first!)
1068 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
1069 -- to appear many times. (NB: mkInlineMe eliminates
1070 -- such notes on trivial RHSs, so do it manually.)
1074 %************************************************************************
1076 \subsection{Case alternative filtering
1078 %************************************************************************
1080 prepareAlts does two things:
1082 1. Eliminate alternatives that cannot match, including the
1083 DEFAULT alternative.
1085 2. If the DEFAULT alternative can match only one possible constructor,
1086 then make that constructor explicit.
1088 case e of x { DEFAULT -> rhs }
1090 case e of x { (a,b) -> rhs }
1091 where the type is a single constructor type. This gives better code
1092 when rhs also scrutinises x or e.
1094 It's a good idea do do this stuff before simplifying the alternatives, to
1095 avoid simplifying alternatives we know can't happen, and to come up with
1096 the list of constructors that are handled, to put into the IdInfo of the
1097 case binder, for use when simplifying the alternatives.
1099 Eliminating the default alternative in (1) isn't so obvious, but it can
1102 data Colour = Red | Green | Blue
1111 DEFAULT -> [ case y of ... ]
1113 If we inline h into f, the default case of the inlined h can't happen.
1114 If we don't notice this, we may end up filtering out *all* the cases
1115 of the inner case y, which give us nowhere to go!
1119 prepareAlts :: OutExpr -- Scrutinee
1120 -> InId -- Case binder (passed only to use in statistics)
1121 -> [InAlt] -- Increasing order
1122 -> SimplM ([InAlt], -- Better alternatives, still incresaing order
1123 [AltCon]) -- These cases are handled
1125 prepareAlts scrut case_bndr alts
1127 (alts_wo_default, maybe_deflt) = findDefault alts
1129 impossible_cons = case scrut of
1130 Var v -> otherCons (idUnfolding v)
1133 -- Filter out alternatives that can't possibly match
1134 better_alts | null impossible_cons = alts_wo_default
1135 | otherwise = [alt | alt@(con,_,_) <- alts_wo_default,
1136 not (con `elem` impossible_cons)]
1138 -- "handled_cons" are handled either by the context,
1139 -- or by a branch in this case expression
1140 -- (Don't add DEFAULT to the handled_cons!!)
1141 handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
1143 -- Filter out the default, if it can't happen,
1144 -- or replace it with "proper" alternative if there
1145 -- is only one constructor left
1146 prepareDefault scrut case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
1148 returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
1149 -- We need the mergeAlts in case the new default_alt
1150 -- has turned into a constructor alternative.
1152 prepareDefault scrut case_bndr handled_cons (Just rhs)
1153 | Just (tycon, inst_tys) <- splitTyConApp_maybe (exprType scrut),
1154 -- Use exprType scrut here, rather than idType case_bndr, because
1155 -- case_bndr is an InId, so exprType scrut may have more information
1156 -- Test simpl013 is an example
1157 isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
1158 not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
1159 -- case x of { DEFAULT -> e }
1160 -- and we don't want to fill in a default for them!
1161 Just all_cons <- tyConDataCons_maybe tycon,
1162 not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
1163 -- which GHC allows, then the case expression will have at most a default
1164 -- alternative. We don't want to eliminate that alternative, because the
1165 -- invariant is that there's always one alternative. It's more convenient
1167 -- case x of { DEFAULT -> e }
1168 -- as it is, rather than transform it to
1169 -- error "case cant match"
1170 -- which would be quite legitmate. But it's a really obscure corner, and
1171 -- not worth wasting code on.
1172 let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
1173 let missing_cons = [con | con <- all_cons,
1174 not (con `elem` handled_data_cons)]
1175 = case missing_cons of
1176 [] -> returnSmpl [] -- Eliminate the default alternative
1177 -- if it can't match
1179 [con] -> -- It matches exactly one constructor, so fill it in
1180 tick (FillInCaseDefault case_bndr) `thenSmpl_`
1181 mk_args con inst_tys `thenSmpl` \ args ->
1182 returnSmpl [(DataAlt con, args, rhs)]
1184 two_or_more -> returnSmpl [(DEFAULT, [], rhs)]
1187 = returnSmpl [(DEFAULT, [], rhs)]
1189 prepareDefault scrut case_bndr handled_cons Nothing
1192 mk_args missing_con inst_tys
1193 = mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
1194 getUniquesSmpl `thenSmpl` \ id_uniqs ->
1195 let arg_tys = dataConInstArgTys missing_con inst_tys'
1196 arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
1198 returnSmpl (tv_bndrs ++ arg_ids)
1200 mk_tv_bndrs missing_con inst_tys
1201 | isVanillaDataCon missing_con
1202 = returnSmpl ([], inst_tys)
1204 = getUniquesSmpl `thenSmpl` \ tv_uniqs ->
1205 let new_tvs = zipWith mk tv_uniqs (dataConTyVars missing_con)
1206 mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
1208 returnSmpl (new_tvs, mkTyVarTys new_tvs)
1212 %************************************************************************
1214 \subsection{Case absorption and identity-case elimination}
1216 %************************************************************************
1218 mkCase puts a case expression back together, trying various transformations first.
1221 mkCase :: OutExpr -> OutId -> OutType
1222 -> [OutAlt] -- Increasing order
1225 mkCase scrut case_bndr ty alts
1226 = getDOptsSmpl `thenSmpl` \dflags ->
1227 mkAlts dflags scrut case_bndr alts `thenSmpl` \ better_alts ->
1228 mkCase1 scrut case_bndr ty better_alts
1232 mkAlts tries these things:
1234 1. If several alternatives are identical, merge them into
1235 a single DEFAULT alternative. I've occasionally seen this
1236 making a big difference:
1238 case e of =====> case e of
1239 C _ -> f x D v -> ....v....
1240 D v -> ....v.... DEFAULT -> f x
1243 The point is that we merge common RHSs, at least for the DEFAULT case.
1244 [One could do something more elaborate but I've never seen it needed.]
1245 To avoid an expensive test, we just merge branches equal to the *first*
1246 alternative; this picks up the common cases
1247 a) all branches equal
1248 b) some branches equal to the DEFAULT (which occurs first)
1251 case e of b { ==> case e of b {
1252 p1 -> rhs1 p1 -> rhs1
1254 pm -> rhsm pm -> rhsm
1255 _ -> case b of b' { pn -> let b'=b in rhsn
1257 ... po -> let b'=b in rhso
1258 po -> rhso _ -> let b'=b in rhsd
1262 which merges two cases in one case when -- the default alternative of
1263 the outer case scrutises the same variable as the outer case This
1264 transformation is called Case Merging. It avoids that the same
1265 variable is scrutinised multiple times.
1268 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
1274 where @is@ was something like
1276 p `is` n = p /= (-1) && p == n
1278 This gave rise to a horrible sequence of cases
1285 and similarly in cascade for all the join points!
1290 --------------------------------------------------
1291 -- 1. Merge identical branches
1292 --------------------------------------------------
1293 mkAlts dflags scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
1294 | all isDeadBinder bndrs1, -- Remember the default
1295 length filtered_alts < length con_alts -- alternative comes first
1296 = tick (AltMerge case_bndr) `thenSmpl_`
1297 returnSmpl better_alts
1299 filtered_alts = filter keep con_alts
1300 keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
1301 better_alts = (DEFAULT, [], rhs1) : filtered_alts
1304 --------------------------------------------------
1305 -- 2. Merge nested cases
1306 --------------------------------------------------
1308 mkAlts dflags scrut outer_bndr outer_alts
1309 | dopt Opt_CaseMerge dflags,
1310 (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
1311 Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt,
1312 scruting_same_var scrut_var
1314 munged_inner_alts = [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts]
1315 munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
1317 new_alts = mergeAlts outer_alts_without_deflt munged_inner_alts
1318 -- The merge keeps the inner DEFAULT at the front, if there is one
1319 -- and eliminates any inner_alts that are shadowed by the outer_alts
1321 tick (CaseMerge outer_bndr) `thenSmpl_`
1323 -- Warning: don't call mkAlts recursively!
1324 -- Firstly, there's no point, because inner alts have already had
1325 -- mkCase applied to them, so they won't have a case in their default
1326 -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
1327 -- in munge_rhs may put a case into the DEFAULT branch!
1329 -- We are scrutinising the same variable if it's
1330 -- the outer case-binder, or if the outer case scrutinises a variable
1331 -- (and it's the same). Testing both allows us not to replace the
1332 -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
1333 scruting_same_var = case scrut of
1334 Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
1335 other -> \ v -> v == outer_bndr
1337 ------------------------------------------------
1339 ------------------------------------------------
1341 mkAlts dflags scrut case_bndr other_alts = returnSmpl other_alts
1344 ---------------------------------
1345 mergeAlts :: [OutAlt] -> [OutAlt] -> [OutAlt]
1346 -- Merge preserving order; alternatives in the first arg
1347 -- shadow ones in the second
1348 mergeAlts [] as2 = as2
1349 mergeAlts as1 [] = as1
1350 mergeAlts (a1:as1) (a2:as2)
1351 = case a1 `cmpAlt` a2 of
1352 LT -> a1 : mergeAlts as1 (a2:as2)
1353 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
1354 GT -> a2 : mergeAlts (a1:as1) as2
1359 =================================================================================
1361 mkCase1 tries these things
1363 1. Eliminate the case altogether if possible
1371 and similar friends.
1374 Start with a simple situation:
1376 case x# of ===> e[x#/y#]
1379 (when x#, y# are of primitive type, of course). We can't (in general)
1380 do this for algebraic cases, because we might turn bottom into
1383 Actually, we generalise this idea to look for a case where we're
1384 scrutinising a variable, and we know that only the default case can
1389 other -> ...(case x of
1393 Here the inner case can be eliminated. This really only shows up in
1394 eliminating error-checking code.
1396 We also make sure that we deal with this very common case:
1401 Here we are using the case as a strict let; if x is used only once
1402 then we want to inline it. We have to be careful that this doesn't
1403 make the program terminate when it would have diverged before, so we
1405 - x is used strictly, or
1406 - e is already evaluated (it may so if e is a variable)
1408 Lastly, we generalise the transformation to handle this:
1414 We only do this for very cheaply compared r's (constructors, literals
1415 and variables). If pedantic bottoms is on, we only do it when the
1416 scrutinee is a PrimOp which can't fail.
1418 We do it *here*, looking at un-simplified alternatives, because we
1419 have to check that r doesn't mention the variables bound by the
1420 pattern in each alternative, so the binder-info is rather useful.
1422 So the case-elimination algorithm is:
1424 1. Eliminate alternatives which can't match
1426 2. Check whether all the remaining alternatives
1427 (a) do not mention in their rhs any of the variables bound in their pattern
1428 and (b) have equal rhss
1430 3. Check we can safely ditch the case:
1431 * PedanticBottoms is off,
1432 or * the scrutinee is an already-evaluated variable
1433 or * the scrutinee is a primop which is ok for speculation
1434 -- ie we want to preserve divide-by-zero errors, and
1435 -- calls to error itself!
1437 or * [Prim cases] the scrutinee is a primitive variable
1439 or * [Alg cases] the scrutinee is a variable and
1440 either * the rhs is the same variable
1441 (eg case x of C a b -> x ===> x)
1442 or * there is only one alternative, the default alternative,
1443 and the binder is used strictly in its scope.
1444 [NB this is helped by the "use default binder where
1445 possible" transformation; see below.]
1448 If so, then we can replace the case with one of the rhss.
1450 Further notes about case elimination
1451 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1452 Consider: test :: Integer -> IO ()
1455 Turns out that this compiles to:
1458 eta1 :: State# RealWorld ->
1459 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1461 (PrelNum.jtos eta ($w[] @ Char))
1463 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1465 Notice the strange '<' which has no effect at all. This is a funny one.
1466 It started like this:
1468 f x y = if x < 0 then jtos x
1469 else if y==0 then "" else jtos x
1471 At a particular call site we have (f v 1). So we inline to get
1473 if v < 0 then jtos x
1474 else if 1==0 then "" else jtos x
1476 Now simplify the 1==0 conditional:
1478 if v<0 then jtos v else jtos v
1480 Now common-up the two branches of the case:
1482 case (v<0) of DEFAULT -> jtos v
1484 Why don't we drop the case? Because it's strict in v. It's technically
1485 wrong to drop even unnecessary evaluations, and in practice they
1486 may be a result of 'seq' so we *definitely* don't want to drop those.
1487 I don't really know how to improve this situation.
1491 --------------------------------------------------
1492 -- 0. Check for empty alternatives
1493 --------------------------------------------------
1495 -- This isn't strictly an error. It's possible that the simplifer might "see"
1496 -- that an inner case has no accessible alternatives before it "sees" that the
1497 -- entire branch of an outer case is inaccessible. So we simply
1498 -- put an error case here insteadd
1499 mkCase1 scrut case_bndr ty []
1500 = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
1501 return (mkApps (Var eRROR_ID)
1502 [Type ty, Lit (mkStringLit "Impossible alternative")])
1504 --------------------------------------------------
1505 -- 1. Eliminate the case altogether if poss
1506 --------------------------------------------------
1508 mkCase1 scrut case_bndr ty [(con,bndrs,rhs)]
1509 -- See if we can get rid of the case altogether
1510 -- See the extensive notes on case-elimination above
1511 -- mkCase made sure that if all the alternatives are equal,
1512 -- then there is now only one (DEFAULT) rhs
1513 | all isDeadBinder bndrs,
1515 -- Check that the scrutinee can be let-bound instead of case-bound
1516 exprOkForSpeculation scrut
1517 -- OK not to evaluate it
1518 -- This includes things like (==# a# b#)::Bool
1519 -- so that we simplify
1520 -- case ==# a# b# of { True -> x; False -> x }
1523 -- This particular example shows up in default methods for
1524 -- comparision operations (e.g. in (>=) for Int.Int32)
1525 || exprIsHNF scrut -- It's already evaluated
1526 || var_demanded_later scrut -- It'll be demanded later
1528 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1529 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1530 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1531 -- its argument: case x of { y -> dataToTag# y }
1532 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1533 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1535 -- Also we don't want to discard 'seq's
1536 = tick (CaseElim case_bndr) `thenSmpl_`
1537 returnSmpl (bindCaseBndr case_bndr scrut rhs)
1540 -- The case binder is going to be evaluated later,
1541 -- and the scrutinee is a simple variable
1542 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1543 var_demanded_later other = False
1546 --------------------------------------------------
1548 --------------------------------------------------
1550 mkCase1 scrut case_bndr ty alts -- Identity case
1551 | all identity_alt alts
1552 = tick (CaseIdentity case_bndr) `thenSmpl_`
1553 returnSmpl (re_note scrut)
1555 identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
1557 identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
1558 identity_rhs (LitAlt lit) _ = Lit lit
1559 identity_rhs DEFAULT _ = Var case_bndr
1561 arg_tys = map Type (tyConAppArgs (idType case_bndr))
1564 -- case coerce T e of x { _ -> coerce T' x }
1565 -- And we definitely want to eliminate this case!
1566 -- So we throw away notes from the RHS, and reconstruct
1567 -- (at least an approximation) at the other end
1568 de_note (Note _ e) = de_note e
1571 -- re_note wraps a coerce if it might be necessary
1572 re_note scrut = case head alts of
1573 (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
1577 --------------------------------------------------
1579 --------------------------------------------------
1580 mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
1584 When adding auxiliary bindings for the case binder, it's worth checking if
1585 its dead, because it often is, and occasionally these mkCase transformations
1586 cascade rather nicely.
1589 bindCaseBndr bndr rhs body
1590 | isDeadBinder bndr = body
1591 | otherwise = bindNonRec bndr rhs body