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 hiding( substTy )
55 import Unify ( dataConCannotMatch )
64 %************************************************************************
68 %************************************************************************
70 A SimplCont allows the simplifier to traverse the expression in a
71 zipper-like fashion. The SimplCont represents the rest of the expression,
72 "above" the point of interest.
74 You can also think of a SimplCont as an "evaluation context", using
75 that term in the way it is used for operational semantics. This is the
76 way I usually think of it, For example you'll often see a syntax for
77 evaluation context looking like
78 C ::= [] | C e | case C of alts | C `cast` co
79 That's the kind of thing we are doing here, and I use that syntax in
84 * A SimplCont describes a *strict* context (just like
85 evaluation contexts do). E.g. Just [] is not a SimplCont
87 * A SimplCont describes a context that *does not* bind
88 any variables. E.g. \x. [] is not a SimplCont
92 = Stop -- An empty context, or hole, []
93 OutType -- Type of the result
95 Bool -- True <=> There is something interesting about
96 -- the context, and hence the inliner
97 -- should be a bit keener (see interestingCallContext)
99 -- This is an argument of a function that has RULES
100 -- Inlining the call might allow the rule to fire
102 | CoerceIt -- C `cast` co
103 OutCoercion -- The coercion simplified
108 InExpr SimplEnv -- The argument and its static env
111 | Select -- case C of alts
113 InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
116 -- The two strict forms have no DupFlag, because we never duplicate them
117 | StrictBind -- (\x* \xs. e) C
118 InId [InBndr] -- let x* = [] in e
119 InExpr SimplEnv -- is a special case
123 OutExpr OutType -- e and its type
124 (Bool,[Bool]) -- Whether the function at the head of e has rules,
125 SimplCont -- plus strictness flags for further args
127 data LetRhsFlag = AnArg -- It's just an argument not a let RHS
128 | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas)
130 instance Outputable LetRhsFlag where
131 ppr AnArg = ptext SLIT("arg")
132 ppr AnRhs = ptext SLIT("rhs")
134 instance Outputable SimplCont where
135 ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
136 ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg)
137 {- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
138 ppr (StrictBind b _ _ _ cont) = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont
139 ppr (StrictArg f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
140 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
141 (nest 4 (ppr alts)) $$ ppr cont
142 ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
144 data DupFlag = OkToDup | NoDup
146 instance Outputable DupFlag where
147 ppr OkToDup = ptext SLIT("ok")
148 ppr NoDup = ptext SLIT("nodup")
153 mkBoringStop :: OutType -> SimplCont
154 mkBoringStop ty = Stop ty AnArg False
156 mkLazyArgStop :: OutType -> Bool -> SimplCont
157 mkLazyArgStop ty has_rules = Stop ty AnArg has_rules
159 mkRhsStop :: OutType -> SimplCont
160 mkRhsStop ty = Stop ty AnRhs False
163 contIsRhsOrArg (Stop {}) = True
164 contIsRhsOrArg (StrictBind {}) = True
165 contIsRhsOrArg (StrictArg {}) = True
166 contIsRhsOrArg other = False
169 contIsDupable :: SimplCont -> Bool
170 contIsDupable (Stop {}) = True
171 contIsDupable (ApplyTo OkToDup _ _ _) = True
172 contIsDupable (Select OkToDup _ _ _ _) = True
173 contIsDupable (CoerceIt _ cont) = contIsDupable cont
174 contIsDupable other = False
177 contIsTrivial :: SimplCont -> Bool
178 contIsTrivial (Stop {}) = True
179 contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
180 contIsTrivial (CoerceIt _ cont) = contIsTrivial cont
181 contIsTrivial other = False
184 contResultType :: SimplCont -> OutType
185 contResultType (Stop to_ty _ _) = to_ty
186 contResultType (StrictArg _ _ _ cont) = contResultType cont
187 contResultType (StrictBind _ _ _ _ cont) = contResultType cont
188 contResultType (ApplyTo _ _ _ cont) = contResultType cont
189 contResultType (CoerceIt _ cont) = contResultType cont
190 contResultType (Select _ _ _ _ cont) = contResultType cont
193 countValArgs :: SimplCont -> Int
194 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
195 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
196 countValArgs other = 0
198 countArgs :: SimplCont -> Int
199 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
202 contArgs :: SimplCont -> ([OutExpr], SimplCont)
203 -- Uses substitution to turn each arg into an OutExpr
204 contArgs cont = go [] cont
206 go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
207 go args cont = (reverse args, cont)
209 dropArgs :: Int -> SimplCont -> SimplCont
210 dropArgs 0 cont = cont
211 dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
212 dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other)
215 splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont)
216 -- Returns Nothing if the continuation should dissolve an InlineMe Note
217 -- Return Just (c1,c2) otherwise,
218 -- where c1 is the continuation to put inside the InlineMe
221 -- Example: (__inline_me__ (/\a. e)) ty
222 -- Here we want to do the beta-redex without dissolving the InlineMe
223 -- See test simpl017 (and Trac #1627) for a good example of why this is important
225 splitInlineCont (ApplyTo dup (Type ty) se c)
226 | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
227 splitInlineCont cont@(Stop ty _ _) = Just (mkBoringStop ty, cont)
228 splitInlineCont cont@(StrictBind bndr _ _ se _) = Just (mkBoringStop (substTy se (idType bndr)), cont)
229 splitInlineCont cont@(StrictArg _ fun_ty _ _) = Just (mkBoringStop (funArgTy fun_ty), cont)
230 splitInlineCont other = Nothing
231 -- NB: the calculation of the type for mkBoringStop is an annoying
232 -- duplication of the same calucation in mkDupableCont
237 interestingArg :: OutExpr -> Bool
238 -- An argument is interesting if it has *some* structure
239 -- We are here trying to avoid unfolding a function that
240 -- is applied only to variables that have no unfolding
241 -- (i.e. they are probably lambda bound): f x y z
242 -- There is little point in inlining f here.
243 interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
244 -- Was: isValueUnfolding (idUnfolding v')
245 -- But that seems over-pessimistic
247 -- This accounts for an argument like
248 -- () or [], which is definitely interesting
249 interestingArg (Type _) = False
250 interestingArg (App fn (Type _)) = interestingArg fn
251 interestingArg (Note _ a) = interestingArg a
253 -- Idea (from Sam B); I'm not sure if it's a good idea, so commented out for now
254 -- interestingArg expr | isUnLiftedType (exprType expr)
255 -- -- Unlifted args are only ever interesting if we know what they are
260 interestingArg other = True
261 -- Consider let x = 3 in f x
262 -- The substitution will contain (x -> ContEx 3), and we want to
263 -- to say that x is an interesting argument.
264 -- But consider also (\x. f x y) y
265 -- The substitution will contain (x -> ContEx y), and we want to say
266 -- that x is not interesting (assuming y has no unfolding)
270 Comment about interestingCallContext
271 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
272 We want to avoid inlining an expression where there can't possibly be
273 any gain, such as in an argument position. Hence, if the continuation
274 is interesting (eg. a case scrutinee, application etc.) then we
275 inline, otherwise we don't.
277 Previously some_benefit used to return True only if the variable was
278 applied to some value arguments. This didn't work:
280 let x = _coerce_ (T Int) Int (I# 3) in
281 case _coerce_ Int (T Int) x of
284 we want to inline x, but can't see that it's a constructor in a case
285 scrutinee position, and some_benefit is False.
289 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
291 .... case dMonadST _@_ x0 of (a,b,c) -> ....
293 we'd really like to inline dMonadST here, but we *don't* want to
294 inline if the case expression is just
296 case x of y { DEFAULT -> ... }
298 since we can just eliminate this case instead (x is in WHNF). Similar
299 applies when x is bound to a lambda expression. Hence
300 contIsInteresting looks for case expressions with just a single
305 interestingCallContext :: SimplCont -> CallContInfo
306 interestingCallContext cont
309 interesting (Select _ bndr _ _ _)
310 | isDeadBinder bndr = CaseCont
311 | otherwise = InterestingCont
313 interesting (ApplyTo {}) = InterestingCont
314 -- Can happen if we have (coerce t (f x)) y
315 -- Perhaps True is a bit over-keen, but I've
316 -- seen (coerce f) x, where f has an INLINE prag,
317 -- So we have to give some motivation for inlining it
318 interesting (StrictArg {}) = InterestingCont
319 interesting (StrictBind {}) = InterestingCont
320 interesting (Stop ty _ yes) = if yes then InterestingCont else BoringCont
321 interesting (CoerceIt _ cont) = interesting cont
322 -- If this call is the arg of a strict function, the context
323 -- is a bit interesting. If we inline here, we may get useful
324 -- evaluation information to avoid repeated evals: e.g.
326 -- Here the contIsInteresting makes the '*' keener to inline,
327 -- which in turn exposes a constructor which makes the '+' inline.
328 -- Assuming that +,* aren't small enough to inline regardless.
330 -- It's also very important to inline in a strict context for things
333 -- Here, the context of (f x) is strict, and if f's unfolding is
334 -- a build it's *great* to inline it here. So we must ensure that
335 -- the context for (f x) is not totally uninteresting.
340 -> Int -- Number of value args
341 -> SimplCont -- Context of the cal
342 -> (Bool, [Bool]) -- Arg info
343 -- The arg info consists of
344 -- * A Bool indicating if the function has rules (recursively)
345 -- * A [Bool] indicating strictness for each arg
346 -- The [Bool] is usually infinite, but if it is finite it
347 -- guarantees that the function diverges after being given
348 -- that number of args
350 mkArgInfo fun n_val_args call_cont
351 = (interestingArgContext fun call_cont, fun_stricts)
353 vanilla_stricts, fun_stricts :: [Bool]
354 vanilla_stricts = repeat False
357 = case splitStrictSig (idNewStrictness fun) of
358 (demands, result_info)
359 | not (demands `lengthExceeds` n_val_args)
360 -> -- Enough args, use the strictness given.
361 -- For bottoming functions we used to pretend that the arg
362 -- is lazy, so that we don't treat the arg as an
363 -- interesting context. This avoids substituting
364 -- top-level bindings for (say) strings into
365 -- calls to error. But now we are more careful about
366 -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
367 if isBotRes result_info then
368 map isStrictDmd demands -- Finite => result is bottom
370 map isStrictDmd demands ++ vanilla_stricts
372 other -> vanilla_stricts -- Not enough args, or no strictness
374 interestingArgContext :: Id -> SimplCont -> Bool
375 -- If the argument has form (f x y), where x,y are boring,
376 -- and f is marked INLINE, then we don't want to inline f.
377 -- But if the context of the argument is
379 -- where g has rules, then we *do* want to inline f, in case it
380 -- exposes a rule that might fire. Similarly, if the context is
382 -- where h has rules, then we do want to inline f; hence the
383 -- call_cont argument to interestingArgContext
385 -- The interesting_arg_ctxt flag makes this happen; if it's
386 -- set, the inliner gets just enough keener to inline f
387 -- regardless of how boring f's arguments are, if it's marked INLINE
389 -- The alternative would be to *always* inline an INLINE function,
390 -- regardless of how boring its context is; but that seems overkill
391 -- For example, it'd mean that wrapper functions were always inlined
392 interestingArgContext fn call_cont
393 = idHasRules fn || go call_cont
395 go (Select {}) = False
396 go (ApplyTo {}) = False
397 go (StrictArg {}) = True
398 go (StrictBind {}) = False -- ??
399 go (CoerceIt _ c) = go c
400 go (Stop _ _ interesting) = interesting
405 %************************************************************************
407 \subsection{Decisions about inlining}
409 %************************************************************************
411 Inlining is controlled partly by the SimplifierMode switch. This has two
414 SimplGently (a) Simplifying before specialiser/full laziness
415 (b) Simplifiying inside INLINE pragma
416 (c) Simplifying the LHS of a rule
417 (d) Simplifying a GHCi expression or Template
420 SimplPhase n Used at all other times
422 The key thing about SimplGently is that it does no call-site inlining.
423 Before full laziness we must be careful not to inline wrappers,
424 because doing so inhibits floating
425 e.g. ...(case f x of ...)...
426 ==> ...(case (case x of I# x# -> fw x#) of ...)...
427 ==> ...(case x of I# x# -> case fw x# of ...)...
428 and now the redex (f x) isn't floatable any more.
430 The no-inlining thing is also important for Template Haskell. You might be
431 compiling in one-shot mode with -O2; but when TH compiles a splice before
432 running it, we don't want to use -O2. Indeed, we don't want to inline
433 anything, because the byte-code interpreter might get confused about
434 unboxed tuples and suchlike.
438 SimplGently is also used as the mode to simplify inside an InlineMe note.
441 inlineMode :: SimplifierMode
442 inlineMode = SimplGently
445 It really is important to switch off inlinings inside such
446 expressions. Consider the following example
452 in ...g...g...g...g...g...
454 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
455 and thence copied multiple times when g is inlined.
458 This function may be inlinined in other modules, so we
459 don't want to remove (by inlining) calls to functions that have
460 specialisations, or that may have transformation rules in an importing
463 E.g. {-# INLINE f #-}
466 and suppose that g is strict *and* has specialisations. If we inline
467 g's wrapper, we deny f the chance of getting the specialised version
468 of g when f is inlined at some call site (perhaps in some other
471 It's also important not to inline a worker back into a wrapper.
473 wraper = inline_me (\x -> ...worker... )
474 Normally, the inline_me prevents the worker getting inlined into
475 the wrapper (initially, the worker's only call site!). But,
476 if the wrapper is sure to be called, the strictness analyser will
477 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
478 continuation. That's why the keep_inline predicate returns True for
479 ArgOf continuations. It shouldn't do any harm not to dissolve the
480 inline-me note under these circumstances.
482 Note that the result is that we do very little simplification
485 all xs = foldr (&&) True xs
486 any p = all . map p {-# INLINE any #-}
488 Problem: any won't get deforested, and so if it's exported and the
489 importer doesn't use the inlining, (eg passes it as an arg) then we
490 won't get deforestation at all. We havn't solved this problem yet!
493 preInlineUnconditionally
494 ~~~~~~~~~~~~~~~~~~~~~~~~
495 @preInlineUnconditionally@ examines a bndr to see if it is used just
496 once in a completely safe way, so that it is safe to discard the
497 binding inline its RHS at the (unique) usage site, REGARDLESS of how
498 big the RHS might be. If this is the case we don't simplify the RHS
499 first, but just inline it un-simplified.
501 This is much better than first simplifying a perhaps-huge RHS and then
502 inlining and re-simplifying it. Indeed, it can be at least quadratically
511 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
512 This can happen with cascades of functions too:
519 THE MAIN INVARIANT is this:
521 ---- preInlineUnconditionally invariant -----
522 IF preInlineUnconditionally chooses to inline x = <rhs>
523 THEN doing the inlining should not change the occurrence
524 info for the free vars of <rhs>
525 ----------------------------------------------
527 For example, it's tempting to look at trivial binding like
529 and inline it unconditionally. But suppose x is used many times,
530 but this is the unique occurrence of y. Then inlining x would change
531 y's occurrence info, which breaks the invariant. It matters: y
532 might have a BIG rhs, which will now be dup'd at every occurrenc of x.
535 Even RHSs labelled InlineMe aren't caught here, because there might be
536 no benefit from inlining at the call site.
538 [Sept 01] Don't unconditionally inline a top-level thing, because that
539 can simply make a static thing into something built dynamically. E.g.
543 [Remember that we treat \s as a one-shot lambda.] No point in
544 inlining x unless there is something interesting about the call site.
546 But watch out: if you aren't careful, some useful foldr/build fusion
547 can be lost (most notably in spectral/hartel/parstof) because the
548 foldr didn't see the build. Doing the dynamic allocation isn't a big
549 deal, in fact, but losing the fusion can be. But the right thing here
550 seems to be to do a callSiteInline based on the fact that there is
551 something interesting about the call site (it's strict). Hmm. That
554 Conclusion: inline top level things gaily until Phase 0 (the last
555 phase), at which point don't.
558 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
559 preInlineUnconditionally env top_lvl bndr rhs
561 | opt_SimplNoPreInlining = False
562 | otherwise = case idOccInfo bndr of
563 IAmDead -> True -- Happens in ((\x.1) v)
564 OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
568 active = case phase of
569 SimplGently -> isAlwaysActive prag
570 SimplPhase n -> isActive n prag
571 prag = idInlinePragma bndr
573 try_once in_lam int_cxt -- There's one textual occurrence
574 | not in_lam = isNotTopLevel top_lvl || early_phase
575 | otherwise = int_cxt && canInlineInLam rhs
577 -- Be very careful before inlining inside a lambda, becuase (a) we must not
578 -- invalidate occurrence information, and (b) we want to avoid pushing a
579 -- single allocation (here) into multiple allocations (inside lambda).
580 -- Inlining a *function* with a single *saturated* call would be ok, mind you.
581 -- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
583 -- is_cheap = exprIsCheap rhs
584 -- ok = is_cheap && int_cxt
586 -- int_cxt The context isn't totally boring
587 -- E.g. let f = \ab.BIG in \y. map f xs
588 -- Don't want to substitute for f, because then we allocate
589 -- its closure every time the \y is called
590 -- But: let f = \ab.BIG in \y. map (f y) xs
591 -- Now we do want to substitute for f, even though it's not
592 -- saturated, because we're going to allocate a closure for
593 -- (f y) every time round the loop anyhow.
595 -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
596 -- so substituting rhs inside a lambda doesn't change the occ info.
597 -- Sadly, not quite the same as exprIsHNF.
598 canInlineInLam (Lit l) = True
599 canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e
600 canInlineInLam (Note _ e) = canInlineInLam e
601 canInlineInLam _ = False
603 early_phase = case phase of
604 SimplPhase 0 -> False
606 -- If we don't have this early_phase test, consider
607 -- x = length [1,2,3]
608 -- The full laziness pass carefully floats all the cons cells to
609 -- top level, and preInlineUnconditionally floats them all back in.
610 -- Result is (a) static allocation replaced by dynamic allocation
611 -- (b) many simplifier iterations because this tickles
612 -- a related problem; only one inlining per pass
614 -- On the other hand, I have seen cases where top-level fusion is
615 -- lost if we don't inline top level thing (e.g. string constants)
616 -- Hence the test for phase zero (which is the phase for all the final
617 -- simplifications). Until phase zero we take no special notice of
618 -- top level things, but then we become more leery about inlining
623 postInlineUnconditionally
624 ~~~~~~~~~~~~~~~~~~~~~~~~~
625 @postInlineUnconditionally@ decides whether to unconditionally inline
626 a thing based on the form of its RHS; in particular if it has a
627 trivial RHS. If so, we can inline and discard the binding altogether.
629 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
630 only have *forward* references Hence, it's safe to discard the binding
632 NOTE: This isn't our last opportunity to inline. We're at the binding
633 site right now, and we'll get another opportunity when we get to the
636 Note that we do this unconditional inlining only for trival RHSs.
637 Don't inline even WHNFs inside lambdas; doing so may simply increase
638 allocation when the function is called. This isn't the last chance; see
641 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
642 Because we don't even want to inline them into the RHS of constructor
643 arguments. See NOTE above
645 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
646 it's best to inline it anyway. We often get a=E; b=a from desugaring,
647 with both a and b marked NOINLINE. But that seems incompatible with
648 our new view that inlining is like a RULE, so I'm sticking to the 'active'
652 postInlineUnconditionally
653 :: SimplEnv -> TopLevelFlag
654 -> InId -- The binder (an OutId would be fine too)
655 -> OccInfo -- From the InId
659 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
661 | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, dont' inline
662 -- because it might be referred to "earlier"
663 | isExportedId bndr = False
664 | exprIsTrivial rhs = True
667 -- The point of examining occ_info here is that for *non-values*
668 -- that occur outside a lambda, the call-site inliner won't have
669 -- a chance (becuase it doesn't know that the thing
670 -- only occurs once). The pre-inliner won't have gotten
671 -- it either, if the thing occurs in more than one branch
672 -- So the main target is things like
675 -- True -> case x of ...
676 -- False -> case x of ...
677 -- I'm not sure how important this is in practice
678 OneOcc in_lam one_br int_cxt -- OneOcc => no code-duplication issue
679 -> smallEnoughToInline unfolding -- Small enough to dup
680 -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
682 -- NB: Do NOT inline arbitrarily big things, even if one_br is True
683 -- Reason: doing so risks exponential behaviour. We simplify a big
684 -- expression, inline it, and simplify it again. But if the
685 -- very same thing happens in the big expression, we get
687 -- PRINCIPLE: when we've already simplified an expression once,
688 -- make sure that we only inline it if it's reasonably small.
690 && ((isNotTopLevel top_lvl && not in_lam) ||
691 -- But outside a lambda, we want to be reasonably aggressive
692 -- about inlining into multiple branches of case
693 -- e.g. let x = <non-value>
694 -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
695 -- Inlining can be a big win if C3 is the hot-spot, even if
696 -- the uses in C1, C2 are not 'interesting'
697 -- An example that gets worse if you add int_cxt here is 'clausify'
699 (isCheapUnfolding unfolding && int_cxt))
700 -- isCheap => acceptable work duplication; in_lam may be true
701 -- int_cxt to prevent us inlining inside a lambda without some
702 -- good reason. See the notes on int_cxt in preInlineUnconditionally
704 IAmDead -> True -- This happens; for example, the case_bndr during case of
705 -- known constructor: case (a,b) of x { (p,q) -> ... }
706 -- Here x isn't mentioned in the RHS, so we don't want to
707 -- create the (dead) let-binding let x = (a,b) in ...
711 -- Here's an example that we don't handle well:
712 -- let f = if b then Left (\x.BIG) else Right (\y.BIG)
713 -- in \y. ....case f of {...} ....
714 -- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
716 -- * We can't preInlineUnconditionally because that woud invalidate
717 -- the occ info for b.
718 -- * We can't postInlineUnconditionally because the RHS is big, and
719 -- that risks exponential behaviour
720 -- * We can't call-site inline, because the rhs is big
724 active = case getMode env of
725 SimplGently -> isAlwaysActive prag
726 SimplPhase n -> isActive n prag
727 prag = idInlinePragma bndr
729 activeInline :: SimplEnv -> OutId -> Bool
731 = case getMode env of
733 -- No inlining at all when doing gentle stuff,
734 -- except for local things that occur once
735 -- The reason is that too little clean-up happens if you
736 -- don't inline use-once things. Also a bit of inlining is *good* for
737 -- full laziness; it can expose constant sub-expressions.
738 -- Example in spectral/mandel/Mandel.hs, where the mandelset
739 -- function gets a useful let-float if you inline windowToViewport
741 -- NB: we used to have a second exception, for data con wrappers.
742 -- On the grounds that we use gentle mode for rule LHSs, and
743 -- they match better when data con wrappers are inlined.
744 -- But that only really applies to the trivial wrappers (like (:)),
745 -- and they are now constructed as Compulsory unfoldings (in MkId)
746 -- so they'll happen anyway.
748 SimplPhase n -> isActive n prag
750 prag = idInlinePragma id
752 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
753 -- Nothing => No rules at all
754 activeRule dflags env
755 | not (dopt Opt_RewriteRules dflags)
756 = Nothing -- Rewriting is off
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 %************************************************************************
773 %************************************************************************
776 mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr
777 -- mkLam tries three things
778 -- a) eta reduction, if that gives a trivial expression
779 -- b) eta expansion [only if there are some value lambdas]
784 = do { dflags <- getDOptsSmpl
785 ; mkLam' dflags bndrs body }
787 mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
788 mkLam' dflags bndrs (Cast body co)
789 | not (any bad bndrs)
790 -- Note [Casts and lambdas]
791 = do { lam <- mkLam' dflags bndrs body
792 ; return (mkCoerce (mkPiTypes bndrs co) lam) }
794 co_vars = tyVarsOfType co
795 bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
797 mkLam' dflags bndrs body
798 | dopt Opt_DoEtaReduction dflags,
799 Just etad_lam <- tryEtaReduce bndrs body
800 = do { tick (EtaReduction (head bndrs))
803 | dopt Opt_DoLambdaEtaExpansion dflags,
804 any isRuntimeVar bndrs
805 = do { body' <- tryEtaExpansion dflags body
806 ; return (mkLams bndrs body') }
809 = returnSmpl (mkLams bndrs body)
812 Note [Casts and lambdas]
813 ~~~~~~~~~~~~~~~~~~~~~~~~
815 (\x. (\y. e) `cast` g1) `cast` g2
816 There is a danger here that the two lambdas look separated, and the
817 full laziness pass might float an expression to between the two.
819 So this equation in mkLam' floats the g1 out, thus:
820 (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1)
823 In general, this floats casts outside lambdas, where (I hope) they
824 might meet and cancel with some other cast:
825 \x. e `cast` co ===> (\x. e) `cast` (tx -> co)
826 /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co)
827 /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co)
830 Notice that it works regardless of 'e'. Originally it worked only
831 if 'e' was itself a lambda, but in some cases that resulted in
832 fruitless iteration in the simplifier. A good example was when
833 compiling Text.ParserCombinators.ReadPrec, where we had a definition
834 like (\x. Get `cast` g)
835 where Get is a constructor with nonzero arity. Then mkLam eta-expanded
836 the Get, and the next iteration eta-reduced it, and then eta-expanded
839 Note also the side condition for the case of coercion binders.
840 It does not make sense to transform
841 /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g)
842 because the latter is not well-kinded.
844 -- c) floating lets out through big lambdas
845 -- [only if all tyvar lambdas, and only if this lambda
846 -- is the RHS of a let]
848 {- Sept 01: I'm experimenting with getting the
849 full laziness pass to float out past big lambdsa
850 | all isTyVar bndrs, -- Only for big lambdas
851 contIsRhs cont -- Only try the rhs type-lambda floating
852 -- if this is indeed a right-hand side; otherwise
853 -- we end up floating the thing out, only for float-in
854 -- to float it right back in again!
855 = tryRhsTyLam env bndrs body `thenSmpl` \ (floats, body') ->
856 returnSmpl (floats, mkLams bndrs body')
860 %************************************************************************
864 %************************************************************************
866 Note [Eta reduction conditions]
867 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
868 We try for eta reduction here, but *only* if we get all the way to an
869 trivial expression. We don't want to remove extra lambdas unless we
870 are going to avoid allocating this thing altogether.
872 There are some particularly delicate points here:
874 * Eta reduction is not valid in general:
876 This matters, partly for old-fashioned correctness reasons but,
877 worse, getting it wrong can yield a seg fault. Consider
879 h y = case (case y of { True -> f `seq` True; False -> False }) of
880 True -> ...; False -> ...
882 If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
883 says f=bottom, and replaces the (f `seq` True) with just
884 (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it
885 *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands
886 the definition again, so that it does not termninate after all.
887 Result: seg-fault because the boolean case actually gets a function value.
890 So it's important to to the right thing.
892 * We need to be careful if we just look at f's arity. Currently (Dec07),
893 f's arity is visible in its own RHS (see Note [Arity robustness] in
894 SimplEnv) so we must *not* trust the arity when checking that 'f' is
895 a value. Instead, look at the unfolding.
897 However for GlobalIds we can look at the arity; and for primops we
898 must, since they have no unfolding.
900 * Regardless of whether 'f' is a vlaue, we always want to
901 reduce (/\a -> f a) to f
902 This came up in a RULE: foldr (build (/\a -> g a))
903 did not match foldr (build (/\b -> ...something complex...))
904 The type checker can insert these eta-expanded versions,
905 with both type and dictionary lambdas; hence the slightly
908 These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
912 tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
913 tryEtaReduce bndrs body
914 = go (reverse bndrs) body
916 go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
917 go [] fun | ok_fun fun = Just fun -- Success!
918 go _ _ = Nothing -- Failure!
920 -- Note [Eta reduction conditions]
921 ok_fun (App fun (Type ty))
922 | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
925 = not (fun_id `elem` bndrs)
926 && (ok_fun_id fun_id || all ok_lam bndrs)
930 | isLocalId fun = isEvaldUnfolding (idUnfolding fun)
931 | isDataConWorkId fun = True
932 | isGlobalId fun = idArity fun > 0
934 ok_lam v = isTyVar v || isDictId v
936 ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
940 %************************************************************************
944 %************************************************************************
948 f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
951 where (in both cases)
953 * The xi can include type variables
955 * The yi are all value variables
957 * N is a NORMAL FORM (i.e. no redexes anywhere)
958 wanting a suitable number of extra args.
960 The biggest reason for doing this is for cases like
966 Here we want to get the lambdas together. A good exmaple is the nofib
967 program fibheaps, which gets 25% more allocation if you don't do this
970 We may have to sandwich some coerces between the lambdas
971 to make the types work. exprEtaExpandArity looks through coerces
972 when computing arity; and etaExpand adds the coerces as necessary when
973 actually computing the expansion.
976 tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
977 -- There is at least one runtime binder in the binders
978 tryEtaExpansion dflags body
979 = getUniquesSmpl `thenSmpl` \ us ->
980 returnSmpl (etaExpand fun_arity us body (exprType body))
982 fun_arity = exprEtaExpandArity dflags body
986 %************************************************************************
988 \subsection{Floating lets out of big lambdas}
990 %************************************************************************
992 Note [Floating and type abstraction]
993 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
996 We'd like to float this to
999 x = /\a. C (y1 a) (y2 a)
1000 for the usual reasons: we want to inline x rather vigorously.
1002 You may think that this kind of thing is rare. But in some programs it is
1003 common. For example, if you do closure conversion you might get:
1005 data a :-> b = forall e. (e -> a -> b) :$ e
1007 f_cc :: forall a. a :-> a
1008 f_cc = /\a. (\e. id a) :$ ()
1010 Now we really want to inline that f_cc thing so that the
1011 construction of the closure goes away.
1013 So I have elaborated simplLazyBind to understand right-hand sides that look
1017 and treat them specially. The real work is done in SimplUtils.abstractFloats,
1018 but there is quite a bit of plumbing in simplLazyBind as well.
1020 The same transformation is good when there are lets in the body:
1022 /\abc -> let(rec) x = e in b
1024 let(rec) x' = /\abc -> let x = x' a b c in e
1026 /\abc -> let x = x' a b c in b
1028 This is good because it can turn things like:
1030 let f = /\a -> letrec g = ... g ... in g
1032 letrec g' = /\a -> ... g' a ...
1034 let f = /\ a -> g' a
1036 which is better. In effect, it means that big lambdas don't impede
1039 This optimisation is CRUCIAL in eliminating the junk introduced by
1040 desugaring mutually recursive definitions. Don't eliminate it lightly!
1042 [May 1999] If we do this transformation *regardless* then we can
1043 end up with some pretty silly stuff. For example,
1046 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
1051 st = /\s -> ...[y1 s/x1, y2 s/x2]
1054 Unless the "..." is a WHNF there is really no point in doing this.
1055 Indeed it can make things worse. Suppose x1 is used strictly,
1058 x1* = case f y of { (a,b) -> e }
1060 If we abstract this wrt the tyvar we then can't do the case inline
1061 as we would normally do.
1063 That's why the whole transformation is part of the same process that
1064 floats let-bindings and constructor arguments out of RHSs. In particular,
1065 it is guarded by the doFloatFromRhs call in simplLazyBind.
1069 abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
1070 abstractFloats main_tvs body_env body
1071 = ASSERT( notNull body_floats )
1072 do { (subst, float_binds) <- mapAccumLSmpl abstract empty_subst body_floats
1073 ; return (float_binds, CoreSubst.substExpr subst body) }
1075 main_tv_set = mkVarSet main_tvs
1076 body_floats = getFloats body_env
1077 empty_subst = CoreSubst.mkEmptySubst (seInScope body_env)
1079 abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
1080 abstract subst (NonRec id rhs)
1081 = do { (poly_id, poly_app) <- mk_poly tvs_here id
1082 ; let poly_rhs = mkLams tvs_here rhs'
1083 subst' = CoreSubst.extendIdSubst subst id poly_app
1084 ; return (subst', (NonRec poly_id poly_rhs)) }
1086 rhs' = CoreSubst.substExpr subst rhs
1087 tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions]
1089 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
1091 -- Abstract only over the type variables free in the rhs
1092 -- wrt which the new binding is abstracted. But the naive
1093 -- approach of abstract wrt the tyvars free in the Id's type
1095 -- /\ a b -> let t :: (a,b) = (e1, e2)
1098 -- Here, b isn't free in x's type, but we must nevertheless
1099 -- abstract wrt b as well, because t's type mentions b.
1100 -- Since t is floated too, we'd end up with the bogus:
1101 -- poly_t = /\ a b -> (e1, e2)
1102 -- poly_x = /\ a -> fst (poly_t a *b*)
1103 -- So for now we adopt the even more naive approach of
1104 -- abstracting wrt *all* the tyvars. We'll see if that
1105 -- gives rise to problems. SLPJ June 98
1107 abstract subst (Rec prs)
1108 = do { (poly_ids, poly_apps) <- mapAndUnzipSmpl (mk_poly tvs_here) ids
1109 ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
1110 poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
1111 ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
1113 (ids,rhss) = unzip prs
1114 -- For a recursive group, it's a bit of a pain to work out the minimal
1115 -- set of tyvars over which to abstract:
1116 -- /\ a b c. let x = ...a... in
1117 -- letrec { p = ...x...q...
1118 -- q = .....p...b... } in
1120 -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
1121 -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
1122 -- Since it's a pain, we just use the whole set, which is always safe
1124 -- If you ever want to be more selective, remember this bizarre case too:
1126 -- Here, we must abstract 'x' over 'a'.
1129 mk_poly tvs_here var
1130 = do { uniq <- getUniqueSmpl
1131 ; let poly_name = setNameUnique (idName var) uniq -- Keep same name
1132 poly_ty = mkForAllTys tvs_here (idType var) -- But new type of course
1133 poly_id = mkLocalId poly_name poly_ty
1134 ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
1135 -- In the olden days, it was crucial to copy the occInfo of the original var,
1136 -- because we were looking at occurrence-analysed but as yet unsimplified code!
1137 -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking
1138 -- at already simplified code, so it doesn't matter
1140 -- It's even right to retain single-occurrence or dead-var info:
1141 -- Suppose we started with /\a -> let x = E in B
1142 -- where x occurs once in B. Then we transform to:
1143 -- let x' = /\a -> E in /\a -> let x* = x' a in B
1144 -- where x* has an INLINE prag on it. Now, once x* is inlined,
1145 -- the occurrences of x' will be just the occurrences originally
1149 Note [Abstract over coercions]
1150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1151 If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
1152 type variable a. Rather than sort this mess out, we simply bale out and abstract
1153 wrt all the type variables if any of them are coercion variables.
1156 Historical note: if you use let-bindings instead of a substitution, beware of this:
1158 -- Suppose we start with:
1160 -- x = /\ a -> let g = G in E
1162 -- Then we'll float to get
1164 -- x = let poly_g = /\ a -> G
1165 -- in /\ a -> let g = poly_g a in E
1167 -- But now the occurrence analyser will see just one occurrence
1168 -- of poly_g, not inside a lambda, so the simplifier will
1169 -- PreInlineUnconditionally poly_g back into g! Badk to square 1!
1170 -- (I used to think that the "don't inline lone occurrences" stuff
1171 -- would stop this happening, but since it's the *only* occurrence,
1172 -- PreInlineUnconditionally kicks in first!)
1174 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
1175 -- to appear many times. (NB: mkInlineMe eliminates
1176 -- such notes on trivial RHSs, so do it manually.)
1178 %************************************************************************
1182 %************************************************************************
1184 prepareAlts tries these things:
1186 1. If several alternatives are identical, merge them into
1187 a single DEFAULT alternative. I've occasionally seen this
1188 making a big difference:
1190 case e of =====> case e of
1191 C _ -> f x D v -> ....v....
1192 D v -> ....v.... DEFAULT -> f x
1195 The point is that we merge common RHSs, at least for the DEFAULT case.
1196 [One could do something more elaborate but I've never seen it needed.]
1197 To avoid an expensive test, we just merge branches equal to the *first*
1198 alternative; this picks up the common cases
1199 a) all branches equal
1200 b) some branches equal to the DEFAULT (which occurs first)
1203 case e of b { ==> case e of b {
1204 p1 -> rhs1 p1 -> rhs1
1206 pm -> rhsm pm -> rhsm
1207 _ -> case b of b' { pn -> let b'=b in rhsn
1209 ... po -> let b'=b in rhso
1210 po -> rhso _ -> let b'=b in rhsd
1214 which merges two cases in one case when -- the default alternative of
1215 the outer case scrutises the same variable as the outer case This
1216 transformation is called Case Merging. It avoids that the same
1217 variable is scrutinised multiple times.
1220 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
1226 where @is@ was something like
1228 p `is` n = p /= (-1) && p == n
1230 This gave rise to a horrible sequence of cases
1237 and similarly in cascade for all the join points!
1240 ~~~~~~~~~~~~~~~~~~~~
1241 We do this *here*, looking at un-simplified alternatives, because we
1242 have to check that r doesn't mention the variables bound by the
1243 pattern in each alternative, so the binder-info is rather useful.
1246 prepareAlts :: SimplEnv -> OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
1247 prepareAlts env scrut case_bndr' alts
1248 = do { dflags <- getDOptsSmpl
1249 ; alts <- combineIdenticalAlts case_bndr' alts
1251 ; let (alts_wo_default, maybe_deflt) = findDefault alts
1252 alt_cons = [con | (con,_,_) <- alts_wo_default]
1253 imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
1254 -- "imposs_deflt_cons" are handled
1255 -- EITHER by the context,
1256 -- OR by a non-DEFAULT branch in this case expression.
1258 ; default_alts <- prepareDefault dflags env case_bndr' mb_tc_app
1259 imposs_deflt_cons maybe_deflt
1261 ; let trimmed_alts = filterOut impossible_alt alts_wo_default
1262 merged_alts = mergeAlts trimmed_alts default_alts
1263 -- We need the mergeAlts in case the new default_alt
1264 -- has turned into a constructor alternative.
1265 -- The merge keeps the inner DEFAULT at the front, if there is one
1266 -- and interleaves the alternatives in the right order
1268 ; return (imposs_deflt_cons, merged_alts) }
1270 mb_tc_app = splitTyConApp_maybe (idType case_bndr')
1271 Just (_, inst_tys) = mb_tc_app
1273 imposs_cons = case scrut of
1274 Var v -> otherCons (idUnfolding v)
1277 impossible_alt :: CoreAlt -> Bool
1278 impossible_alt (con, _, _) | con `elem` imposs_cons = True
1279 impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con
1280 impossible_alt alt = False
1283 --------------------------------------------------
1284 -- 1. Merge identical branches
1285 --------------------------------------------------
1286 combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
1288 combineIdenticalAlts case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
1289 | all isDeadBinder bndrs1, -- Remember the default
1290 length filtered_alts < length con_alts -- alternative comes first
1291 -- Also Note [Dead binders]
1292 = do { tick (AltMerge case_bndr)
1293 ; return ((DEFAULT, [], rhs1) : filtered_alts) }
1295 filtered_alts = filter keep con_alts
1296 keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
1298 combineIdenticalAlts case_bndr alts = return alts
1300 -------------------------------------------------------------------------
1301 -- Prepare the default alternative
1302 -------------------------------------------------------------------------
1303 prepareDefault :: DynFlags
1305 -> OutId -- Case binder; need just for its type. Note that as an
1306 -- OutId, it has maximum information; this is important.
1307 -- Test simpl013 is an example
1308 -> Maybe (TyCon, [Type]) -- Type of scrutinee, decomposed
1309 -> [AltCon] -- These cons can't happen when matching the default
1310 -> Maybe InExpr -- Rhs
1311 -> SimplM [InAlt] -- Still unsimplified
1312 -- We use a list because it's what mergeAlts expects,
1313 -- And becuase case-merging can cause many to show up
1315 ------- Merge nested cases ----------
1316 prepareDefault dflags env outer_bndr bndr_ty imposs_cons (Just deflt_rhs)
1317 | dopt Opt_CaseMerge dflags
1318 , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
1319 , DoneId inner_scrut_var' <- substId env inner_scrut_var
1320 -- Remember, inner_scrut_var is an InId, but outer_bndr is an OutId
1321 , inner_scrut_var' == outer_bndr
1322 -- NB: the substId means that if the outer scrutinee was a
1323 -- variable, and inner scrutinee is the same variable,
1324 -- then inner_scrut_var' will be outer_bndr
1325 -- via the magic of simplCaseBinder
1326 = do { tick (CaseMerge outer_bndr)
1328 ; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
1329 ; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts,
1330 not (con `elem` imposs_cons) ]
1331 -- NB: filter out any imposs_cons. Example:
1334 -- DEFAULT -> case x of
1337 -- When we merge, we must ensure that e1 takes
1338 -- precedence over e2 as the value for A!
1340 -- Warning: don't call prepareAlts recursively!
1341 -- Firstly, there's no point, because inner alts have already had
1342 -- mkCase applied to them, so they won't have a case in their default
1343 -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
1344 -- in munge_rhs may put a case into the DEFAULT branch!
1347 --------- Fill in known constructor -----------
1348 prepareDefault dflags env case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
1349 | -- This branch handles the case where we are
1350 -- scrutinisng an algebraic data type
1351 isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples.
1352 , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval:
1353 -- case x of { DEFAULT -> e }
1354 -- and we don't want to fill in a default for them!
1355 , Just all_cons <- tyConDataCons_maybe tycon
1356 , not (null all_cons) -- This is a tricky corner case. If the data type has no constructors,
1357 -- which GHC allows, then the case expression will have at most a default
1358 -- alternative. We don't want to eliminate that alternative, because the
1359 -- invariant is that there's always one alternative. It's more convenient
1361 -- case x of { DEFAULT -> e }
1362 -- as it is, rather than transform it to
1363 -- error "case cant match"
1364 -- which would be quite legitmate. But it's a really obscure corner, and
1365 -- not worth wasting code on.
1366 , let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type
1367 impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
1368 = case filterOut impossible all_cons of
1369 [] -> return [] -- Eliminate the default alternative
1370 -- altogether if it can't match
1372 [con] -> -- It matches exactly one constructor, so fill it in
1373 do { tick (FillInCaseDefault case_bndr)
1374 ; us <- getUniquesSmpl
1375 ; let (ex_tvs, co_tvs, arg_ids) =
1376 dataConRepInstPat us con inst_tys
1377 ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] }
1379 two_or_more -> return [(DEFAULT, [], deflt_rhs)]
1381 --------- Catch-all cases -----------
1382 prepareDefault dflags env case_bndr bndr_ty imposs_cons (Just deflt_rhs)
1383 = return [(DEFAULT, [], deflt_rhs)]
1385 prepareDefault dflags env case_bndr bndr_ty imposs_cons Nothing
1386 = return [] -- No default branch
1391 =================================================================================
1393 mkCase tries these things
1395 1. Eliminate the case altogether if possible
1403 and similar friends.
1407 mkCase :: OutExpr -> OutId -> OutType
1408 -> [OutAlt] -- Increasing order
1411 --------------------------------------------------
1412 -- 1. Check for empty alternatives
1413 --------------------------------------------------
1415 -- This isn't strictly an error. It's possible that the simplifer might "see"
1416 -- that an inner case has no accessible alternatives before it "sees" that the
1417 -- entire branch of an outer case is inaccessible. So we simply
1418 -- put an error case here insteadd
1419 mkCase scrut case_bndr ty []
1420 = pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
1421 return (mkApps (Var rUNTIME_ERROR_ID)
1422 [Type ty, Lit (mkStringLit "Impossible alternative")])
1425 --------------------------------------------------
1427 --------------------------------------------------
1429 mkCase scrut case_bndr ty alts -- Identity case
1430 | all identity_alt alts
1431 = tick (CaseIdentity case_bndr) `thenSmpl_`
1432 returnSmpl (re_cast scrut)
1434 identity_alt (con, args, rhs) = check_eq con args (de_cast rhs)
1436 check_eq DEFAULT _ (Var v) = v == case_bndr
1437 check_eq (LitAlt lit') _ (Lit lit) = lit == lit'
1438 check_eq (DataAlt con) args rhs = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
1439 || rhs `cheapEqExpr` Var case_bndr
1440 check_eq con args rhs = False
1442 arg_tys = map Type (tyConAppArgs (idType case_bndr))
1445 -- case e of x { _ -> x `cast` c }
1446 -- And we definitely want to eliminate this case, to give
1448 -- So we throw away the cast from the RHS, and reconstruct
1449 -- it at the other end. All the RHS casts must be the same
1450 -- if (all identity_alt alts) holds.
1452 -- Don't worry about nested casts, because the simplifier combines them
1453 de_cast (Cast e _) = e
1456 re_cast scrut = case head alts of
1457 (_,_,Cast _ co) -> Cast scrut co
1462 --------------------------------------------------
1464 --------------------------------------------------
1465 mkCase scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
1469 When adding auxiliary bindings for the case binder, it's worth checking if
1470 its dead, because it often is, and occasionally these mkCase transformations
1471 cascade rather nicely.
1474 bindCaseBndr bndr rhs body
1475 | isDeadBinder bndr = body
1476 | otherwise = bindNonRec bndr rhs body