2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplUtils]{The simplifier utilities}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 mkLam, mkCase, prepareAlts, bindCaseBndr,
19 preInlineUnconditionally, postInlineUnconditionally,
20 activeInline, activeRule, inlineMode,
22 -- The continuation type
23 SimplCont(..), DupFlag(..), LetRhsFlag(..),
24 contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs,
25 countValArgs, countArgs, splitInlineCont,
26 mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
27 interestingCallContext, interestingArgContext,
29 interestingArg, mkArgInfo,
34 #include "HsVersions.h"
40 import qualified CoreSubst
49 import Var ( isCoVar )
52 import Type ( Type, funArgTy, mkForAllTys, mkTyVarTys,
53 splitTyConApp_maybe, tyConAppArgs )
56 import Unify ( dataConCannotMatch )
65 %************************************************************************
69 %************************************************************************
71 A SimplCont allows the simplifier to traverse the expression in a
72 zipper-like fashion. The SimplCont represents the rest of the expression,
73 "above" the point of interest.
75 You can also think of a SimplCont as an "evaluation context", using
76 that term in the way it is used for operational semantics. This is the
77 way I usually think of it, For example you'll often see a syntax for
78 evaluation context looking like
79 C ::= [] | C e | case C of alts | C `cast` co
80 That's the kind of thing we are doing here, and I use that syntax in
85 * A SimplCont describes a *strict* context (just like
86 evaluation contexts do). E.g. Just [] is not a SimplCont
88 * A SimplCont describes a context that *does not* bind
89 any variables. E.g. \x. [] is not a SimplCont
93 = Stop -- An empty context, or hole, []
94 OutType -- Type of the result
96 Bool -- True <=> There is something interesting about
97 -- the context, and hence the inliner
98 -- should be a bit keener (see interestingCallContext)
100 -- (a) This is the RHS of a thunk whose type suggests
101 -- that update-in-place would be possible
102 -- (b) This is an argument of a function that has RULES
103 -- Inlining the call might allow the rule to fire
105 | CoerceIt -- C `cast` co
106 OutCoercion -- The coercion simplified
111 InExpr SimplEnv -- The argument and its static env
114 | Select -- case C of alts
116 InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
119 -- The two strict forms have no DupFlag, because we never duplicate them
120 | StrictBind -- (\x* \xs. e) C
121 InId [InBndr] -- let x* = [] in e
122 InExpr SimplEnv -- is a special case
126 OutExpr OutType -- e and its type
127 (Bool,[Bool]) -- Whether the function at the head of e has rules,
128 SimplCont -- plus strictness flags for further args
130 data LetRhsFlag = AnArg -- It's just an argument not a let RHS
131 | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas)
133 instance Outputable LetRhsFlag where
134 ppr AnArg = ptext SLIT("arg")
135 ppr AnRhs = ptext SLIT("rhs")
137 instance Outputable SimplCont where
138 ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
139 ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg)
140 {- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
141 ppr (StrictBind b _ _ _ cont) = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont
142 ppr (StrictArg f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
143 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
144 (nest 4 (ppr alts)) $$ ppr cont
145 ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
147 data DupFlag = OkToDup | NoDup
149 instance Outputable DupFlag where
150 ppr OkToDup = ptext SLIT("ok")
151 ppr NoDup = ptext SLIT("nodup")
156 mkBoringStop :: OutType -> SimplCont
157 mkBoringStop ty = Stop ty AnArg False
159 mkLazyArgStop :: OutType -> Bool -> SimplCont
160 mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules)
162 mkRhsStop :: OutType -> SimplCont
163 mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
166 contIsRhsOrArg (Stop {}) = True
167 contIsRhsOrArg (StrictBind {}) = True
168 contIsRhsOrArg (StrictArg {}) = True
169 contIsRhsOrArg other = False
172 contIsDupable :: SimplCont -> Bool
173 contIsDupable (Stop {}) = True
174 contIsDupable (ApplyTo OkToDup _ _ _) = True
175 contIsDupable (Select OkToDup _ _ _ _) = True
176 contIsDupable (CoerceIt _ cont) = contIsDupable cont
177 contIsDupable other = False
180 contIsTrivial :: SimplCont -> Bool
181 contIsTrivial (Stop {}) = True
182 contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
183 contIsTrivial (CoerceIt _ cont) = contIsTrivial cont
184 contIsTrivial other = False
187 contResultType :: SimplCont -> OutType
188 contResultType (Stop to_ty _ _) = to_ty
189 contResultType (StrictArg _ _ _ cont) = contResultType cont
190 contResultType (StrictBind _ _ _ _ cont) = contResultType cont
191 contResultType (ApplyTo _ _ _ cont) = contResultType cont
192 contResultType (CoerceIt _ cont) = contResultType cont
193 contResultType (Select _ _ _ _ cont) = contResultType cont
196 countValArgs :: SimplCont -> Int
197 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
198 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
199 countValArgs other = 0
201 countArgs :: SimplCont -> Int
202 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
205 contArgs :: SimplCont -> ([OutExpr], SimplCont)
206 -- Uses substitution to turn each arg into an OutExpr
207 contArgs cont = go [] cont
209 go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
210 go args cont = (reverse args, cont)
212 dropArgs :: Int -> SimplCont -> SimplCont
213 dropArgs 0 cont = cont
214 dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
215 dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other)
218 splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont)
219 -- Returns Nothing if the continuation should dissolve an InlineMe Note
220 -- Return Just (c1,c2) otherwise,
221 -- where c1 is the continuation to put inside the InlineMe
224 -- Example: (__inline_me__ (/\a. e)) ty
225 -- Here we want to do the beta-redex without dissolving the InlineMe
226 -- See test simpl017 (and Trac #1627) for a good example of why this is important
228 splitInlineCont (ApplyTo dup (Type ty) se c)
229 | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
230 splitInlineCont cont@(Stop ty _ _) = Just (mkBoringStop ty, cont)
231 splitInlineCont cont@(StrictBind bndr _ _ se _) = Just (mkBoringStop (substTy se (idType bndr)), cont)
232 splitInlineCont cont@(StrictArg _ fun_ty _ _) = Just (mkBoringStop (funArgTy fun_ty), cont)
233 splitInlineCont other = Nothing
234 -- NB: the calculation of the type for mkBoringStop is an annoying
235 -- duplication of the same calucation in mkDupableCont
240 interestingArg :: OutExpr -> Bool
241 -- An argument is interesting if it has *some* structure
242 -- We are here trying to avoid unfolding a function that
243 -- is applied only to variables that have no unfolding
244 -- (i.e. they are probably lambda bound): f x y z
245 -- There is little point in inlining f here.
246 interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
247 -- Was: isValueUnfolding (idUnfolding v')
248 -- But that seems over-pessimistic
250 -- This accounts for an argument like
251 -- () or [], which is definitely interesting
252 interestingArg (Type _) = False
253 interestingArg (App fn (Type _)) = interestingArg fn
254 interestingArg (Note _ a) = interestingArg a
256 -- Idea (from Sam B); I'm not sure if it's a good idea, so commented out for now
257 -- interestingArg expr | isUnLiftedType (exprType expr)
258 -- -- Unlifted args are only ever interesting if we know what they are
263 interestingArg other = True
264 -- Consider let x = 3 in f x
265 -- The substitution will contain (x -> ContEx 3), and we want to
266 -- to say that x is an interesting argument.
267 -- But consider also (\x. f x y) y
268 -- The substitution will contain (x -> ContEx y), and we want to say
269 -- that x is not interesting (assuming y has no unfolding)
273 Comment about interestingCallContext
274 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
275 We want to avoid inlining an expression where there can't possibly be
276 any gain, such as in an argument position. Hence, if the continuation
277 is interesting (eg. a case scrutinee, application etc.) then we
278 inline, otherwise we don't.
280 Previously some_benefit used to return True only if the variable was
281 applied to some value arguments. This didn't work:
283 let x = _coerce_ (T Int) Int (I# 3) in
284 case _coerce_ Int (T Int) x of
287 we want to inline x, but can't see that it's a constructor in a case
288 scrutinee position, and some_benefit is False.
292 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
294 .... case dMonadST _@_ x0 of (a,b,c) -> ....
296 we'd really like to inline dMonadST here, but we *don't* want to
297 inline if the case expression is just
299 case x of y { DEFAULT -> ... }
301 since we can just eliminate this case instead (x is in WHNF). Similar
302 applies when x is bound to a lambda expression. Hence
303 contIsInteresting looks for case expressions with just a single
307 interestingCallContext :: Bool -- False <=> no args at all
308 -> Bool -- False <=> no value args
310 -- The "lone-variable" case is important. I spent ages
311 -- messing about with unsatisfactory varaints, but this is nice.
312 -- The idea is that if a variable appear all alone
313 -- as an arg of lazy fn, or rhs Stop
314 -- as scrutinee of a case Select
315 -- as arg of a strict fn ArgOf
316 -- then we should not inline it (unless there is some other reason,
317 -- e.g. is is the sole occurrence). We achieve this by making
318 -- interestingCallContext return False for a lone variable.
320 -- Why? At least in the case-scrutinee situation, turning
321 -- let x = (a,b) in case x of y -> ...
323 -- let x = (a,b) in case (a,b) of y -> ...
325 -- let x = (a,b) in let y = (a,b) in ...
326 -- is bad if the binding for x will remain.
328 -- Another example: I discovered that strings
329 -- were getting inlined straight back into applications of 'error'
330 -- because the latter is strict.
332 -- f = \x -> ...(error s)...
334 -- Fundamentally such contexts should not ecourage inlining because
335 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
336 -- so there's no gain.
338 -- However, even a type application or coercion isn't a lone variable.
340 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
341 -- We had better inline that sucker! The case won't see through it.
343 -- For now, I'm treating treating a variable applied to types
344 -- in a *lazy* context "lone". The motivating example was
346 -- g = /\a. \y. h (f a)
347 -- There's no advantage in inlining f here, and perhaps
348 -- a significant disadvantage. Hence some_val_args in the Stop case
350 interestingCallContext some_args some_val_args cont
353 interesting (Select {}) = some_args
354 interesting (ApplyTo {}) = True -- Can happen if we have (coerce t (f x)) y
355 -- Perhaps True is a bit over-keen, but I've
356 -- seen (coerce f) x, where f has an INLINE prag,
357 -- So we have to give some motivaiton for inlining it
358 interesting (StrictArg {}) = some_val_args
359 interesting (StrictBind {}) = some_val_args -- ??
360 interesting (Stop ty _ interesting) = some_val_args && interesting
361 interesting (CoerceIt _ cont) = interesting cont
362 -- If this call is the arg of a strict function, the context
363 -- is a bit interesting. If we inline here, we may get useful
364 -- evaluation information to avoid repeated evals: e.g.
366 -- Here the contIsInteresting makes the '*' keener to inline,
367 -- which in turn exposes a constructor which makes the '+' inline.
368 -- Assuming that +,* aren't small enough to inline regardless.
370 -- It's also very important to inline in a strict context for things
373 -- Here, the context of (f x) is strict, and if f's unfolding is
374 -- a build it's *great* to inline it here. So we must ensure that
375 -- the context for (f x) is not totally uninteresting.
380 -> Int -- Number of value args
381 -> SimplCont -- Context of the cal
382 -> (Bool, [Bool]) -- Arg info
383 -- The arg info consists of
384 -- * A Bool indicating if the function has rules (recursively)
385 -- * A [Bool] indicating strictness for each arg
386 -- The [Bool] is usually infinite, but if it is finite it
387 -- guarantees that the function diverges after being given
388 -- that number of args
390 mkArgInfo fun n_val_args call_cont
391 = (interestingArgContext fun call_cont, fun_stricts)
393 vanilla_stricts, fun_stricts :: [Bool]
394 vanilla_stricts = repeat False
397 = case splitStrictSig (idNewStrictness fun) of
398 (demands, result_info)
399 | not (demands `lengthExceeds` n_val_args)
400 -> -- Enough args, use the strictness given.
401 -- For bottoming functions we used to pretend that the arg
402 -- is lazy, so that we don't treat the arg as an
403 -- interesting context. This avoids substituting
404 -- top-level bindings for (say) strings into
405 -- calls to error. But now we are more careful about
406 -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
407 if isBotRes result_info then
408 map isStrictDmd demands -- Finite => result is bottom
410 map isStrictDmd demands ++ vanilla_stricts
412 other -> vanilla_stricts -- Not enough args, or no strictness
414 interestingArgContext :: Id -> SimplCont -> Bool
415 -- If the argument has form (f x y), where x,y are boring,
416 -- and f is marked INLINE, then we don't want to inline f.
417 -- But if the context of the argument is
419 -- where g has rules, then we *do* want to inline f, in case it
420 -- exposes a rule that might fire. Similarly, if the context is
422 -- where h has rules, then we do want to inline f.
423 -- The interesting_arg_ctxt flag makes this happen; if it's
424 -- set, the inliner gets just enough keener to inline f
425 -- regardless of how boring f's arguments are, if it's marked INLINE
427 -- The alternative would be to *always* inline an INLINE function,
428 -- regardless of how boring its context is; but that seems overkill
429 -- For example, it'd mean that wrapper functions were always inlined
430 interestingArgContext fn cont
431 = idHasRules fn || go cont
433 go (Select {}) = False
434 go (ApplyTo {}) = False
435 go (StrictArg {}) = True
436 go (StrictBind {}) = False -- ??
437 go (CoerceIt _ c) = go c
438 go (Stop _ _ interesting) = interesting
441 canUpdateInPlace :: Type -> Bool
442 -- Consider let x = <wurble> in ...
443 -- If <wurble> returns an explicit constructor, we might be able
444 -- to do update in place. So we treat even a thunk RHS context
445 -- as interesting if update in place is possible. We approximate
446 -- this by seeing if the type has a single constructor with a
447 -- small arity. But arity zero isn't good -- we share the single copy
448 -- for that case, so no point in sharing.
451 | not opt_UF_UpdateInPlace = False
453 = case splitTyConApp_maybe ty of
455 Just (tycon, _) -> case tyConDataCons_maybe tycon of
456 Just [dc] -> arity == 1 || arity == 2
458 arity = dataConRepArity dc
464 %************************************************************************
466 \subsection{Decisions about inlining}
468 %************************************************************************
470 Inlining is controlled partly by the SimplifierMode switch. This has two
473 SimplGently (a) Simplifying before specialiser/full laziness
474 (b) Simplifiying inside INLINE pragma
475 (c) Simplifying the LHS of a rule
476 (d) Simplifying a GHCi expression or Template
479 SimplPhase n Used at all other times
481 The key thing about SimplGently is that it does no call-site inlining.
482 Before full laziness we must be careful not to inline wrappers,
483 because doing so inhibits floating
484 e.g. ...(case f x of ...)...
485 ==> ...(case (case x of I# x# -> fw x#) of ...)...
486 ==> ...(case x of I# x# -> case fw x# of ...)...
487 and now the redex (f x) isn't floatable any more.
489 The no-inlining thing is also important for Template Haskell. You might be
490 compiling in one-shot mode with -O2; but when TH compiles a splice before
491 running it, we don't want to use -O2. Indeed, we don't want to inline
492 anything, because the byte-code interpreter might get confused about
493 unboxed tuples and suchlike.
497 SimplGently is also used as the mode to simplify inside an InlineMe note.
500 inlineMode :: SimplifierMode
501 inlineMode = SimplGently
504 It really is important to switch off inlinings inside such
505 expressions. Consider the following example
511 in ...g...g...g...g...g...
513 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
514 and thence copied multiple times when g is inlined.
517 This function may be inlinined in other modules, so we
518 don't want to remove (by inlining) calls to functions that have
519 specialisations, or that may have transformation rules in an importing
522 E.g. {-# INLINE f #-}
525 and suppose that g is strict *and* has specialisations. If we inline
526 g's wrapper, we deny f the chance of getting the specialised version
527 of g when f is inlined at some call site (perhaps in some other
530 It's also important not to inline a worker back into a wrapper.
532 wraper = inline_me (\x -> ...worker... )
533 Normally, the inline_me prevents the worker getting inlined into
534 the wrapper (initially, the worker's only call site!). But,
535 if the wrapper is sure to be called, the strictness analyser will
536 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
537 continuation. That's why the keep_inline predicate returns True for
538 ArgOf continuations. It shouldn't do any harm not to dissolve the
539 inline-me note under these circumstances.
541 Note that the result is that we do very little simplification
544 all xs = foldr (&&) True xs
545 any p = all . map p {-# INLINE any #-}
547 Problem: any won't get deforested, and so if it's exported and the
548 importer doesn't use the inlining, (eg passes it as an arg) then we
549 won't get deforestation at all. We havn't solved this problem yet!
552 preInlineUnconditionally
553 ~~~~~~~~~~~~~~~~~~~~~~~~
554 @preInlineUnconditionally@ examines a bndr to see if it is used just
555 once in a completely safe way, so that it is safe to discard the
556 binding inline its RHS at the (unique) usage site, REGARDLESS of how
557 big the RHS might be. If this is the case we don't simplify the RHS
558 first, but just inline it un-simplified.
560 This is much better than first simplifying a perhaps-huge RHS and then
561 inlining and re-simplifying it. Indeed, it can be at least quadratically
570 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
571 This can happen with cascades of functions too:
578 THE MAIN INVARIANT is this:
580 ---- preInlineUnconditionally invariant -----
581 IF preInlineUnconditionally chooses to inline x = <rhs>
582 THEN doing the inlining should not change the occurrence
583 info for the free vars of <rhs>
584 ----------------------------------------------
586 For example, it's tempting to look at trivial binding like
588 and inline it unconditionally. But suppose x is used many times,
589 but this is the unique occurrence of y. Then inlining x would change
590 y's occurrence info, which breaks the invariant. It matters: y
591 might have a BIG rhs, which will now be dup'd at every occurrenc of x.
594 Evne RHSs labelled InlineMe aren't caught here, because there might be
595 no benefit from inlining at the call site.
597 [Sept 01] Don't unconditionally inline a top-level thing, because that
598 can simply make a static thing into something built dynamically. E.g.
602 [Remember that we treat \s as a one-shot lambda.] No point in
603 inlining x unless there is something interesting about the call site.
605 But watch out: if you aren't careful, some useful foldr/build fusion
606 can be lost (most notably in spectral/hartel/parstof) because the
607 foldr didn't see the build. Doing the dynamic allocation isn't a big
608 deal, in fact, but losing the fusion can be. But the right thing here
609 seems to be to do a callSiteInline based on the fact that there is
610 something interesting about the call site (it's strict). Hmm. That
613 Conclusion: inline top level things gaily until Phase 0 (the last
614 phase), at which point don't.
617 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
618 preInlineUnconditionally env top_lvl bndr rhs
620 | opt_SimplNoPreInlining = False
621 | otherwise = case idOccInfo bndr of
622 IAmDead -> True -- Happens in ((\x.1) v)
623 OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
627 active = case phase of
628 SimplGently -> isAlwaysActive prag
629 SimplPhase n -> isActive n prag
630 prag = idInlinePragma bndr
632 try_once in_lam int_cxt -- There's one textual occurrence
633 | not in_lam = isNotTopLevel top_lvl || early_phase
634 | otherwise = int_cxt && canInlineInLam rhs
636 -- Be very careful before inlining inside a lambda, becuase (a) we must not
637 -- invalidate occurrence information, and (b) we want to avoid pushing a
638 -- single allocation (here) into multiple allocations (inside lambda).
639 -- Inlining a *function* with a single *saturated* call would be ok, mind you.
640 -- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
642 -- is_cheap = exprIsCheap rhs
643 -- ok = is_cheap && int_cxt
645 -- int_cxt The context isn't totally boring
646 -- E.g. let f = \ab.BIG in \y. map f xs
647 -- Don't want to substitute for f, because then we allocate
648 -- its closure every time the \y is called
649 -- But: let f = \ab.BIG in \y. map (f y) xs
650 -- Now we do want to substitute for f, even though it's not
651 -- saturated, because we're going to allocate a closure for
652 -- (f y) every time round the loop anyhow.
654 -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
655 -- so substituting rhs inside a lambda doesn't change the occ info.
656 -- Sadly, not quite the same as exprIsHNF.
657 canInlineInLam (Lit l) = True
658 canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e
659 canInlineInLam (Note _ e) = canInlineInLam e
660 canInlineInLam _ = False
662 early_phase = case phase of
663 SimplPhase 0 -> False
665 -- If we don't have this early_phase test, consider
666 -- x = length [1,2,3]
667 -- The full laziness pass carefully floats all the cons cells to
668 -- top level, and preInlineUnconditionally floats them all back in.
669 -- Result is (a) static allocation replaced by dynamic allocation
670 -- (b) many simplifier iterations because this tickles
671 -- a related problem; only one inlining per pass
673 -- On the other hand, I have seen cases where top-level fusion is
674 -- lost if we don't inline top level thing (e.g. string constants)
675 -- Hence the test for phase zero (which is the phase for all the final
676 -- simplifications). Until phase zero we take no special notice of
677 -- top level things, but then we become more leery about inlining
682 postInlineUnconditionally
683 ~~~~~~~~~~~~~~~~~~~~~~~~~
684 @postInlineUnconditionally@ decides whether to unconditionally inline
685 a thing based on the form of its RHS; in particular if it has a
686 trivial RHS. If so, we can inline and discard the binding altogether.
688 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
689 only have *forward* references Hence, it's safe to discard the binding
691 NOTE: This isn't our last opportunity to inline. We're at the binding
692 site right now, and we'll get another opportunity when we get to the
695 Note that we do this unconditional inlining only for trival RHSs.
696 Don't inline even WHNFs inside lambdas; doing so may simply increase
697 allocation when the function is called. This isn't the last chance; see
700 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
701 Because we don't even want to inline them into the RHS of constructor
702 arguments. See NOTE above
704 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
705 it's best to inline it anyway. We often get a=E; b=a from desugaring,
706 with both a and b marked NOINLINE. But that seems incompatible with
707 our new view that inlining is like a RULE, so I'm sticking to the 'active'
711 postInlineUnconditionally
712 :: SimplEnv -> TopLevelFlag
713 -> InId -- The binder (an OutId would be fine too)
714 -> OccInfo -- From the InId
718 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
720 | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, dont' inline
721 -- because it might be referred to "earlier"
722 | isExportedId bndr = False
723 | exprIsTrivial rhs = True
726 -- The point of examining occ_info here is that for *non-values*
727 -- that occur outside a lambda, the call-site inliner won't have
728 -- a chance (becuase it doesn't know that the thing
729 -- only occurs once). The pre-inliner won't have gotten
730 -- it either, if the thing occurs in more than one branch
731 -- So the main target is things like
734 -- True -> case x of ...
735 -- False -> case x of ...
736 -- I'm not sure how important this is in practice
737 OneOcc in_lam one_br int_cxt -- OneOcc => no code-duplication issue
738 -> smallEnoughToInline unfolding -- Small enough to dup
739 -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
741 -- NB: Do NOT inline arbitrarily big things, even if one_br is True
742 -- Reason: doing so risks exponential behaviour. We simplify a big
743 -- expression, inline it, and simplify it again. But if the
744 -- very same thing happens in the big expression, we get
746 -- PRINCIPLE: when we've already simplified an expression once,
747 -- make sure that we only inline it if it's reasonably small.
749 && ((isNotTopLevel top_lvl && not in_lam) ||
750 -- But outside a lambda, we want to be reasonably aggressive
751 -- about inlining into multiple branches of case
752 -- e.g. let x = <non-value>
753 -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
754 -- Inlining can be a big win if C3 is the hot-spot, even if
755 -- the uses in C1, C2 are not 'interesting'
756 -- An example that gets worse if you add int_cxt here is 'clausify'
758 (isCheapUnfolding unfolding && int_cxt))
759 -- isCheap => acceptable work duplication; in_lam may be true
760 -- int_cxt to prevent us inlining inside a lambda without some
761 -- good reason. See the notes on int_cxt in preInlineUnconditionally
763 IAmDead -> True -- This happens; for example, the case_bndr during case of
764 -- known constructor: case (a,b) of x { (p,q) -> ... }
765 -- Here x isn't mentioned in the RHS, so we don't want to
766 -- create the (dead) let-binding let x = (a,b) in ...
770 -- Here's an example that we don't handle well:
771 -- let f = if b then Left (\x.BIG) else Right (\y.BIG)
772 -- in \y. ....case f of {...} ....
773 -- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
775 -- * We can't preInlineUnconditionally because that woud invalidate
776 -- the occ info for b.
777 -- * We can't postInlineUnconditionally because the RHS is big, and
778 -- that risks exponential behaviour
779 -- * We can't call-site inline, because the rhs is big
783 active = case getMode env of
784 SimplGently -> isAlwaysActive prag
785 SimplPhase n -> isActive n prag
786 prag = idInlinePragma bndr
788 activeInline :: SimplEnv -> OutId -> Bool
790 = case getMode env of
792 -- No inlining at all when doing gentle stuff,
793 -- except for local things that occur once
794 -- The reason is that too little clean-up happens if you
795 -- don't inline use-once things. Also a bit of inlining is *good* for
796 -- full laziness; it can expose constant sub-expressions.
797 -- Example in spectral/mandel/Mandel.hs, where the mandelset
798 -- function gets a useful let-float if you inline windowToViewport
800 -- NB: we used to have a second exception, for data con wrappers.
801 -- On the grounds that we use gentle mode for rule LHSs, and
802 -- they match better when data con wrappers are inlined.
803 -- But that only really applies to the trivial wrappers (like (:)),
804 -- and they are now constructed as Compulsory unfoldings (in MkId)
805 -- so they'll happen anyway.
807 SimplPhase n -> isActive n prag
809 prag = idInlinePragma id
811 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
812 -- Nothing => No rules at all
813 activeRule dflags env
814 | not (dopt Opt_RewriteRules dflags)
815 = Nothing -- Rewriting is off
817 = case getMode env of
818 SimplGently -> Just isAlwaysActive
819 -- Used to be Nothing (no rules in gentle mode)
820 -- Main motivation for changing is that I wanted
821 -- lift String ===> ...
822 -- to work in Template Haskell when simplifying
823 -- splices, so we get simpler code for literal strings
824 SimplPhase n -> Just (isActive n)
828 %************************************************************************
832 %************************************************************************
835 mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr
836 -- mkLam tries three things
837 -- a) eta reduction, if that gives a trivial expression
838 -- b) eta expansion [only if there are some value lambdas]
843 = do { dflags <- getDOptsSmpl
844 ; mkLam' dflags bndrs body }
846 mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
847 mkLam' dflags bndrs (Cast body@(Lam _ _) co)
848 -- Note [Casts and lambdas]
849 = do { lam <- mkLam' dflags (bndrs ++ bndrs') body'
850 ; return (mkCoerce (mkPiTypes bndrs co) lam) }
852 (bndrs',body') = collectBinders body
854 mkLam' dflags bndrs body
855 | dopt Opt_DoEtaReduction dflags,
856 Just etad_lam <- tryEtaReduce bndrs body
857 = do { tick (EtaReduction (head bndrs))
860 | dopt Opt_DoLambdaEtaExpansion dflags,
861 any isRuntimeVar bndrs
862 = do { body' <- tryEtaExpansion dflags body
863 ; return (mkLams bndrs body') }
866 = returnSmpl (mkLams bndrs body)
869 Note [Casts and lambdas]
870 ~~~~~~~~~~~~~~~~~~~~~~~~
872 (\x. (\y. e) `cast` g1) `cast` g2
873 There is a danger here that the two lambdas look separated, and the
874 full laziness pass might float an expression to between the two.
876 So this equation in mkLam' floats the g1 out, thus:
877 (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1)
880 In general, this floats casts outside lambdas, where (I hope) they might meet
881 and cancel with some other cast.
884 -- c) floating lets out through big lambdas
885 -- [only if all tyvar lambdas, and only if this lambda
886 -- is the RHS of a let]
888 {- Sept 01: I'm experimenting with getting the
889 full laziness pass to float out past big lambdsa
890 | all isTyVar bndrs, -- Only for big lambdas
891 contIsRhs cont -- Only try the rhs type-lambda floating
892 -- if this is indeed a right-hand side; otherwise
893 -- we end up floating the thing out, only for float-in
894 -- to float it right back in again!
895 = tryRhsTyLam env bndrs body `thenSmpl` \ (floats, body') ->
896 returnSmpl (floats, mkLams bndrs body')
900 %************************************************************************
902 \subsection{Eta expansion and reduction}
904 %************************************************************************
906 We try for eta reduction here, but *only* if we get all the
907 way to an exprIsTrivial expression.
908 We don't want to remove extra lambdas unless we are going
909 to avoid allocating this thing altogether
912 tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
913 tryEtaReduce bndrs body
914 -- We don't use CoreUtils.etaReduce, because we can be more
916 -- (a) we already have the binders
917 -- (b) we can do the triviality test before computing the free vars
918 = go (reverse bndrs) body
920 go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
921 go [] fun | ok_fun fun = Just fun -- Success!
922 go _ _ = Nothing -- Failure!
924 ok_fun fun = exprIsTrivial fun
925 && not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
926 && (exprIsHNF fun || all ok_lam bndrs)
927 ok_lam v = isTyVar v || isDictId v
928 -- The exprIsHNF is because eta reduction is not
929 -- valid in general: \x. bot /= bot
930 -- So we need to be sure that the "fun" is a value.
932 -- However, we always want to reduce (/\a -> f a) to f
933 -- This came up in a RULE: foldr (build (/\a -> g a))
934 -- did not match foldr (build (/\b -> ...something complex...))
935 -- The type checker can insert these eta-expanded versions,
936 -- with both type and dictionary lambdas; hence the slightly
939 ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
943 Try eta expansion for RHSs
946 f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
949 where (in both cases)
951 * The xi can include type variables
953 * The yi are all value variables
955 * N is a NORMAL FORM (i.e. no redexes anywhere)
956 wanting a suitable number of extra args.
958 We may have to sandwich some coerces between the lambdas
959 to make the types work. exprEtaExpandArity looks through coerces
960 when computing arity; and etaExpand adds the coerces as necessary when
961 actually computing the expansion.
964 tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
965 -- There is at least one runtime binder in the binders
966 tryEtaExpansion dflags body
967 = getUniquesSmpl `thenSmpl` \ us ->
968 returnSmpl (etaExpand fun_arity us body (exprType body))
970 fun_arity = exprEtaExpandArity dflags body
974 %************************************************************************
976 \subsection{Floating lets out of big lambdas}
978 %************************************************************************
980 Note [Floating and type abstraction]
981 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
984 We'd like to float this to
987 x = /\a. C (y1 a) (y2 a)
988 for the usual reasons: we want to inline x rather vigorously.
990 You may think that this kind of thing is rare. But in some programs it is
991 common. For example, if you do closure conversion you might get:
993 data a :-> b = forall e. (e -> a -> b) :$ e
995 f_cc :: forall a. a :-> a
996 f_cc = /\a. (\e. id a) :$ ()
998 Now we really want to inline that f_cc thing so that the
999 construction of the closure goes away.
1001 So I have elaborated simplLazyBind to understand right-hand sides that look
1005 and treat them specially. The real work is done in SimplUtils.abstractFloats,
1006 but there is quite a bit of plumbing in simplLazyBind as well.
1008 The same transformation is good when there are lets in the body:
1010 /\abc -> let(rec) x = e in b
1012 let(rec) x' = /\abc -> let x = x' a b c in e
1014 /\abc -> let x = x' a b c in b
1016 This is good because it can turn things like:
1018 let f = /\a -> letrec g = ... g ... in g
1020 letrec g' = /\a -> ... g' a ...
1022 let f = /\ a -> g' a
1024 which is better. In effect, it means that big lambdas don't impede
1027 This optimisation is CRUCIAL in eliminating the junk introduced by
1028 desugaring mutually recursive definitions. Don't eliminate it lightly!
1030 [May 1999] If we do this transformation *regardless* then we can
1031 end up with some pretty silly stuff. For example,
1034 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
1039 st = /\s -> ...[y1 s/x1, y2 s/x2]
1042 Unless the "..." is a WHNF there is really no point in doing this.
1043 Indeed it can make things worse. Suppose x1 is used strictly,
1046 x1* = case f y of { (a,b) -> e }
1048 If we abstract this wrt the tyvar we then can't do the case inline
1049 as we would normally do.
1051 That's why the whole transformation is part of the same process that
1052 floats let-bindings and constructor arguments out of RHSs. In particular,
1053 it is guarded by the doFloatFromRhs call in simplLazyBind.
1057 abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
1058 abstractFloats main_tvs body_env body
1059 = ASSERT( notNull body_floats )
1060 do { (subst, float_binds) <- mapAccumLSmpl abstract empty_subst body_floats
1061 ; return (float_binds, CoreSubst.substExpr subst body) }
1063 main_tv_set = mkVarSet main_tvs
1064 body_floats = getFloats body_env
1065 empty_subst = CoreSubst.mkEmptySubst (seInScope body_env)
1067 abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
1068 abstract subst (NonRec id rhs)
1069 = do { (poly_id, poly_app) <- mk_poly tvs_here id
1070 ; let poly_rhs = mkLams tvs_here rhs'
1071 subst' = CoreSubst.extendIdSubst subst id poly_app
1072 ; return (subst', (NonRec poly_id poly_rhs)) }
1074 rhs' = CoreSubst.substExpr subst rhs
1075 tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions]
1077 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
1079 -- Abstract only over the type variables free in the rhs
1080 -- wrt which the new binding is abstracted. But the naive
1081 -- approach of abstract wrt the tyvars free in the Id's type
1083 -- /\ a b -> let t :: (a,b) = (e1, e2)
1086 -- Here, b isn't free in x's type, but we must nevertheless
1087 -- abstract wrt b as well, because t's type mentions b.
1088 -- Since t is floated too, we'd end up with the bogus:
1089 -- poly_t = /\ a b -> (e1, e2)
1090 -- poly_x = /\ a -> fst (poly_t a *b*)
1091 -- So for now we adopt the even more naive approach of
1092 -- abstracting wrt *all* the tyvars. We'll see if that
1093 -- gives rise to problems. SLPJ June 98
1095 abstract subst (Rec prs)
1096 = do { (poly_ids, poly_apps) <- mapAndUnzipSmpl (mk_poly tvs_here) ids
1097 ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
1098 poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
1099 ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
1101 (ids,rhss) = unzip prs
1102 -- For a recursive group, it's a bit of a pain to work out the minimal
1103 -- set of tyvars over which to abstract:
1104 -- /\ a b c. let x = ...a... in
1105 -- letrec { p = ...x...q...
1106 -- q = .....p...b... } in
1108 -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
1109 -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
1110 -- Since it's a pain, we just use the whole set, which is always safe
1112 -- If you ever want to be more selective, remember this bizarre case too:
1114 -- Here, we must abstract 'x' over 'a'.
1117 mk_poly tvs_here var
1118 = do { uniq <- getUniqueSmpl
1119 ; let poly_name = setNameUnique (idName var) uniq -- Keep same name
1120 poly_ty = mkForAllTys tvs_here (idType var) -- But new type of course
1121 poly_id = mkLocalId poly_name poly_ty
1122 ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
1123 -- In the olden days, it was crucial to copy the occInfo of the original var,
1124 -- because we were looking at occurrence-analysed but as yet unsimplified code!
1125 -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking
1126 -- at already simplified code, so it doesn't matter
1128 -- It's even right to retain single-occurrence or dead-var info:
1129 -- Suppose we started with /\a -> let x = E in B
1130 -- where x occurs once in B. Then we transform to:
1131 -- let x' = /\a -> E in /\a -> let x* = x' a in B
1132 -- where x* has an INLINE prag on it. Now, once x* is inlined,
1133 -- the occurrences of x' will be just the occurrences originally
1137 Note [Abstract over coercions]
1138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1139 If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
1140 type variable a. Rather than sort this mess out, we simply bale out and abstract
1141 wrt all the type variables if any of them are coercion variables.
1144 Historical note: if you use let-bindings instead of a substitution, beware of this:
1146 -- Suppose we start with:
1148 -- x = /\ a -> let g = G in E
1150 -- Then we'll float to get
1152 -- x = let poly_g = /\ a -> G
1153 -- in /\ a -> let g = poly_g a in E
1155 -- But now the occurrence analyser will see just one occurrence
1156 -- of poly_g, not inside a lambda, so the simplifier will
1157 -- PreInlineUnconditionally poly_g back into g! Badk to square 1!
1158 -- (I used to think that the "don't inline lone occurrences" stuff
1159 -- would stop this happening, but since it's the *only* occurrence,
1160 -- PreInlineUnconditionally kicks in first!)
1162 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
1163 -- to appear many times. (NB: mkInlineMe eliminates
1164 -- such notes on trivial RHSs, so do it manually.)
1166 %************************************************************************
1170 %************************************************************************
1172 prepareAlts tries these things:
1174 1. If several alternatives are identical, merge them into
1175 a single DEFAULT alternative. I've occasionally seen this
1176 making a big difference:
1178 case e of =====> case e of
1179 C _ -> f x D v -> ....v....
1180 D v -> ....v.... DEFAULT -> f x
1183 The point is that we merge common RHSs, at least for the DEFAULT case.
1184 [One could do something more elaborate but I've never seen it needed.]
1185 To avoid an expensive test, we just merge branches equal to the *first*
1186 alternative; this picks up the common cases
1187 a) all branches equal
1188 b) some branches equal to the DEFAULT (which occurs first)
1191 case e of b { ==> case e of b {
1192 p1 -> rhs1 p1 -> rhs1
1194 pm -> rhsm pm -> rhsm
1195 _ -> case b of b' { pn -> let b'=b in rhsn
1197 ... po -> let b'=b in rhso
1198 po -> rhso _ -> let b'=b in rhsd
1202 which merges two cases in one case when -- the default alternative of
1203 the outer case scrutises the same variable as the outer case This
1204 transformation is called Case Merging. It avoids that the same
1205 variable is scrutinised multiple times.
1208 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
1214 where @is@ was something like
1216 p `is` n = p /= (-1) && p == n
1218 This gave rise to a horrible sequence of cases
1225 and similarly in cascade for all the join points!
1228 ~~~~~~~~~~~~~~~~~~~~
1229 We do this *here*, looking at un-simplified alternatives, because we
1230 have to check that r doesn't mention the variables bound by the
1231 pattern in each alternative, so the binder-info is rather useful.
1234 prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
1235 prepareAlts scrut case_bndr' alts
1236 = do { dflags <- getDOptsSmpl
1237 ; alts <- combineIdenticalAlts case_bndr' alts
1239 ; let (alts_wo_default, maybe_deflt) = findDefault alts
1240 alt_cons = [con | (con,_,_) <- alts_wo_default]
1241 imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
1242 -- "imposs_deflt_cons" are handled
1243 -- EITHER by the context,
1244 -- OR by a non-DEFAULT branch in this case expression.
1246 ; default_alts <- prepareDefault dflags scrut case_bndr' mb_tc_app
1247 imposs_deflt_cons maybe_deflt
1249 ; let trimmed_alts = filterOut impossible_alt alts_wo_default
1250 merged_alts = mergeAlts trimmed_alts default_alts
1251 -- We need the mergeAlts in case the new default_alt
1252 -- has turned into a constructor alternative.
1253 -- The merge keeps the inner DEFAULT at the front, if there is one
1254 -- and interleaves the alternatives in the right order
1256 ; return (imposs_deflt_cons, merged_alts) }
1258 mb_tc_app = splitTyConApp_maybe (idType case_bndr')
1259 Just (_, inst_tys) = mb_tc_app
1261 imposs_cons = case scrut of
1262 Var v -> otherCons (idUnfolding v)
1265 impossible_alt :: CoreAlt -> Bool
1266 impossible_alt (con, _, _) | con `elem` imposs_cons = True
1267 impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con
1268 impossible_alt alt = False
1271 --------------------------------------------------
1272 -- 1. Merge identical branches
1273 --------------------------------------------------
1274 combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
1276 combineIdenticalAlts case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
1277 | all isDeadBinder bndrs1, -- Remember the default
1278 length filtered_alts < length con_alts -- alternative comes first
1279 -- Also Note [Dead binders]
1280 = do { tick (AltMerge case_bndr)
1281 ; return ((DEFAULT, [], rhs1) : filtered_alts) }
1283 filtered_alts = filter keep con_alts
1284 keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
1286 combineIdenticalAlts case_bndr alts = return alts
1288 -------------------------------------------------------------------------
1289 -- Prepare the default alternative
1290 -------------------------------------------------------------------------
1291 prepareDefault :: DynFlags
1292 -> OutExpr -- Scrutinee
1293 -> OutId -- Case binder; need just for its type. Note that as an
1294 -- OutId, it has maximum information; this is important.
1295 -- Test simpl013 is an example
1296 -> Maybe (TyCon, [Type]) -- Type of scrutinee, decomposed
1297 -> [AltCon] -- These cons can't happen when matching the default
1298 -> Maybe InExpr -- Rhs
1299 -> SimplM [InAlt] -- Still unsimplified
1300 -- We use a list because it's what mergeAlts expects,
1301 -- And becuase case-merging can cause many to show up
1303 ------- Merge nested cases ----------
1304 prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs)
1305 | dopt Opt_CaseMerge dflags
1306 , Case (Var scrut_var) inner_bndr _ inner_alts <- deflt_rhs
1307 , scruting_same_var scrut_var
1308 = do { tick (CaseMerge outer_bndr)
1310 ; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
1311 ; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts,
1312 not (con `elem` imposs_cons) ]
1313 -- NB: filter out any imposs_cons. Example:
1316 -- DEFAULT -> case x of
1319 -- When we merge, we must ensure that e1 takes
1320 -- precedence over e2 as the value for A!
1322 -- Warning: don't call prepareAlts recursively!
1323 -- Firstly, there's no point, because inner alts have already had
1324 -- mkCase applied to them, so they won't have a case in their default
1325 -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
1326 -- in munge_rhs may put a case into the DEFAULT branch!
1328 -- We are scrutinising the same variable if it's
1329 -- the outer case-binder, or if the outer case scrutinises a variable
1330 -- (and it's the same). Testing both allows us not to replace the
1331 -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
1332 scruting_same_var = case scrut of
1333 Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
1334 other -> \ v -> v == outer_bndr
1336 --------- Fill in known constructor -----------
1337 prepareDefault dflags scrut case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
1338 | -- This branch handles the case where we are
1339 -- scrutinisng an algebraic data type
1340 isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples.
1341 , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval:
1342 -- case x of { DEFAULT -> e }
1343 -- and we don't want to fill in a default for them!
1344 , Just all_cons <- tyConDataCons_maybe tycon
1345 , not (null all_cons) -- This is a tricky corner case. If the data type has no constructors,
1346 -- which GHC allows, then the case expression will have at most a default
1347 -- alternative. We don't want to eliminate that alternative, because the
1348 -- invariant is that there's always one alternative. It's more convenient
1350 -- case x of { DEFAULT -> e }
1351 -- as it is, rather than transform it to
1352 -- error "case cant match"
1353 -- which would be quite legitmate. But it's a really obscure corner, and
1354 -- not worth wasting code on.
1355 , let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type
1356 impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
1357 = case filterOut impossible all_cons of
1358 [] -> return [] -- Eliminate the default alternative
1359 -- altogether if it can't match
1361 [con] -> -- It matches exactly one constructor, so fill it in
1362 do { tick (FillInCaseDefault case_bndr)
1363 ; us <- getUniquesSmpl
1364 ; let (ex_tvs, co_tvs, arg_ids) =
1365 dataConRepInstPat us con inst_tys
1366 ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] }
1368 two_or_more -> return [(DEFAULT, [], deflt_rhs)]
1370 --------- Catch-all cases -----------
1371 prepareDefault dflags scrut case_bndr bndr_ty imposs_cons (Just deflt_rhs)
1372 = return [(DEFAULT, [], deflt_rhs)]
1374 prepareDefault dflags scrut case_bndr bndr_ty imposs_cons Nothing
1375 = return [] -- No default branch
1380 =================================================================================
1382 mkCase tries these things
1384 1. Eliminate the case altogether if possible
1392 and similar friends.
1396 mkCase :: OutExpr -> OutId -> OutType
1397 -> [OutAlt] -- Increasing order
1400 --------------------------------------------------
1401 -- 1. Check for empty alternatives
1402 --------------------------------------------------
1404 -- This isn't strictly an error. It's possible that the simplifer might "see"
1405 -- that an inner case has no accessible alternatives before it "sees" that the
1406 -- entire branch of an outer case is inaccessible. So we simply
1407 -- put an error case here insteadd
1408 mkCase scrut case_bndr ty []
1409 = pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
1410 return (mkApps (Var rUNTIME_ERROR_ID)
1411 [Type ty, Lit (mkStringLit "Impossible alternative")])
1414 --------------------------------------------------
1416 --------------------------------------------------
1418 mkCase scrut case_bndr ty alts -- Identity case
1419 | all identity_alt alts
1420 = tick (CaseIdentity case_bndr) `thenSmpl_`
1421 returnSmpl (re_cast scrut)
1423 identity_alt (con, args, rhs) = check_eq con args (de_cast rhs)
1425 check_eq DEFAULT _ (Var v) = v == case_bndr
1426 check_eq (LitAlt lit') _ (Lit lit) = lit == lit'
1427 check_eq (DataAlt con) args rhs = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
1428 || rhs `cheapEqExpr` Var case_bndr
1429 check_eq con args rhs = False
1431 arg_tys = map Type (tyConAppArgs (idType case_bndr))
1434 -- case e of x { _ -> x `cast` c }
1435 -- And we definitely want to eliminate this case, to give
1437 -- So we throw away the cast from the RHS, and reconstruct
1438 -- it at the other end. All the RHS casts must be the same
1439 -- if (all identity_alt alts) holds.
1441 -- Don't worry about nested casts, because the simplifier combines them
1442 de_cast (Cast e _) = e
1445 re_cast scrut = case head alts of
1446 (_,_,Cast _ co) -> Cast scrut co
1451 --------------------------------------------------
1453 --------------------------------------------------
1454 mkCase scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
1458 When adding auxiliary bindings for the case binder, it's worth checking if
1459 its dead, because it often is, and occasionally these mkCase transformations
1460 cascade rather nicely.
1463 bindCaseBndr bndr rhs body
1464 | isDeadBinder bndr = body
1465 | otherwise = bindNonRec bndr rhs body