2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplUtils]{The simplifier utilities}
8 mkLam, prepareAlts, mkCase,
11 preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
14 -- The continuation type
15 SimplCont(..), DupFlag(..), LetRhsFlag(..),
16 contIsDupable, contResultType,
17 countValArgs, countArgs, pushContArgs,
18 mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
19 getContArgs, interestingCallContext, interestingArg, isStrictType
23 #include "HsVersions.h"
26 import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), opt_UF_UpdateInPlace,
27 opt_SimplNoPreInlining, opt_RulesOff,
30 import CoreFVs ( exprFreeVars )
31 import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
32 etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
33 findDefault, exprOkForSpeculation, exprIsValue
35 import Id ( idType, isDataConWorkId, idOccInfo,
36 mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
37 idUnfolding, idNewStrictness, idInlinePragma,
39 import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
41 import Type ( Type, splitFunTys, dropForAlls, isStrictType,
42 splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
44 import TcType ( isDictTy )
45 import Name ( mkSysTvName )
46 import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
47 import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
48 import Var ( tyVarKind, mkTyVar )
50 import BasicTypes ( TopLevelFlag(..), isTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
51 Activation, isAlwaysActive, isActive )
52 import Util ( lengthExceeds )
57 %************************************************************************
59 \subsection{The continuation data type}
61 %************************************************************************
64 data SimplCont -- Strict contexts
65 = Stop OutType -- Type of the result
67 Bool -- True <=> This is the RHS of a thunk whose type suggests
68 -- that update-in-place would be possible
69 -- (This makes the inliner a little keener.)
71 | CoerceIt OutType -- The To-type, simplified
74 | InlinePlease -- This continuation makes a function very
75 SimplCont -- keen to inline itelf
78 InExpr SimplEnv -- The argument, as yet unsimplified,
79 SimplCont -- and its environment
82 InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
85 | ArgOf LetRhsFlag -- An arbitrary strict context: the argument
86 -- of a strict function, or a primitive-arg fn
88 -- No DupFlag because we never duplicate it
89 OutType -- arg_ty: type of the argument itself
90 OutType -- cont_ty: the type of the expression being sought by the context
91 -- f (error "foo") ==> coerce t (error "foo")
93 -- We need to know the type t, to which to coerce.
95 (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- What to do with the result
96 -- The result expression in the OutExprStuff has type cont_ty
98 data LetRhsFlag = AnArg -- It's just an argument not a let RHS
99 | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas)
101 instance Outputable LetRhsFlag where
102 ppr AnArg = ptext SLIT("arg")
103 ppr AnRhs = ptext SLIT("rhs")
105 instance Outputable SimplCont where
106 ppr (Stop _ is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs)
107 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
108 ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
109 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
110 (nest 4 (ppr alts)) $$ ppr cont
111 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
112 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
114 data DupFlag = OkToDup | NoDup
116 instance Outputable DupFlag where
117 ppr OkToDup = ptext SLIT("ok")
118 ppr NoDup = ptext SLIT("nodup")
122 mkBoringStop, mkRhsStop :: OutType -> SimplCont
123 mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
124 mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
126 contIsRhs :: SimplCont -> Bool
127 contIsRhs (Stop _ AnRhs _) = True
128 contIsRhs (ArgOf AnRhs _ _ _) = True
129 contIsRhs other = False
131 contIsRhsOrArg (Stop _ _ _) = True
132 contIsRhsOrArg (ArgOf _ _ _ _) = True
133 contIsRhsOrArg other = False
136 contIsDupable :: SimplCont -> Bool
137 contIsDupable (Stop _ _ _) = True
138 contIsDupable (ApplyTo OkToDup _ _ _) = True
139 contIsDupable (Select OkToDup _ _ _ _) = True
140 contIsDupable (CoerceIt _ cont) = contIsDupable cont
141 contIsDupable (InlinePlease cont) = contIsDupable cont
142 contIsDupable other = False
145 discardableCont :: SimplCont -> Bool
146 discardableCont (Stop _ _ _) = False
147 discardableCont (CoerceIt _ cont) = discardableCont cont
148 discardableCont (InlinePlease cont) = discardableCont cont
149 discardableCont other = True
151 discardCont :: SimplCont -- A continuation, expecting
152 -> SimplCont -- Replace the continuation with a suitable coerce
153 discardCont cont = case cont of
154 Stop to_ty is_rhs _ -> cont
155 other -> CoerceIt to_ty (mkBoringStop to_ty)
157 to_ty = contResultType cont
160 contResultType :: SimplCont -> OutType
161 contResultType (Stop to_ty _ _) = to_ty
162 contResultType (ArgOf _ _ to_ty _) = to_ty
163 contResultType (ApplyTo _ _ _ cont) = contResultType cont
164 contResultType (CoerceIt _ cont) = contResultType cont
165 contResultType (InlinePlease cont) = contResultType cont
166 contResultType (Select _ _ _ _ cont) = contResultType cont
169 countValArgs :: SimplCont -> Int
170 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
171 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
172 countValArgs other = 0
174 countArgs :: SimplCont -> Int
175 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
179 pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
180 -- Pushes args with the specified environment
181 pushContArgs env [] cont = cont
182 pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
187 getContArgs :: SwitchChecker
188 -> OutId -> SimplCont
189 -> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
190 SimplCont, -- Remaining continuation
191 Bool) -- Whether we came across an InlineCall
192 -- getContArgs id k = (args, k', inl)
193 -- args are the leading ApplyTo items in k
194 -- (i.e. outermost comes first)
195 -- augmented with demand info from the functionn
196 getContArgs chkr fun orig_cont
198 -- Ignore strictness info if the no-case-of-case
199 -- flag is on. Strictness changes evaluation order
200 -- and that can change full laziness
201 stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
202 | otherwise = computed_stricts
204 go [] stricts False orig_cont
206 ----------------------------
209 go acc ss inl (ApplyTo _ arg@(Type _) se cont)
210 = go ((arg,se,False) : acc) ss inl cont
211 -- NB: don't bother to instantiate the function type
214 go acc (s:ss) inl (ApplyTo _ arg se cont)
215 = go ((arg,se,s) : acc) ss inl cont
217 -- An Inline continuation
218 go acc ss inl (InlinePlease cont)
219 = go acc ss True cont
221 -- We're run out of arguments, or else we've run out of demands
222 -- The latter only happens if the result is guaranteed bottom
223 -- This is the case for
224 -- * case (error "hello") of { ... }
225 -- * (error "Hello") arg
226 -- * f (error "Hello") where f is strict
228 -- Then, especially in the first of these cases, we'd like to discard
229 -- the continuation, leaving just the bottoming expression. But the
230 -- type might not be right, so we may have to add a coerce.
232 | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
233 | otherwise = (reverse acc, cont, inl)
235 ----------------------------
236 vanilla_stricts, computed_stricts :: [Bool]
237 vanilla_stricts = repeat False
238 computed_stricts = zipWith (||) fun_stricts arg_stricts
240 ----------------------------
241 (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun))
242 arg_stricts = map isStrictType val_arg_tys ++ repeat False
243 -- These argument types are used as a cheap and cheerful way to find
244 -- unboxed arguments, which must be strict. But it's an InType
245 -- and so there might be a type variable where we expect a function
246 -- type (the substitution hasn't happened yet). And we don't bother
247 -- doing the type applications for a polymorphic function.
248 -- Hence the splitFunTys*IgnoringForAlls*
250 ----------------------------
251 -- If fun_stricts is finite, it means the function returns bottom
252 -- after that number of value args have been consumed
253 -- Otherwise it's infinite, extended with False
255 = case splitStrictSig (idNewStrictness fun) of
256 (demands, result_info)
257 | not (demands `lengthExceeds` countValArgs orig_cont)
258 -> -- Enough args, use the strictness given.
259 -- For bottoming functions we used to pretend that the arg
260 -- is lazy, so that we don't treat the arg as an
261 -- interesting context. This avoids substituting
262 -- top-level bindings for (say) strings into
263 -- calls to error. But now we are more careful about
264 -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
265 if isBotRes result_info then
266 map isStrictDmd demands -- Finite => result is bottom
268 map isStrictDmd demands ++ vanilla_stricts
270 other -> vanilla_stricts -- Not enough args, or no strictness
273 interestingArg :: OutExpr -> Bool
274 -- An argument is interesting if it has *some* structure
275 -- We are here trying to avoid unfolding a function that
276 -- is applied only to variables that have no unfolding
277 -- (i.e. they are probably lambda bound): f x y z
278 -- There is little point in inlining f here.
279 interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
280 -- Was: isValueUnfolding (idUnfolding v')
281 -- But that seems over-pessimistic
283 -- This accounts for an argument like
284 -- () or [], which is definitely interesting
285 interestingArg (Type _) = False
286 interestingArg (App fn (Type _)) = interestingArg fn
287 interestingArg (Note _ a) = interestingArg a
288 interestingArg other = True
289 -- Consider let x = 3 in f x
290 -- The substitution will contain (x -> ContEx 3), and we want to
291 -- to say that x is an interesting argument.
292 -- But consider also (\x. f x y) y
293 -- The substitution will contain (x -> ContEx y), and we want to say
294 -- that x is not interesting (assuming y has no unfolding)
297 Comment about interestingCallContext
298 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
299 We want to avoid inlining an expression where there can't possibly be
300 any gain, such as in an argument position. Hence, if the continuation
301 is interesting (eg. a case scrutinee, application etc.) then we
302 inline, otherwise we don't.
304 Previously some_benefit used to return True only if the variable was
305 applied to some value arguments. This didn't work:
307 let x = _coerce_ (T Int) Int (I# 3) in
308 case _coerce_ Int (T Int) x of
311 we want to inline x, but can't see that it's a constructor in a case
312 scrutinee position, and some_benefit is False.
316 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
318 .... case dMonadST _@_ x0 of (a,b,c) -> ....
320 we'd really like to inline dMonadST here, but we *don't* want to
321 inline if the case expression is just
323 case x of y { DEFAULT -> ... }
325 since we can just eliminate this case instead (x is in WHNF). Similar
326 applies when x is bound to a lambda expression. Hence
327 contIsInteresting looks for case expressions with just a single
331 interestingCallContext :: Bool -- False <=> no args at all
332 -> Bool -- False <=> no value args
334 -- The "lone-variable" case is important. I spent ages
335 -- messing about with unsatisfactory varaints, but this is nice.
336 -- The idea is that if a variable appear all alone
337 -- as an arg of lazy fn, or rhs Stop
338 -- as scrutinee of a case Select
339 -- as arg of a strict fn ArgOf
340 -- then we should not inline it (unless there is some other reason,
341 -- e.g. is is the sole occurrence). We achieve this by making
342 -- interestingCallContext return False for a lone variable.
344 -- Why? At least in the case-scrutinee situation, turning
345 -- let x = (a,b) in case x of y -> ...
347 -- let x = (a,b) in case (a,b) of y -> ...
349 -- let x = (a,b) in let y = (a,b) in ...
350 -- is bad if the binding for x will remain.
352 -- Another example: I discovered that strings
353 -- were getting inlined straight back into applications of 'error'
354 -- because the latter is strict.
356 -- f = \x -> ...(error s)...
358 -- Fundamentally such contexts should not ecourage inlining because
359 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
360 -- so there's no gain.
362 -- However, even a type application or coercion isn't a lone variable.
364 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
365 -- We had better inline that sucker! The case won't see through it.
367 -- For now, I'm treating treating a variable applied to types
368 -- in a *lazy* context "lone". The motivating example was
370 -- g = /\a. \y. h (f a)
371 -- There's no advantage in inlining f here, and perhaps
372 -- a significant disadvantage. Hence some_val_args in the Stop case
374 interestingCallContext some_args some_val_args cont
377 interesting (InlinePlease _) = True
378 interesting (Select _ _ _ _ _) = some_args
379 interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
380 -- Perhaps True is a bit over-keen, but I've
381 -- seen (coerce f) x, where f has an INLINE prag,
382 -- So we have to give some motivaiton for inlining it
383 interesting (ArgOf _ _ _ _) = some_val_args
384 interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
385 interesting (CoerceIt _ cont) = interesting cont
386 -- If this call is the arg of a strict function, the context
387 -- is a bit interesting. If we inline here, we may get useful
388 -- evaluation information to avoid repeated evals: e.g.
390 -- Here the contIsInteresting makes the '*' keener to inline,
391 -- which in turn exposes a constructor which makes the '+' inline.
392 -- Assuming that +,* aren't small enough to inline regardless.
394 -- It's also very important to inline in a strict context for things
397 -- Here, the context of (f x) is strict, and if f's unfolding is
398 -- a build it's *great* to inline it here. So we must ensure that
399 -- the context for (f x) is not totally uninteresting.
403 canUpdateInPlace :: Type -> Bool
404 -- Consider let x = <wurble> in ...
405 -- If <wurble> returns an explicit constructor, we might be able
406 -- to do update in place. So we treat even a thunk RHS context
407 -- as interesting if update in place is possible. We approximate
408 -- this by seeing if the type has a single constructor with a
409 -- small arity. But arity zero isn't good -- we share the single copy
410 -- for that case, so no point in sharing.
413 | not opt_UF_UpdateInPlace = False
415 = case splitTyConApp_maybe ty of
417 Just (tycon, _) -> case tyConDataCons_maybe tycon of
418 Just [dc] -> arity == 1 || arity == 2
420 arity = dataConRepArity dc
426 %************************************************************************
428 \subsection{Decisions about inlining}
430 %************************************************************************
432 Inlining is controlled partly by the SimplifierMode switch. This has two
435 SimplGently (a) Simplifying before specialiser/full laziness
436 (b) Simplifiying inside INLINE pragma
437 (c) Simplifying the LHS of a rule
438 (d) Simplifying a GHCi expression or Template
441 SimplPhase n Used at all other times
443 The key thing about SimplGently is that it does no call-site inlining.
444 Before full laziness we must be careful not to inline wrappers,
445 because doing so inhibits floating
446 e.g. ...(case f x of ...)...
447 ==> ...(case (case x of I# x# -> fw x#) of ...)...
448 ==> ...(case x of I# x# -> case fw x# of ...)...
449 and now the redex (f x) isn't floatable any more.
451 The no-inling thing is also important for Template Haskell. You might be
452 compiling in one-shot mode with -O2; but when TH compiles a splice before
453 running it, we don't want to use -O2. Indeed, we don't want to inline
454 anything, because the byte-code interpreter might get confused about
455 unboxed tuples and suchlike.
459 SimplGently is also used as the mode to simplify inside an InlineMe note.
462 inlineMode :: SimplifierMode
463 inlineMode = SimplGently
466 It really is important to switch off inlinings inside such
467 expressions. Consider the following example
473 in ...g...g...g...g...g...
475 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
476 and thence copied multiple times when g is inlined.
479 This function may be inlinined in other modules, so we
480 don't want to remove (by inlining) calls to functions that have
481 specialisations, or that may have transformation rules in an importing
484 E.g. {-# INLINE f #-}
487 and suppose that g is strict *and* has specialisations. If we inline
488 g's wrapper, we deny f the chance of getting the specialised version
489 of g when f is inlined at some call site (perhaps in some other
492 It's also important not to inline a worker back into a wrapper.
494 wraper = inline_me (\x -> ...worker... )
495 Normally, the inline_me prevents the worker getting inlined into
496 the wrapper (initially, the worker's only call site!). But,
497 if the wrapper is sure to be called, the strictness analyser will
498 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
499 continuation. That's why the keep_inline predicate returns True for
500 ArgOf continuations. It shouldn't do any harm not to dissolve the
501 inline-me note under these circumstances.
503 Note that the result is that we do very little simplification
506 all xs = foldr (&&) True xs
507 any p = all . map p {-# INLINE any #-}
509 Problem: any won't get deforested, and so if it's exported and the
510 importer doesn't use the inlining, (eg passes it as an arg) then we
511 won't get deforestation at all. We havn't solved this problem yet!
514 preInlineUnconditionally
515 ~~~~~~~~~~~~~~~~~~~~~~~~
516 @preInlineUnconditionally@ examines a bndr to see if it is used just
517 once in a completely safe way, so that it is safe to discard the
518 binding inline its RHS at the (unique) usage site, REGARDLESS of how
519 big the RHS might be. If this is the case we don't simplify the RHS
520 first, but just inline it un-simplified.
522 This is much better than first simplifying a perhaps-huge RHS and then
523 inlining and re-simplifying it. Indeed, it can be at least quadratically
532 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
534 NB: we don't even look at the RHS to see if it's trivial
537 where x is used many times, but this is the unique occurrence of y.
538 We should NOT inline x at all its uses, because then we'd do the same
539 for y -- aargh! So we must base this pre-rhs-simplification decision
540 solely on x's occurrences, not on its rhs.
542 Evne RHSs labelled InlineMe aren't caught here, because there might be
543 no benefit from inlining at the call site.
545 [Sept 01] Don't unconditionally inline a top-level thing, because that
546 can simply make a static thing into something built dynamically. E.g.
550 [Remember that we treat \s as a one-shot lambda.] No point in
551 inlining x unless there is something interesting about the call site.
553 But watch out: if you aren't careful, some useful foldr/build fusion
554 can be lost (most notably in spectral/hartel/parstof) because the
555 foldr didn't see the build. Doing the dynamic allocation isn't a big
556 deal, in fact, but losing the fusion can be. But the right thing here
557 seems to be to do a callSiteInline based on the fact that there is
558 something interesting about the call site (it's strict). Hmm. That
561 Conclusion: inline top level things gaily until Phase 0 (the last
562 phase), at which point don't.
565 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
566 preInlineUnconditionally env top_lvl bndr
567 | isTopLevel top_lvl, SimplPhase 0 <- phase = False
568 -- If we don't have this test, consider
569 -- x = length [1,2,3]
570 -- The full laziness pass carefully floats all the cons cells to
571 -- top level, and preInlineUnconditionally floats them all back in.
572 -- Result is (a) static allocation replaced by dynamic allocation
573 -- (b) many simplifier iterations because this tickles
574 -- a related problem; only one inlining per pass
576 -- On the other hand, I have seen cases where top-level fusion is
577 -- lost if we don't inline top level thing (e.g. string constants)
578 -- Hence the test for phase zero (which is the phase for all the final
579 -- simplifications). Until phase zero we take no special notice of
580 -- top level things, but then we become more leery about inlining
584 | opt_SimplNoPreInlining = False
585 | otherwise = case idOccInfo bndr of
586 IAmDead -> True -- Happens in ((\x.1) v)
587 OneOcc in_lam once -> not in_lam && once
588 -- Not inside a lambda, one occurrence ==> safe!
592 active = case phase of
593 SimplGently -> isAlwaysActive prag
594 SimplPhase n -> isActive n prag
595 prag = idInlinePragma bndr
598 postInlineUnconditionally
599 ~~~~~~~~~~~~~~~~~~~~~~~~~
600 @postInlineUnconditionally@ decides whether to unconditionally inline
601 a thing based on the form of its RHS; in particular if it has a
602 trivial RHS. If so, we can inline and discard the binding altogether.
604 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
605 only have *forward* references Hence, it's safe to discard the binding
607 NOTE: This isn't our last opportunity to inline. We're at the binding
608 site right now, and we'll get another opportunity when we get to the
611 Note that we do this unconditional inlining only for trival RHSs.
612 Don't inline even WHNFs inside lambdas; doing so may simply increase
613 allocation when the function is called. This isn't the last chance; see
616 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
617 Because we don't even want to inline them into the RHS of constructor
618 arguments. See NOTE above
620 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
621 it's best to inline it anyway. We often get a=E; b=a from desugaring,
622 with both a and b marked NOINLINE. But that seems incompatible with
623 our new view that inlining is like a RULE, so I'm sticking to the 'active'
627 postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
628 postInlineUnconditionally env bndr occ_info rhs
631 && not (isLoopBreaker occ_info)
632 && not (isExportedId bndr)
633 -- We used to have (isOneOcc occ_info) instead of
634 -- not (isLoopBreaker occ_info) && not (isExportedId bndr)
635 -- That was because a rather fragile use of rules got confused
636 -- if you inlined even a binding f=g e.g. We used to have
638 -- But now a more precise use of phases has eliminated this problem,
639 -- so the is_active test will do the job. I think.
641 -- OLD COMMENT: (delete soon)
642 -- Indeed, you might suppose that
643 -- there is nothing wrong with substituting for a trivial RHS, even
644 -- if it occurs many times. But consider
646 -- h = _inline_me_ (...x...)
647 -- Here we do *not* want to have x inlined, even though the RHS is
648 -- trivial, becuase the contract for an INLINE pragma is "no inlining".
649 -- This is important in the rules for the Prelude
651 active = case getMode env of
652 SimplGently -> isAlwaysActive prag
653 SimplPhase n -> isActive n prag
654 prag = idInlinePragma bndr
656 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
657 activeInline env id occ
658 = case getMode env of
659 SimplGently -> isOneOcc occ && isAlwaysActive prag
660 -- No inlining at all when doing gentle stuff,
661 -- except for local things that occur once
662 -- The reason is that too little clean-up happens if you
663 -- don't inline use-once things. Also a bit of inlining is *good* for
664 -- full laziness; it can expose constant sub-expressions.
665 -- Example in spectral/mandel/Mandel.hs, where the mandelset
666 -- function gets a useful let-float if you inline windowToViewport
668 -- NB: we used to have a second exception, for data con wrappers.
669 -- On the grounds that we use gentle mode for rule LHSs, and
670 -- they match better when data con wrappers are inlined.
671 -- But that only really applies to the trivial wrappers (like (:)),
672 -- and they are now constructed as Compulsory unfoldings (in MkId)
673 -- so they'll happen anyway.
675 SimplPhase n -> isActive n prag
677 prag = idInlinePragma id
679 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
680 -- Nothing => No rules at all
682 | opt_RulesOff = Nothing
684 = case getMode env of
685 SimplGently -> Just isAlwaysActive
686 -- Used to be Nothing (no rules in gentle mode)
687 -- Main motivation for changing is that I wanted
688 -- lift String ===> ...
689 -- to work in Template Haskell when simplifying
690 -- splices, so we get simpler code for literal strings
691 SimplPhase n -> Just (isActive n)
695 %************************************************************************
697 \subsection{Rebuilding a lambda}
699 %************************************************************************
702 mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
706 a) eta reduction, if that gives a trivial expression
707 b) eta expansion [only if there are some value lambdas]
708 c) floating lets out through big lambdas
709 [only if all tyvar lambdas, and only if this lambda
713 mkLam env bndrs body cont
714 = getDOptsSmpl `thenSmpl` \dflags ->
715 mkLam' dflags env bndrs body cont
717 mkLam' dflags env bndrs body cont
718 | dopt Opt_DoEtaReduction dflags,
719 Just etad_lam <- tryEtaReduce bndrs body
720 = tick (EtaReduction (head bndrs)) `thenSmpl_`
721 returnSmpl (emptyFloats env, etad_lam)
723 | dopt Opt_DoLambdaEtaExpansion dflags,
724 any isRuntimeVar bndrs
725 = tryEtaExpansion body `thenSmpl` \ body' ->
726 returnSmpl (emptyFloats env, mkLams bndrs body')
728 {- Sept 01: I'm experimenting with getting the
729 full laziness pass to float out past big lambdsa
730 | all isTyVar bndrs, -- Only for big lambdas
731 contIsRhs cont -- Only try the rhs type-lambda floating
732 -- if this is indeed a right-hand side; otherwise
733 -- we end up floating the thing out, only for float-in
734 -- to float it right back in again!
735 = tryRhsTyLam env bndrs body `thenSmpl` \ (floats, body') ->
736 returnSmpl (floats, mkLams bndrs body')
740 = returnSmpl (emptyFloats env, mkLams bndrs body)
744 %************************************************************************
746 \subsection{Eta expansion and reduction}
748 %************************************************************************
750 We try for eta reduction here, but *only* if we get all the
751 way to an exprIsTrivial expression.
752 We don't want to remove extra lambdas unless we are going
753 to avoid allocating this thing altogether
756 tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr
757 tryEtaReduce bndrs body
758 -- We don't use CoreUtils.etaReduce, because we can be more
760 -- (a) we already have the binders
761 -- (b) we can do the triviality test before computing the free vars
762 = go (reverse bndrs) body
764 go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
765 go [] fun | ok_fun fun = Just fun -- Success!
766 go _ _ = Nothing -- Failure!
768 ok_fun fun = exprIsTrivial fun
769 && not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
770 && (exprIsValue fun || all ok_lam bndrs)
771 ok_lam v = isTyVar v || isDictTy (idType v)
772 -- The exprIsValue is because eta reduction is not
773 -- valid in general: \x. bot /= bot
774 -- So we need to be sure that the "fun" is a value.
776 -- However, we always want to reduce (/\a -> f a) to f
777 -- This came up in a RULE: foldr (build (/\a -> g a))
778 -- did not match foldr (build (/\b -> ...something complex...))
779 -- The type checker can insert these eta-expanded versions,
780 -- with both type and dictionary lambdas; hence the slightly
783 ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
787 Try eta expansion for RHSs
790 f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
793 where (in both cases)
795 * The xi can include type variables
797 * The yi are all value variables
799 * N is a NORMAL FORM (i.e. no redexes anywhere)
800 wanting a suitable number of extra args.
802 We may have to sandwich some coerces between the lambdas
803 to make the types work. exprEtaExpandArity looks through coerces
804 when computing arity; and etaExpand adds the coerces as necessary when
805 actually computing the expansion.
808 tryEtaExpansion :: OutExpr -> SimplM OutExpr
809 -- There is at least one runtime binder in the binders
811 = getUniquesSmpl `thenSmpl` \ us ->
812 returnSmpl (etaExpand fun_arity us body (exprType body))
814 fun_arity = exprEtaExpandArity body
818 %************************************************************************
820 \subsection{Floating lets out of big lambdas}
822 %************************************************************************
824 tryRhsTyLam tries this transformation, when the big lambda appears as
825 the RHS of a let(rec) binding:
827 /\abc -> let(rec) x = e in b
829 let(rec) x' = /\abc -> let x = x' a b c in e
831 /\abc -> let x = x' a b c in b
833 This is good because it can turn things like:
835 let f = /\a -> letrec g = ... g ... in g
837 letrec g' = /\a -> ... g' a ...
841 which is better. In effect, it means that big lambdas don't impede
844 This optimisation is CRUCIAL in eliminating the junk introduced by
845 desugaring mutually recursive definitions. Don't eliminate it lightly!
847 So far as the implementation is concerned:
849 Invariant: go F e = /\tvs -> F e
853 = Let x' = /\tvs -> F e
857 G = F . Let x = x' tvs
859 go F (Letrec xi=ei in b)
860 = Letrec {xi' = /\tvs -> G ei}
864 G = F . Let {xi = xi' tvs}
866 [May 1999] If we do this transformation *regardless* then we can
867 end up with some pretty silly stuff. For example,
870 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
875 st = /\s -> ...[y1 s/x1, y2 s/x2]
878 Unless the "..." is a WHNF there is really no point in doing this.
879 Indeed it can make things worse. Suppose x1 is used strictly,
882 x1* = case f y of { (a,b) -> e }
884 If we abstract this wrt the tyvar we then can't do the case inline
885 as we would normally do.
889 {- Trying to do this in full laziness
891 tryRhsTyLam :: SimplEnv -> [OutTyVar] -> OutExpr -> SimplM FloatsWithExpr
892 -- Call ensures that all the binders are type variables
894 tryRhsTyLam env tyvars body -- Only does something if there's a let
895 | not (all isTyVar tyvars)
896 || not (worth_it body) -- inside a type lambda,
897 = returnSmpl (emptyFloats env, body) -- and a WHNF inside that
900 = go env (\x -> x) body
903 worth_it e@(Let _ _) = whnf_in_middle e
906 whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
907 whnf_in_middle (Let _ e) = whnf_in_middle e
908 whnf_in_middle e = exprIsCheap e
910 main_tyvar_set = mkVarSet tyvars
912 go env fn (Let bind@(NonRec var rhs) body)
914 = go env (fn . Let bind) body
916 go env fn (Let (NonRec var rhs) body)
917 = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
918 addAuxiliaryBind env (NonRec var' (mkLams tyvars_here (fn rhs))) $ \ env ->
919 go env (fn . Let (mk_silly_bind var rhs')) body
923 tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprSomeFreeVars isTyVar rhs)
924 -- Abstract only over the type variables free in the rhs
925 -- wrt which the new binding is abstracted. But the naive
926 -- approach of abstract wrt the tyvars free in the Id's type
928 -- /\ a b -> let t :: (a,b) = (e1, e2)
931 -- Here, b isn't free in x's type, but we must nevertheless
932 -- abstract wrt b as well, because t's type mentions b.
933 -- Since t is floated too, we'd end up with the bogus:
934 -- poly_t = /\ a b -> (e1, e2)
935 -- poly_x = /\ a -> fst (poly_t a *b*)
936 -- So for now we adopt the even more naive approach of
937 -- abstracting wrt *all* the tyvars. We'll see if that
938 -- gives rise to problems. SLPJ June 98
940 go env fn (Let (Rec prs) body)
941 = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
943 gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
944 pairs = vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]
946 addAuxiliaryBind env (Rec pairs) $ \ env ->
949 (vars,rhss) = unzip prs
950 tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprsSomeFreeVars isTyVar (map snd prs))
951 -- See notes with tyvars_here above
953 go env fn body = returnSmpl (emptyFloats env, fn body)
955 mk_poly tyvars_here var
956 = getUniqueSmpl `thenSmpl` \ uniq ->
958 poly_name = setNameUnique (idName var) uniq -- Keep same name
959 poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
960 poly_id = mkLocalId poly_name poly_ty
962 -- In the olden days, it was crucial to copy the occInfo of the original var,
963 -- because we were looking at occurrence-analysed but as yet unsimplified code!
964 -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking
965 -- at already simplified code, so it doesn't matter
967 -- It's even right to retain single-occurrence or dead-var info:
968 -- Suppose we started with /\a -> let x = E in B
969 -- where x occurs once in B. Then we transform to:
970 -- let x' = /\a -> E in /\a -> let x* = x' a in B
971 -- where x* has an INLINE prag on it. Now, once x* is inlined,
972 -- the occurrences of x' will be just the occurrences originally
975 returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
977 mk_silly_bind var rhs = NonRec var (Note InlineMe rhs)
978 -- Suppose we start with:
980 -- x = /\ a -> let g = G in E
982 -- Then we'll float to get
984 -- x = let poly_g = /\ a -> G
985 -- in /\ a -> let g = poly_g a in E
987 -- But now the occurrence analyser will see just one occurrence
988 -- of poly_g, not inside a lambda, so the simplifier will
989 -- PreInlineUnconditionally poly_g back into g! Badk to square 1!
990 -- (I used to think that the "don't inline lone occurrences" stuff
991 -- would stop this happening, but since it's the *only* occurrence,
992 -- PreInlineUnconditionally kicks in first!)
994 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
995 -- to appear many times. (NB: mkInlineMe eliminates
996 -- such notes on trivial RHSs, so do it manually.)
1000 %************************************************************************
1002 \subsection{Case alternative filtering
1004 %************************************************************************
1006 prepareAlts does two things:
1008 1. Eliminate alternatives that cannot match, including the
1009 DEFAULT alternative.
1011 2. If the DEFAULT alternative can match only one possible constructor,
1012 then make that constructor explicit.
1014 case e of x { DEFAULT -> rhs }
1016 case e of x { (a,b) -> rhs }
1017 where the type is a single constructor type. This gives better code
1018 when rhs also scrutinises x or e.
1020 It's a good idea do do this stuff before simplifying the alternatives, to
1021 avoid simplifying alternatives we know can't happen, and to come up with
1022 the list of constructors that are handled, to put into the IdInfo of the
1023 case binder, for use when simplifying the alternatives.
1025 Eliminating the default alternative in (1) isn't so obvious, but it can
1028 data Colour = Red | Green | Blue
1037 DEFAULT -> [ case y of ... ]
1039 If we inline h into f, the default case of the inlined h can't happen.
1040 If we don't notice this, we may end up filtering out *all* the cases
1041 of the inner case y, which give us nowhere to go!
1045 prepareAlts :: OutExpr -- Scrutinee
1046 -> InId -- Case binder
1047 -> [InAlt] -- Increasing order
1048 -> SimplM ([InAlt], -- Better alternatives, still incresaing order
1049 [AltCon]) -- These cases are handled
1051 prepareAlts scrut case_bndr alts
1053 (alts_wo_default, maybe_deflt) = findDefault alts
1055 impossible_cons = case scrut of
1056 Var v -> otherCons (idUnfolding v)
1059 -- Filter out alternatives that can't possibly match
1060 better_alts | null impossible_cons = alts_wo_default
1061 | otherwise = [alt | alt@(con,_,_) <- alts_wo_default,
1062 not (con `elem` impossible_cons)]
1064 -- "handled_cons" are handled either by the context,
1065 -- or by a branch in this case expression
1066 -- (Don't add DEFAULT to the handled_cons!!)
1067 handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
1069 -- Filter out the default, if it can't happen,
1070 -- or replace it with "proper" alternative if there
1071 -- is only one constructor left
1072 prepareDefault case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
1074 returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
1075 -- We need the mergeAlts in case the new default_alt
1076 -- has turned into a constructor alternative.
1078 prepareDefault case_bndr handled_cons (Just rhs)
1079 | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
1080 isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
1081 not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
1082 -- case x of { DEFAULT -> e }
1083 -- and we don't want to fill in a default for them!
1084 Just all_cons <- tyConDataCons_maybe tycon,
1085 not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
1086 -- which GHC allows, then the case expression will have at most a default
1087 -- alternative. We don't want to eliminate that alternative, because the
1088 -- invariant is that there's always one alternative. It's more convenient
1090 -- case x of { DEFAULT -> e }
1091 -- as it is, rather than transform it to
1092 -- error "case cant match"
1093 -- which would be quite legitmate. But it's a really obscure corner, and
1094 -- not worth wasting code on.
1095 let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
1096 let missing_cons = [con | con <- all_cons,
1097 not (con `elem` handled_data_cons)]
1098 = case missing_cons of
1099 [] -> returnSmpl [] -- Eliminate the default alternative
1100 -- if it can't match
1102 [con] -> -- It matches exactly one constructor, so fill it in
1103 tick (FillInCaseDefault case_bndr) `thenSmpl_`
1104 mk_args con inst_tys `thenSmpl` \ args ->
1105 returnSmpl [(DataAlt con, args, rhs)]
1107 two_or_more -> returnSmpl [(DEFAULT, [], rhs)]
1110 = returnSmpl [(DEFAULT, [], rhs)]
1112 prepareDefault case_bndr handled_cons Nothing
1115 mk_args missing_con inst_tys
1116 = mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
1117 getUniquesSmpl `thenSmpl` \ id_uniqs ->
1118 let arg_tys = dataConArgTys missing_con inst_tys'
1119 arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
1121 returnSmpl (tv_bndrs ++ arg_ids)
1123 mk_tv_bndrs missing_con inst_tys
1124 | isVanillaDataCon missing_con
1125 = returnSmpl ([], inst_tys)
1127 = getUniquesSmpl `thenSmpl` \ tv_uniqs ->
1128 let new_tvs = zipWith mk tv_uniqs (dataConTyVars missing_con)
1129 mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
1131 returnSmpl (new_tvs, mkTyVarTys new_tvs)
1135 %************************************************************************
1137 \subsection{Case absorption and identity-case elimination}
1139 %************************************************************************
1141 mkCase puts a case expression back together, trying various transformations first.
1144 mkCase :: OutExpr -> OutId -> OutType
1145 -> [OutAlt] -- Increasing order
1148 mkCase scrut case_bndr ty alts
1149 = getDOptsSmpl `thenSmpl` \dflags ->
1150 mkAlts dflags scrut case_bndr alts `thenSmpl` \ better_alts ->
1151 mkCase1 scrut case_bndr ty better_alts
1155 mkAlts tries these things:
1157 1. If several alternatives are identical, merge them into
1158 a single DEFAULT alternative. I've occasionally seen this
1159 making a big difference:
1161 case e of =====> case e of
1162 C _ -> f x D v -> ....v....
1163 D v -> ....v.... DEFAULT -> f x
1166 The point is that we merge common RHSs, at least for the DEFAULT case.
1167 [One could do something more elaborate but I've never seen it needed.]
1168 To avoid an expensive test, we just merge branches equal to the *first*
1169 alternative; this picks up the common cases
1170 a) all branches equal
1171 b) some branches equal to the DEFAULT (which occurs first)
1174 case e of b { ==> case e of b {
1175 p1 -> rhs1 p1 -> rhs1
1177 pm -> rhsm pm -> rhsm
1178 _ -> case b of b' { pn -> let b'=b in rhsn
1180 ... po -> let b'=b in rhso
1181 po -> rhso _ -> let b'=b in rhsd
1185 which merges two cases in one case when -- the default alternative of
1186 the outer case scrutises the same variable as the outer case This
1187 transformation is called Case Merging. It avoids that the same
1188 variable is scrutinised multiple times.
1191 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
1197 where @is@ was something like
1199 p `is` n = p /= (-1) && p == n
1201 This gave rise to a horrible sequence of cases
1208 and similarly in cascade for all the join points!
1213 --------------------------------------------------
1214 -- 1. Merge identical branches
1215 --------------------------------------------------
1216 mkAlts dflags scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
1217 | all isDeadBinder bndrs1, -- Remember the default
1218 length filtered_alts < length con_alts -- alternative comes first
1219 = tick (AltMerge case_bndr) `thenSmpl_`
1220 returnSmpl better_alts
1222 filtered_alts = filter keep con_alts
1223 keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
1224 better_alts = (DEFAULT, [], rhs1) : filtered_alts
1227 --------------------------------------------------
1228 -- 2. Merge nested cases
1229 --------------------------------------------------
1231 mkAlts dflags scrut outer_bndr outer_alts
1232 | dopt Opt_CaseMerge dflags,
1233 (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
1234 Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt,
1235 scruting_same_var scrut_var
1237 munged_inner_alts = [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts]
1238 munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
1240 new_alts = mergeAlts outer_alts_without_deflt munged_inner_alts
1241 -- The merge keeps the inner DEFAULT at the front, if there is one
1242 -- and eliminates any inner_alts that are shadowed by the outer_alts
1244 tick (CaseMerge outer_bndr) `thenSmpl_`
1246 -- Warning: don't call mkAlts recursively!
1247 -- Firstly, there's no point, because inner alts have already had
1248 -- mkCase applied to them, so they won't have a case in their default
1249 -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
1250 -- in munge_rhs may put a case into the DEFAULT branch!
1252 -- We are scrutinising the same variable if it's
1253 -- the outer case-binder, or if the outer case scrutinises a variable
1254 -- (and it's the same). Testing both allows us not to replace the
1255 -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
1256 scruting_same_var = case scrut of
1257 Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
1258 other -> \ v -> v == outer_bndr
1260 ------------------------------------------------
1262 ------------------------------------------------
1264 mkAlts dflags scrut case_bndr other_alts = returnSmpl other_alts
1267 ---------------------------------
1268 mergeAlts :: [OutAlt] -> [OutAlt] -> [OutAlt]
1269 -- Merge preserving order; alternatives in the first arg
1270 -- shadow ones in the second
1271 mergeAlts [] as2 = as2
1272 mergeAlts as1 [] = as1
1273 mergeAlts (a1:as1) (a2:as2)
1274 = case a1 `cmpAlt` a2 of
1275 LT -> a1 : mergeAlts as1 (a2:as2)
1276 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
1277 GT -> a2 : mergeAlts (a1:as1) as2
1282 =================================================================================
1284 mkCase1 tries these things
1286 1. Eliminate the case altogether if possible
1294 and similar friends.
1297 Start with a simple situation:
1299 case x# of ===> e[x#/y#]
1302 (when x#, y# are of primitive type, of course). We can't (in general)
1303 do this for algebraic cases, because we might turn bottom into
1306 Actually, we generalise this idea to look for a case where we're
1307 scrutinising a variable, and we know that only the default case can
1312 other -> ...(case x of
1316 Here the inner case can be eliminated. This really only shows up in
1317 eliminating error-checking code.
1319 We also make sure that we deal with this very common case:
1324 Here we are using the case as a strict let; if x is used only once
1325 then we want to inline it. We have to be careful that this doesn't
1326 make the program terminate when it would have diverged before, so we
1328 - x is used strictly, or
1329 - e is already evaluated (it may so if e is a variable)
1331 Lastly, we generalise the transformation to handle this:
1337 We only do this for very cheaply compared r's (constructors, literals
1338 and variables). If pedantic bottoms is on, we only do it when the
1339 scrutinee is a PrimOp which can't fail.
1341 We do it *here*, looking at un-simplified alternatives, because we
1342 have to check that r doesn't mention the variables bound by the
1343 pattern in each alternative, so the binder-info is rather useful.
1345 So the case-elimination algorithm is:
1347 1. Eliminate alternatives which can't match
1349 2. Check whether all the remaining alternatives
1350 (a) do not mention in their rhs any of the variables bound in their pattern
1351 and (b) have equal rhss
1353 3. Check we can safely ditch the case:
1354 * PedanticBottoms is off,
1355 or * the scrutinee is an already-evaluated variable
1356 or * the scrutinee is a primop which is ok for speculation
1357 -- ie we want to preserve divide-by-zero errors, and
1358 -- calls to error itself!
1360 or * [Prim cases] the scrutinee is a primitive variable
1362 or * [Alg cases] the scrutinee is a variable and
1363 either * the rhs is the same variable
1364 (eg case x of C a b -> x ===> x)
1365 or * there is only one alternative, the default alternative,
1366 and the binder is used strictly in its scope.
1367 [NB this is helped by the "use default binder where
1368 possible" transformation; see below.]
1371 If so, then we can replace the case with one of the rhss.
1373 Further notes about case elimination
1374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1375 Consider: test :: Integer -> IO ()
1378 Turns out that this compiles to:
1381 eta1 :: State# RealWorld ->
1382 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1384 (PrelNum.jtos eta ($w[] @ Char))
1386 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1388 Notice the strange '<' which has no effect at all. This is a funny one.
1389 It started like this:
1391 f x y = if x < 0 then jtos x
1392 else if y==0 then "" else jtos x
1394 At a particular call site we have (f v 1). So we inline to get
1396 if v < 0 then jtos x
1397 else if 1==0 then "" else jtos x
1399 Now simplify the 1==0 conditional:
1401 if v<0 then jtos v else jtos v
1403 Now common-up the two branches of the case:
1405 case (v<0) of DEFAULT -> jtos v
1407 Why don't we drop the case? Because it's strict in v. It's technically
1408 wrong to drop even unnecessary evaluations, and in practice they
1409 may be a result of 'seq' so we *definitely* don't want to drop those.
1410 I don't really know how to improve this situation.
1414 --------------------------------------------------
1415 -- 0. Check for empty alternatives
1416 --------------------------------------------------
1419 mkCase1 scrut case_bndr ty []
1420 = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
1424 --------------------------------------------------
1425 -- 1. Eliminate the case altogether if poss
1426 --------------------------------------------------
1428 mkCase1 scrut case_bndr ty [(con,bndrs,rhs)]
1429 -- See if we can get rid of the case altogether
1430 -- See the extensive notes on case-elimination above
1431 -- mkCase made sure that if all the alternatives are equal,
1432 -- then there is now only one (DEFAULT) rhs
1433 | all isDeadBinder bndrs,
1435 -- Check that the scrutinee can be let-bound instead of case-bound
1436 exprOkForSpeculation scrut
1437 -- OK not to evaluate it
1438 -- This includes things like (==# a# b#)::Bool
1439 -- so that we simplify
1440 -- case ==# a# b# of { True -> x; False -> x }
1443 -- This particular example shows up in default methods for
1444 -- comparision operations (e.g. in (>=) for Int.Int32)
1445 || exprIsValue scrut -- It's already evaluated
1446 || var_demanded_later scrut -- It'll be demanded later
1448 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1449 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1450 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1451 -- its argument: case x of { y -> dataToTag# y }
1452 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1453 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1455 -- Also we don't want to discard 'seq's
1456 = tick (CaseElim case_bndr) `thenSmpl_`
1457 returnSmpl (bindCaseBndr case_bndr scrut rhs)
1460 -- The case binder is going to be evaluated later,
1461 -- and the scrutinee is a simple variable
1462 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1463 var_demanded_later other = False
1466 --------------------------------------------------
1468 --------------------------------------------------
1470 mkCase1 scrut case_bndr ty alts -- Identity case
1471 | all identity_alt alts
1472 = tick (CaseIdentity case_bndr) `thenSmpl_`
1473 returnSmpl (re_note scrut)
1475 identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
1477 identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
1478 identity_rhs (LitAlt lit) _ = Lit lit
1479 identity_rhs DEFAULT _ = Var case_bndr
1481 arg_tys = map Type (tyConAppArgs (idType case_bndr))
1484 -- case coerce T e of x { _ -> coerce T' x }
1485 -- And we definitely want to eliminate this case!
1486 -- So we throw away notes from the RHS, and reconstruct
1487 -- (at least an approximation) at the other end
1488 de_note (Note _ e) = de_note e
1491 -- re_note wraps a coerce if it might be necessary
1492 re_note scrut = case head alts of
1493 (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
1497 --------------------------------------------------
1499 --------------------------------------------------
1500 mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
1504 When adding auxiliary bindings for the case binder, it's worth checking if
1505 its dead, because it often is, and occasionally these mkCase transformations
1506 cascade rather nicely.
1509 bindCaseBndr bndr rhs body
1510 | isDeadBinder bndr = body
1511 | otherwise = bindNonRec bndr rhs body