compiler: de-lhs simplCore/
[ghc.git] / compiler / simplCore / Simplify.hs
1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
3
4 \section[Simplify]{The main module of the simplifier}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module Simplify ( simplTopBinds, simplExpr ) where
10
11 #include "HsVersions.h"
12
13 import DynFlags
14 import SimplMonad
15 import Type hiding ( substTy, extendTvSubst, substTyVar )
16 import SimplEnv
17 import SimplUtils
18 import FamInstEnv ( FamInstEnv )
19 import Literal ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326
20 import Id
21 import MkId ( seqId, voidPrimId )
22 import MkCore ( mkImpossibleExpr, castBottomExpr )
23 import IdInfo
24 import Name ( mkSystemVarName, isExternalName )
25 import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst )
26 import OptCoercion ( optCoercion )
27 import FamInstEnv ( topNormaliseType_maybe )
28 import DataCon ( DataCon, dataConWorkId, dataConRepStrictness
29 , isMarkedStrict ) --, dataConTyCon, dataConTag, fIRST_TAG )
30 --import TyCon ( isEnumerationTyCon ) -- temporalily commented out. See #8326
31 import CoreMonad ( Tick(..), SimplifierMode(..) )
32 import CoreSyn
33 import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd )
34 import PprCore ( pprParendExpr, pprCoreExpr )
35 import CoreUnfold
36 import CoreUtils
37 import CoreArity
38 --import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326
39 import Rules ( lookupRule, getRules )
40 import TysPrim ( voidPrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
41 import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
42 import MonadUtils ( foldlM, mapAccumLM, liftIO )
43 import Maybes ( orElse )
44 --import Unique ( hasKey ) -- temporalily commented out. See #8326
45 import Control.Monad
46 import Data.List ( mapAccumL )
47 import Outputable
48 import FastString
49 import Pair
50 import Util
51 import ErrUtils
52
53 {-
54 The guts of the simplifier is in this module, but the driver loop for
55 the simplifier is in SimplCore.lhs.
56
57
58 -----------------------------------------
59 *** IMPORTANT NOTE ***
60 -----------------------------------------
61 The simplifier used to guarantee that the output had no shadowing, but
62 it does not do so any more. (Actually, it never did!) The reason is
63 documented with simplifyArgs.
64
65
66 -----------------------------------------
67 *** IMPORTANT NOTE ***
68 -----------------------------------------
69 Many parts of the simplifier return a bunch of "floats" as well as an
70 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
71
72 All "floats" are let-binds, not case-binds, but some non-rec lets may
73 be unlifted (with RHS ok-for-speculation).
74
75
76
77 -----------------------------------------
78 ORGANISATION OF FUNCTIONS
79 -----------------------------------------
80 simplTopBinds
81 - simplify all top-level binders
82 - for NonRec, call simplRecOrTopPair
83 - for Rec, call simplRecBind
84
85
86 ------------------------------
87 simplExpr (applied lambda) ==> simplNonRecBind
88 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
89 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
90
91 ------------------------------
92 simplRecBind [binders already simplfied]
93 - use simplRecOrTopPair on each pair in turn
94
95 simplRecOrTopPair [binder already simplified]
96 Used for: recursive bindings (top level and nested)
97 top-level non-recursive bindings
98 Returns:
99 - check for PreInlineUnconditionally
100 - simplLazyBind
101
102 simplNonRecBind
103 Used for: non-top-level non-recursive bindings
104 beta reductions (which amount to the same thing)
105 Because it can deal with strict arts, it takes a
106 "thing-inside" and returns an expression
107
108 - check for PreInlineUnconditionally
109 - simplify binder, including its IdInfo
110 - if strict binding
111 simplStrictArg
112 mkAtomicArgs
113 completeNonRecX
114 else
115 simplLazyBind
116 addFloats
117
118 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
119 Used for: binding case-binder and constr args in a known-constructor case
120 - check for PreInLineUnconditionally
121 - simplify binder
122 - completeNonRecX
123
124 ------------------------------
125 simplLazyBind: [binder already simplified, RHS not]
126 Used for: recursive bindings (top level and nested)
127 top-level non-recursive bindings
128 non-top-level, but *lazy* non-recursive bindings
129 [must not be strict or unboxed]
130 Returns floats + an augmented environment, not an expression
131 - substituteIdInfo and add result to in-scope
132 [so that rules are available in rec rhs]
133 - simplify rhs
134 - mkAtomicArgs
135 - float if exposes constructor or PAP
136 - completeBind
137
138
139 completeNonRecX: [binder and rhs both simplified]
140 - if the the thing needs case binding (unlifted and not ok-for-spec)
141 build a Case
142 else
143 completeBind
144 addFloats
145
146 completeBind: [given a simplified RHS]
147 [used for both rec and non-rec bindings, top level and not]
148 - try PostInlineUnconditionally
149 - add unfolding [this is the only place we add an unfolding]
150 - add arity
151
152
153
154 Right hand sides and arguments
155 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156 In many ways we want to treat
157 (a) the right hand side of a let(rec), and
158 (b) a function argument
159 in the same way. But not always! In particular, we would
160 like to leave these arguments exactly as they are, so they
161 will match a RULE more easily.
162
163 f (g x, h x)
164 g (+ x)
165
166 It's harder to make the rule match if we ANF-ise the constructor,
167 or eta-expand the PAP:
168
169 f (let { a = g x; b = h x } in (a,b))
170 g (\y. + x y)
171
172 On the other hand if we see the let-defns
173
174 p = (g x, h x)
175 q = + x
176
177 then we *do* want to ANF-ise and eta-expand, so that p and q
178 can be safely inlined.
179
180 Even floating lets out is a bit dubious. For let RHS's we float lets
181 out if that exposes a value, so that the value can be inlined more vigorously.
182 For example
183
184 r = let x = e in (x,x)
185
186 Here, if we float the let out we'll expose a nice constructor. We did experiments
187 that showed this to be a generally good thing. But it was a bad thing to float
188 lets out unconditionally, because that meant they got allocated more often.
189
190 For function arguments, there's less reason to expose a constructor (it won't
191 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
192 So for the moment we don't float lets out of function arguments either.
193
194
195 Eta expansion
196 ~~~~~~~~~~~~~~
197 For eta expansion, we want to catch things like
198
199 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
200
201 If the \x was on the RHS of a let, we'd eta expand to bring the two
202 lambdas together. And in general that's a good thing to do. Perhaps
203 we should eta expand wherever we find a (value) lambda? Then the eta
204 expansion at a let RHS can concentrate solely on the PAP case.
205
206
207 ************************************************************************
208 * *
209 \subsection{Bindings}
210 * *
211 ************************************************************************
212 -}
213
214 simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
215
216 simplTopBinds env0 binds0
217 = do { -- Put all the top-level binders into scope at the start
218 -- so that if a transformation rule has unexpectedly brought
219 -- anything into scope, then we don't get a complaint about that.
220 -- It's rather as if the top-level binders were imported.
221 -- See note [Glomming] in OccurAnal.
222 ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
223 ; env2 <- simpl_binds env1 binds0
224 ; freeTick SimplifierDone
225 ; return env2 }
226 where
227 -- We need to track the zapped top-level binders, because
228 -- they should have their fragile IdInfo zapped (notably occurrence info)
229 -- That's why we run down binds and bndrs' simultaneously.
230 --
231 simpl_binds :: SimplEnv -> [InBind] -> SimplM SimplEnv
232 simpl_binds env [] = return env
233 simpl_binds env (bind:binds) = do { env' <- simpl_bind env bind
234 ; simpl_binds env' binds }
235
236 simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
237 simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
238 where
239 (env', b') = addBndrRules env b (lookupRecBndr env b)
240
241 {-
242 ************************************************************************
243 * *
244 \subsection{Lazy bindings}
245 * *
246 ************************************************************************
247
248 simplRecBind is used for
249 * recursive bindings only
250 -}
251
252 simplRecBind :: SimplEnv -> TopLevelFlag
253 -> [(InId, InExpr)]
254 -> SimplM SimplEnv
255 simplRecBind env0 top_lvl pairs0
256 = do { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
257 ; env1 <- go (zapFloats env_with_info) triples
258 ; return (env0 `addRecFloats` env1) }
259 -- addFloats adds the floats from env1,
260 -- _and_ updates env0 with the in-scope set from env1
261 where
262 add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
263 -- Add the (substituted) rules to the binder
264 add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
265 where
266 (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
267
268 go env [] = return env
269
270 go env ((old_bndr, new_bndr, rhs) : pairs)
271 = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
272 ; go env' pairs }
273
274 {-
275 simplOrTopPair is used for
276 * recursive bindings (whether top level or not)
277 * top-level non-recursive bindings
278
279 It assumes the binder has already been simplified, but not its IdInfo.
280 -}
281
282 simplRecOrTopPair :: SimplEnv
283 -> TopLevelFlag -> RecFlag
284 -> InId -> OutBndr -> InExpr -- Binder and rhs
285 -> SimplM SimplEnv -- Returns an env that includes the binding
286
287 simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
288 = do { dflags <- getDynFlags
289 ; trace_bind dflags $
290 if preInlineUnconditionally dflags env top_lvl old_bndr rhs
291 -- Check for unconditional inline
292 then do tick (PreInlineUnconditionally old_bndr)
293 return (extendIdSubst env old_bndr (mkContEx env rhs))
294 else simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env }
295 where
296 trace_bind dflags thing_inside
297 | not (dopt Opt_D_verbose_core2core dflags)
298 = thing_inside
299 | otherwise
300 = pprTrace "SimplBind" (ppr old_bndr) thing_inside
301 -- trace_bind emits a trace for each top-level binding, which
302 -- helps to locate the tracing for inlining and rule firing
303
304 {-
305 simplLazyBind is used for
306 * [simplRecOrTopPair] recursive bindings (whether top level or not)
307 * [simplRecOrTopPair] top-level non-recursive bindings
308 * [simplNonRecE] non-top-level *lazy* non-recursive bindings
309
310 Nota bene:
311 1. It assumes that the binder is *already* simplified,
312 and is in scope, and its IdInfo too, except unfolding
313
314 2. It assumes that the binder type is lifted.
315
316 3. It does not check for pre-inline-unconditionally;
317 that should have been done already.
318 -}
319
320 simplLazyBind :: SimplEnv
321 -> TopLevelFlag -> RecFlag
322 -> InId -> OutId -- Binder, both pre-and post simpl
323 -- The OutId has IdInfo, except arity, unfolding
324 -> InExpr -> SimplEnv -- The RHS and its environment
325 -> SimplM SimplEnv
326 -- Precondition: rhs obeys the let/app invariant
327 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
328 = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
329 do { let rhs_env = rhs_se `setInScope` env
330 (tvs, body) = case collectTyBinders rhs of
331 (tvs, body) | not_lam body -> (tvs,body)
332 | otherwise -> ([], rhs)
333 not_lam (Lam _ _) = False
334 not_lam _ = True
335 -- Do not do the "abstract tyyvar" thing if there's
336 -- a lambda inside, because it defeats eta-reduction
337 -- f = /\a. \x. g a x
338 -- should eta-reduce
339
340
341 ; (body_env, tvs') <- simplBinders rhs_env tvs
342 -- See Note [Floating and type abstraction] in SimplUtils
343
344 -- Simplify the RHS
345 ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))
346 ; (body_env1, body1) <- simplExprF body_env body rhs_cont
347 -- ANF-ise a constructor or PAP rhs
348 ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
349
350 ; (env', rhs')
351 <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
352 then -- No floating, revert to body1
353 do { rhs' <- mkLam tvs' (wrapFloats body_env1 body1) rhs_cont
354 ; return (env, rhs') }
355
356 else if null tvs then -- Simple floating
357 do { tick LetFloatFromLet
358 ; return (addFloats env body_env2, body2) }
359
360 else -- Do type-abstraction first
361 do { tick LetFloatFromLet
362 ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
363 ; rhs' <- mkLam tvs' body3 rhs_cont
364 ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
365 ; return (env', rhs') }
366
367 ; completeBind env' top_lvl bndr bndr1 rhs' }
368
369 {-
370 A specialised variant of simplNonRec used when the RHS is already simplified,
371 notably in knownCon. It uses case-binding where necessary.
372 -}
373
374 simplNonRecX :: SimplEnv
375 -> InId -- Old binder
376 -> OutExpr -- Simplified RHS
377 -> SimplM SimplEnv
378 -- Precondition: rhs satisfies the let/app invariant
379 simplNonRecX env bndr new_rhs
380 | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
381 = return env -- Here c is dead, and we avoid creating
382 -- the binding c = (a,b)
383
384 | Coercion co <- new_rhs
385 = return (extendCvSubst env bndr co)
386
387 | otherwise
388 = do { (env', bndr') <- simplBinder env bndr
389 ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
390 -- simplNonRecX is only used for NotTopLevel things
391
392 completeNonRecX :: TopLevelFlag -> SimplEnv
393 -> Bool
394 -> InId -- Old binder
395 -> OutId -- New binder
396 -> OutExpr -- Simplified RHS
397 -> SimplM SimplEnv
398 -- Precondition: rhs satisfies the let/app invariant
399 -- See Note [CoreSyn let/app invariant] in CoreSyn
400
401 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
402 = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
403 ; (env2, rhs2) <-
404 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
405 then do { tick LetFloatFromLet
406 ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
407 else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
408 ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
409
410 {-
411 {- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
412 Doing so risks exponential behaviour, because new_rhs has been simplified once already
413 In the cases described by the folowing commment, postInlineUnconditionally will
414 catch many of the relevant cases.
415 -- This happens; for example, the case_bndr during case of
416 -- known constructor: case (a,b) of x { (p,q) -> ... }
417 -- Here x isn't mentioned in the RHS, so we don't want to
418 -- create the (dead) let-binding let x = (a,b) in ...
419 --
420 -- Similarly, single occurrences can be inlined vigourously
421 -- e.g. case (f x, g y) of (a,b) -> ....
422 -- If a,b occur once we can avoid constructing the let binding for them.
423
424 Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
425 -- Consider case I# (quotInt# x y) of
426 -- I# v -> let w = J# v in ...
427 -- If we gaily inline (quotInt# x y) for v, we end up building an
428 -- extra thunk:
429 -- let w = J# (quotInt# x y) in ...
430 -- because quotInt# can fail.
431
432 | preInlineUnconditionally env NotTopLevel bndr new_rhs
433 = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
434 -}
435
436 ----------------------------------
437 prepareRhs takes a putative RHS, checks whether it's a PAP or
438 constructor application and, if so, converts it to ANF, so that the
439 resulting thing can be inlined more easily. Thus
440 x = (f a, g b)
441 becomes
442 t1 = f a
443 t2 = g b
444 x = (t1,t2)
445
446 We also want to deal well cases like this
447 v = (f e1 `cast` co) e2
448 Here we want to make e1,e2 trivial and get
449 x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
450 That's what the 'go' loop in prepareRhs does
451 -}
452
453 prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
454 -- Adds new floats to the env iff that allows us to return a good RHS
455 prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions]
456 | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type
457 , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
458 = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
459 ; return (env', Cast rhs' co) }
460 where
461 sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
462 `setDemandInfo` demandInfo info
463 info = idInfo id
464
465 prepareRhs top_lvl env0 _ rhs0
466 = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
467 ; return (env1, rhs1) }
468 where
469 go n_val_args env (Cast rhs co)
470 = do { (is_exp, env', rhs') <- go n_val_args env rhs
471 ; return (is_exp, env', Cast rhs' co) }
472 go n_val_args env (App fun (Type ty))
473 = do { (is_exp, env', rhs') <- go n_val_args env fun
474 ; return (is_exp, env', App rhs' (Type ty)) }
475 go n_val_args env (App fun arg)
476 = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
477 ; case is_exp of
478 True -> do { (env'', arg') <- makeTrivial top_lvl env' arg
479 ; return (True, env'', App fun' arg') }
480 False -> return (False, env, App fun arg) }
481 go n_val_args env (Var fun)
482 = return (is_exp, env, Var fun)
483 where
484 is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP
485 -- See Note [CONLIKE pragma] in BasicTypes
486 -- The definition of is_exp should match that in
487 -- OccurAnal.occAnalApp
488
489 go _ env other
490 = return (False, env, other)
491
492 {-
493 Note [Float coercions]
494 ~~~~~~~~~~~~~~~~~~~~~~
495 When we find the binding
496 x = e `cast` co
497 we'd like to transform it to
498 x' = e
499 x = x `cast` co -- A trivial binding
500 There's a chance that e will be a constructor application or function, or something
501 like that, so moving the coerion to the usage site may well cancel the coersions
502 and lead to further optimisation. Example:
503
504 data family T a :: *
505 data instance T Int = T Int
506
507 foo :: Int -> Int -> Int
508 foo m n = ...
509 where
510 x = T m
511 go 0 = 0
512 go n = case x of { T m -> go (n-m) }
513 -- This case should optimise
514
515 Note [Preserve strictness when floating coercions]
516 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
517 In the Note [Float coercions] transformation, keep the strictness info.
518 Eg
519 f = e `cast` co -- f has strictness SSL
520 When we transform to
521 f' = e -- f' also has strictness SSL
522 f = f' `cast` co -- f still has strictness SSL
523
524 Its not wrong to drop it on the floor, but better to keep it.
525
526 Note [Float coercions (unlifted)]
527 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
528 BUT don't do [Float coercions] if 'e' has an unlifted type.
529 This *can* happen:
530
531 foo :: Int = (error (# Int,Int #) "urk")
532 `cast` CoUnsafe (# Int,Int #) Int
533
534 If do the makeTrivial thing to the error call, we'll get
535 foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
536 But 'v' isn't in scope!
537
538 These strange casts can happen as a result of case-of-case
539 bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
540 (# p,q #) -> p+q
541 -}
542
543 makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)
544 makeTrivialArg env (ValArg e) = do { (env', e') <- makeTrivial NotTopLevel env e
545 ; return (env', ValArg e') }
546 makeTrivialArg env (CastBy co) = return (env, CastBy co)
547
548 makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
549 -- Binds the expression to a variable, if it's not trivial, returning the variable
550 makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr
551
552 makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo
553 -> OutExpr -> SimplM (SimplEnv, OutExpr)
554 -- Propagate strictness and demand info to the new binder
555 -- Note [Preserve strictness when floating coercions]
556 -- Returned SimplEnv has same substitution as incoming one
557 makeTrivialWithInfo top_lvl env info expr
558 | exprIsTrivial expr -- Already trivial
559 || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise
560 -- See Note [Cannot trivialise]
561 = return (env, expr)
562 | otherwise -- See Note [Take care] below
563 = do { uniq <- getUniqueM
564 ; let name = mkSystemVarName uniq (fsLit "a")
565 var = mkLocalIdWithInfo name expr_ty info
566 ; env' <- completeNonRecX top_lvl env False var var expr
567 ; expr' <- simplVar env' var
568 ; return (env', expr') }
569 -- The simplVar is needed becase we're constructing a new binding
570 -- a = rhs
571 -- And if rhs is of form (rhs1 |> co), then we might get
572 -- a1 = rhs1
573 -- a = a1 |> co
574 -- and now a's RHS is trivial and can be substituted out, and that
575 -- is what completeNonRecX will do
576 -- To put it another way, it's as if we'd simplified
577 -- let var = e in var
578 where
579 expr_ty = exprType expr
580
581 bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
582 -- True iff we can have a binding of this expression at this level
583 -- Precondition: the type is the type of the expression
584 bindingOk top_lvl _ expr_ty
585 | isTopLevel top_lvl = not (isUnLiftedType expr_ty)
586 | otherwise = True
587
588 {-
589 Note [Cannot trivialise]
590 ~~~~~~~~~~~~~~~~~~~~~~~~
591 Consider tih
592 f :: Int -> Addr#
593
594 foo :: Bar
595 foo = Bar (f 3)
596
597 Then we can't ANF-ise foo, even though we'd like to, because
598 we can't make a top-level binding for the Addr# (f 3). And if
599 so we don't want to turn it into
600 foo = let x = f 3 in Bar x
601 because we'll just end up inlining x back, and that makes the
602 simplifier loop. Better not to ANF-ise it at all.
603
604 A case in point is literal strings (a MachStr is not regarded as
605 trivial):
606
607 foo = Ptr "blob"#
608
609 We don't want to ANF-ise this.
610
611 ************************************************************************
612 * *
613 \subsection{Completing a lazy binding}
614 * *
615 ************************************************************************
616
617 completeBind
618 * deals only with Ids, not TyVars
619 * takes an already-simplified binder and RHS
620 * is used for both recursive and non-recursive bindings
621 * is used for both top-level and non-top-level bindings
622
623 It does the following:
624 - tries discarding a dead binding
625 - tries PostInlineUnconditionally
626 - add unfolding [this is the only place we add an unfolding]
627 - add arity
628
629 It does *not* attempt to do let-to-case. Why? Because it is used for
630 - top-level bindings (when let-to-case is impossible)
631 - many situations where the "rhs" is known to be a WHNF
632 (so let-to-case is inappropriate).
633
634 Nor does it do the atomic-argument thing
635 -}
636
637 completeBind :: SimplEnv
638 -> TopLevelFlag -- Flag stuck into unfolding
639 -> InId -- Old binder
640 -> OutId -> OutExpr -- New binder and RHS
641 -> SimplM SimplEnv
642 -- completeBind may choose to do its work
643 -- * by extending the substitution (e.g. let x = y in ...)
644 -- * or by adding to the floats in the envt
645 --
646 -- Precondition: rhs obeys the let/app invariant
647 completeBind env top_lvl old_bndr new_bndr new_rhs
648 | isCoVar old_bndr
649 = case new_rhs of
650 Coercion co -> return (extendCvSubst env old_bndr co)
651 _ -> return (addNonRec env new_bndr new_rhs)
652
653 | otherwise
654 = ASSERT( isId new_bndr )
655 do { let old_info = idInfo old_bndr
656 old_unf = unfoldingInfo old_info
657 occ_info = occInfo old_info
658
659 -- Do eta-expansion on the RHS of the binding
660 -- See Note [Eta-expanding at let bindings] in SimplUtils
661 ; (new_arity, final_rhs) <- tryEtaExpandRhs env new_bndr new_rhs
662
663 -- Simplify the unfolding
664 ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
665
666 ; dflags <- getDynFlags
667 ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info
668 final_rhs new_unfolding
669
670 -- Inline and discard the binding
671 then do { tick (PostInlineUnconditionally old_bndr)
672 ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
673 -- Use the substitution to make quite, quite sure that the
674 -- substitution will happen, since we are going to discard the binding
675 else
676 do { let info1 = idInfo new_bndr `setArityInfo` new_arity
677
678 -- Unfolding info: Note [Setting the new unfolding]
679 info2 = info1 `setUnfoldingInfo` new_unfolding
680
681 -- Demand info: Note [Setting the demand info]
682 --
683 -- We also have to nuke demand info if for some reason
684 -- eta-expansion *reduces* the arity of the binding to less
685 -- than that of the strictness sig. This can happen: see Note [Arity decrease].
686 info3 | isEvaldUnfolding new_unfolding
687 || (case strictnessInfo info2 of
688 StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
689 = zapDemandInfo info2 `orElse` info2
690 | otherwise
691 = info2
692
693 final_id = new_bndr `setIdInfo` info3
694
695 ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
696 return (addNonRec env final_id final_rhs) } }
697 -- The addNonRec adds it to the in-scope set too
698
699 ------------------------------
700 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
701 -- Add a new binding to the environment, complete with its unfolding
702 -- but *do not* do postInlineUnconditionally, because we have already
703 -- processed some of the scope of the binding
704 -- We still want the unfolding though. Consider
705 -- let
706 -- x = /\a. let y = ... in Just y
707 -- in body
708 -- Then we float the y-binding out (via abstractFloats and addPolyBind)
709 -- but 'x' may well then be inlined in 'body' in which case we'd like the
710 -- opportunity to inline 'y' too.
711 --
712 -- INVARIANT: the arity is correct on the incoming binders
713
714 addPolyBind top_lvl env (NonRec poly_id rhs)
715 = do { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
716 -- Assumes that poly_id did not have an INLINE prag
717 -- which is perhaps wrong. ToDo: think about this
718 ; let final_id = setIdInfo poly_id $
719 idInfo poly_id `setUnfoldingInfo` unfolding
720
721 ; return (addNonRec env final_id rhs) }
722
723 addPolyBind _ env bind@(Rec _)
724 = return (extendFloats env bind)
725 -- Hack: letrecs are more awkward, so we extend "by steam"
726 -- without adding unfoldings etc. At worst this leads to
727 -- more simplifier iterations
728
729 ------------------------------
730 simplUnfolding :: SimplEnv-> TopLevelFlag
731 -> InId
732 -> OutExpr
733 -> Unfolding -> SimplM Unfolding
734 -- Note [Setting the new unfolding]
735 simplUnfolding env top_lvl id new_rhs unf
736 = case unf of
737 DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
738 -> do { (env', bndrs') <- simplBinders rule_env bndrs
739 ; args' <- mapM (simplExpr env') args
740 ; return (mkDFunUnfolding bndrs' con args') }
741
742 CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
743 | isStableSource src
744 -> do { expr' <- simplExpr rule_env expr
745 ; case guide of
746 UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok } -- Happens for INLINE things
747 -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok
748 , ug_boring_ok = inlineBoringOk expr' }
749 -- Refresh the boring-ok flag, in case expr'
750 -- has got small. This happens, notably in the inlinings
751 -- for dfuns for single-method classes; see
752 -- Note [Single-method classes] in TcInstDcls.
753 -- A test case is Trac #4138
754 in return (mkCoreUnfolding src is_top_lvl expr' guide')
755 -- See Note [Top-level flag on inline rules] in CoreUnfold
756
757 _other -- Happens for INLINABLE things
758 -> bottoming `seq` -- See Note [Force bottoming field]
759 do { dflags <- getDynFlags
760 ; return (mkUnfolding dflags src is_top_lvl bottoming expr') } }
761 -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
762 -- unfolding, and we need to make sure the guidance is kept up
763 -- to date with respect to any changes in the unfolding.
764
765 _other -> bottoming `seq` -- See Note [Force bottoming field]
766 do { dflags <- getDynFlags
767 ; return (mkUnfolding dflags InlineRhs is_top_lvl bottoming new_rhs) }
768 -- We make an unfolding *even for loop-breakers*.
769 -- Reason: (a) It might be useful to know that they are WHNF
770 -- (b) In TidyPgm we currently assume that, if we want to
771 -- expose the unfolding then indeed we *have* an unfolding
772 -- to expose. (We could instead use the RHS, but currently
773 -- we don't.) The simple thing is always to have one.
774 where
775 bottoming = isBottomingId id
776 is_top_lvl = isTopLevel top_lvl
777 act = idInlineActivation id
778 rule_env = updMode (updModeForStableUnfoldings act) env
779 -- See Note [Simplifying inside stable unfoldings] in SimplUtils
780
781 {-
782 Note [Force bottoming field]
783 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
784 We need to force bottoming, or the new unfolding holds
785 on to the old unfolding (which is part of the id).
786
787 Note [Arity decrease]
788 ~~~~~~~~~~~~~~~~~~~~~
789 Generally speaking the arity of a binding should not decrease. But it *can*
790 legitimately happen because of RULES. Eg
791 f = g Int
792 where g has arity 2, will have arity 2. But if there's a rewrite rule
793 g Int --> h
794 where h has arity 1, then f's arity will decrease. Here's a real-life example,
795 which is in the output of Specialise:
796
797 Rec {
798 $dm {Arity 2} = \d.\x. op d
799 {-# RULES forall d. $dm Int d = $s$dm #-}
800
801 dInt = MkD .... opInt ...
802 opInt {Arity 1} = $dm dInt
803
804 $s$dm {Arity 0} = \x. op dInt }
805
806 Here opInt has arity 1; but when we apply the rule its arity drops to 0.
807 That's why Specialise goes to a little trouble to pin the right arity
808 on specialised functions too.
809
810 Note [Setting the new unfolding]
811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812 * If there's an INLINE pragma, we simplify the RHS gently. Maybe we
813 should do nothing at all, but simplifying gently might get rid of
814 more crap.
815
816 * If not, we make an unfolding from the new RHS. But *only* for
817 non-loop-breakers. Making loop breakers not have an unfolding at all
818 means that we can avoid tests in exprIsConApp, for example. This is
819 important: if exprIsConApp says 'yes' for a recursive thing, then we
820 can get into an infinite loop
821
822 If there's an stable unfolding on a loop breaker (which happens for
823 INLINEABLE), we hang on to the inlining. It's pretty dodgy, but the
824 user did say 'INLINE'. May need to revisit this choice.
825
826 Note [Setting the demand info]
827 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
828 If the unfolding is a value, the demand info may
829 go pear-shaped, so we nuke it. Example:
830 let x = (a,b) in
831 case x of (p,q) -> h p q x
832 Here x is certainly demanded. But after we've nuked
833 the case, we'll get just
834 let x = (a,b) in h a b x
835 and now x is not demanded (I'm assuming h is lazy)
836 This really happens. Similarly
837 let f = \x -> e in ...f..f...
838 After inlining f at some of its call sites the original binding may
839 (for example) be no longer strictly demanded.
840 The solution here is a bit ad hoc...
841
842
843 ************************************************************************
844 * *
845 \subsection[Simplify-simplExpr]{The main function: simplExpr}
846 * *
847 ************************************************************************
848
849 The reason for this OutExprStuff stuff is that we want to float *after*
850 simplifying a RHS, not before. If we do so naively we get quadratic
851 behaviour as things float out.
852
853 To see why it's important to do it after, consider this (real) example:
854
855 let t = f x
856 in fst t
857 ==>
858 let t = let a = e1
859 b = e2
860 in (a,b)
861 in fst t
862 ==>
863 let a = e1
864 b = e2
865 t = (a,b)
866 in
867 a -- Can't inline a this round, cos it appears twice
868 ==>
869 e1
870
871 Each of the ==> steps is a round of simplification. We'd save a
872 whole round if we float first. This can cascade. Consider
873
874 let f = g d
875 in \x -> ...f...
876 ==>
877 let f = let d1 = ..d.. in \y -> e
878 in \x -> ...f...
879 ==>
880 let d1 = ..d..
881 in \x -> ...(\y ->e)...
882
883 Only in this second round can the \y be applied, and it
884 might do the same again.
885 -}
886
887 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
888 simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
889 where
890 expr_out_ty :: OutType
891 expr_out_ty = substTy env (exprType expr)
892
893 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
894 -- Simplify an expression, given a continuation
895 simplExprC env expr cont
896 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
897 do { (env', expr') <- simplExprF (zapFloats env) expr cont
898 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
899 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
900 -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
901 return (wrapFloats env' expr') }
902
903 --------------------------------------------------
904 simplExprF :: SimplEnv -> InExpr -> SimplCont
905 -> SimplM (SimplEnv, OutExpr)
906
907 simplExprF env e cont
908 = {- pprTrace "simplExprF" (vcat
909 [ ppr e
910 , text "cont =" <+> ppr cont
911 , text "inscope =" <+> ppr (seInScope env)
912 , text "tvsubst =" <+> ppr (seTvSubst env)
913 , text "idsubst =" <+> ppr (seIdSubst env)
914 , text "cvsubst =" <+> ppr (seCvSubst env)
915 {- , ppr (seFloats env) -}
916 ]) $ -}
917 simplExprF1 env e cont
918
919 simplExprF1 :: SimplEnv -> InExpr -> SimplCont
920 -> SimplM (SimplEnv, OutExpr)
921 simplExprF1 env (Var v) cont = simplIdF env v cont
922 simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont
923 simplExprF1 env (Tick t expr) cont = simplTick env t expr cont
924 simplExprF1 env (Cast body co) cont = simplCast env body co cont
925 simplExprF1 env (Coercion co) cont = simplCoercionF env co cont
926 simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont )
927 rebuild env (Type (substTy env ty)) cont
928 simplExprF1 env (App fun arg) cont = simplExprF env fun $
929 ApplyTo NoDup arg env cont
930
931 simplExprF1 env expr@(Lam {}) cont
932 = simplLam env zapped_bndrs body cont
933 -- The main issue here is under-saturated lambdas
934 -- (\x1. \x2. e) arg1
935 -- Here x1 might have "occurs-once" occ-info, because occ-info
936 -- is computed assuming that a group of lambdas is applied
937 -- all at once. If there are too few args, we must zap the
938 -- occ-info, UNLESS the remaining binders are one-shot
939 where
940 (bndrs, body) = collectBinders expr
941 zapped_bndrs | need_to_zap = map zap bndrs
942 | otherwise = bndrs
943
944 need_to_zap = any zappable_bndr (drop n_args bndrs)
945 n_args = countArgs cont
946 -- NB: countArgs counts all the args (incl type args)
947 -- and likewise drop counts all binders (incl type lambdas)
948
949 zappable_bndr b = isId b && not (isOneShotBndr b)
950 zap b | isTyVar b = b
951 | otherwise = zapLamIdInfo b
952
953 simplExprF1 env (Case scrut bndr _ alts) cont
954 = simplExprF env scrut (Select NoDup bndr alts env cont)
955
956 simplExprF1 env (Let (Rec pairs) body) cont
957 = do { env' <- simplRecBndrs env (map fst pairs)
958 -- NB: bndrs' don't have unfoldings or rules
959 -- We add them as we go down
960
961 ; env'' <- simplRecBind env' NotTopLevel pairs
962 ; simplExprF env'' body cont }
963
964 simplExprF1 env (Let (NonRec bndr rhs) body) cont
965 = simplNonRecE env bndr (rhs, env) ([], body) cont
966
967 ---------------------------------
968 simplType :: SimplEnv -> InType -> SimplM OutType
969 -- Kept monadic just so we can do the seqType
970 simplType env ty
971 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
972 seqType new_ty `seq` return new_ty
973 where
974 new_ty = substTy env ty
975
976 ---------------------------------
977 simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
978 -> SimplM (SimplEnv, OutExpr)
979 simplCoercionF env co cont
980 = do { co' <- simplCoercion env co
981 ; rebuild env (Coercion co') cont }
982
983 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
984 simplCoercion env co
985 = let opt_co = optCoercion (getCvSubst env) co
986 in seqCo opt_co `seq` return opt_co
987
988 -----------------------------------
989 -- | Push a TickIt context outwards past applications and cases, as
990 -- long as this is a non-scoping tick, to let case and application
991 -- optimisations apply.
992
993 simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
994 -> SimplM (SimplEnv, OutExpr)
995 simplTick env tickish expr cont
996 -- A scoped tick turns into a continuation, so that we can spot
997 -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do
998 -- it this way, then it would take two passes of the simplifier to
999 -- reduce ((scc t (\x . e)) e').
1000 -- NB, don't do this with counting ticks, because if the expr is
1001 -- bottom, then rebuildCall will discard the continuation.
1002
1003 -- XXX: we cannot do this, because the simplifier assumes that
1004 -- the context can be pushed into a case with a single branch. e.g.
1005 -- scc<f> case expensive of p -> e
1006 -- becomes
1007 -- case expensive of p -> scc<f> e
1008 --
1009 -- So I'm disabling this for now. It just means we will do more
1010 -- simplifier iterations that necessary in some cases.
1011
1012 -- | tickishScoped tickish && not (tickishCounts tickish)
1013 -- = simplExprF env expr (TickIt tickish cont)
1014
1015 -- For non-scoped ticks, we push the continuation inside the
1016 -- tick. This has the effect of moving the tick to the outside of a
1017 -- case or application context, allowing the normal case and
1018 -- application optimisations to fire.
1019 | not (tickishScoped tickish)
1020 = do { (env', expr') <- simplExprF env expr cont
1021 ; return (env', mkTick tickish expr')
1022 }
1023
1024 -- For breakpoints, we cannot do any floating of bindings around the
1025 -- tick, because breakpoints cannot be split into tick/scope pairs.
1026 | not (tickishCanSplit tickish)
1027 = no_floating_past_tick
1028
1029 | interesting_cont, Just expr' <- push_tick_inside tickish expr
1030 -- see Note [case-of-scc-of-case]
1031 = simplExprF env expr' cont
1032
1033 | otherwise
1034 = no_floating_past_tick -- was: wrap_floats, see below
1035
1036 where
1037 interesting_cont = case cont of
1038 Select {} -> True
1039 _ -> False
1040
1041 push_tick_inside t expr0
1042 = ASSERT(tickishScoped t)
1043 case expr0 of
1044 Tick t' expr
1045 -- scc t (tick t' E)
1046 -- Pull the tick to the outside
1047 -- This one is important for #5363
1048 | not (tickishScoped t')
1049 -> Just (Tick t' (Tick t expr))
1050
1051 -- scc t (scc t' E)
1052 -- Try to push t' into E first, and if that works,
1053 -- try to push t in again
1054 | Just expr' <- push_tick_inside t' expr
1055 -> push_tick_inside t expr'
1056
1057 | otherwise -> Nothing
1058
1059 Case scrut bndr ty alts
1060 | not (tickishCanSplit t) -> Nothing
1061 | otherwise -> Just (Case (mkTick t scrut) bndr ty alts')
1062 where t_scope = mkNoCount t -- drop the tick on the dup'd ones
1063 alts' = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
1064
1065 _other -> Nothing
1066 where
1067
1068 no_floating_past_tick =
1069 do { let (inc,outc) = splitCont cont
1070 ; (env', expr') <- simplExprF (zapFloats env) expr inc
1071 ; let tickish' = simplTickish env tickish
1072 ; (env'', expr'') <- rebuild (zapFloats env')
1073 (wrapFloats env' expr')
1074 (TickIt tickish' outc)
1075 ; return (addFloats env env'', expr'')
1076 }
1077
1078 -- Alternative version that wraps outgoing floats with the tick. This
1079 -- results in ticks being duplicated, as we don't make any attempt to
1080 -- eliminate the tick if we re-inline the binding (because the tick
1081 -- semantics allows unrestricted inlining of HNFs), so I'm not doing
1082 -- this any more. FloatOut will catch any real opportunities for
1083 -- floating.
1084 --
1085 -- wrap_floats =
1086 -- do { let (inc,outc) = splitCont cont
1087 -- ; (env', expr') <- simplExprF (zapFloats env) expr inc
1088 -- ; let tickish' = simplTickish env tickish
1089 -- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),
1090 -- mkTick (mkNoCount tickish') rhs)
1091 -- -- when wrapping a float with mkTick, we better zap the Id's
1092 -- -- strictness info and arity, because it might be wrong now.
1093 -- ; let env'' = addFloats env (mapFloats env' wrap_float)
1094 -- ; rebuild env'' expr' (TickIt tickish' outc)
1095 -- }
1096
1097
1098 simplTickish env tickish
1099 | Breakpoint n ids <- tickish
1100 = Breakpoint n (map (getDoneId . substId env) ids)
1101 | otherwise = tickish
1102
1103 -- push type application and coercion inside a tick
1104 splitCont :: SimplCont -> (SimplCont, SimplCont)
1105 splitCont (ApplyTo f (Type t) env c) = (ApplyTo f (Type t) env inc, outc)
1106 where (inc,outc) = splitCont c
1107 splitCont (CoerceIt co c) = (CoerceIt co inc, outc)
1108 where (inc,outc) = splitCont c
1109 splitCont other = (mkBoringStop (contInputType other), other)
1110
1111 getDoneId (DoneId id) = id
1112 getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
1113 getDoneId other = pprPanic "getDoneId" (ppr other)
1114
1115 -- Note [case-of-scc-of-case]
1116 -- It's pretty important to be able to transform case-of-case when
1117 -- there's an SCC in the way. For example, the following comes up
1118 -- in nofib/real/compress/Encode.hs:
1119 --
1120 -- case scctick<code_string.r1>
1121 -- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje
1122 -- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->
1123 -- (ww1_s13f, ww2_s13g, ww3_s13h)
1124 -- }
1125 -- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->
1126 -- tick<code_string.f1>
1127 -- (ww_s12Y,
1128 -- ww1_s12Z,
1129 -- PTTrees.PT
1130 -- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)
1131 -- }
1132 --
1133 -- We really want this case-of-case to fire, because then the 3-tuple
1134 -- will go away (indeed, the CPR optimisation is relying on this
1135 -- happening). But the scctick is in the way - we need to push it
1136 -- inside to expose the case-of-case. So we perform this
1137 -- transformation on the inner case:
1138 --
1139 -- scctick c (case e of { p1 -> e1; ...; pn -> en })
1140 -- ==>
1141 -- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }
1142 --
1143 -- So we've moved a constant amount of work out of the scc to expose
1144 -- the case. We only do this when the continuation is interesting: in
1145 -- for now, it has to be another Case (maybe generalise this later).
1146
1147 {-
1148 ************************************************************************
1149 * *
1150 \subsection{The main rebuilder}
1151 * *
1152 ************************************************************************
1153 -}
1154
1155 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
1156 -- At this point the substitution in the SimplEnv should be irrelevant
1157 -- only the in-scope set and floats should matter
1158 rebuild env expr cont
1159 = case cont of
1160 Stop {} -> return (env, expr)
1161 CoerceIt co cont -> rebuild env (mkCast expr co) cont
1162 -- NB: mkCast implements the (Coercion co |> g) optimisation
1163 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
1164 StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont
1165 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
1166 -- expr satisfies let/app since it started life
1167 -- in a call to simplNonRecE
1168 ; simplLam env' bs body cont }
1169 ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
1170 | isSimplified dup_flag -> rebuild env (App expr arg) cont
1171 | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg
1172 ; rebuild env (App expr arg') cont }
1173 TickIt t cont -> rebuild env (mkTick t expr) cont
1174
1175 {-
1176 ************************************************************************
1177 * *
1178 \subsection{Lambdas}
1179 * *
1180 ************************************************************************
1181 -}
1182
1183 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
1184 -> SimplM (SimplEnv, OutExpr)
1185 simplCast env body co0 cont0
1186 = do { co1 <- simplCoercion env co0
1187 ; -- pprTrace "simplCast" (ppr co1) $
1188 simplExprF env body (addCoerce co1 cont0) }
1189 where
1190 addCoerce co cont = add_coerce co (coercionKind co) cont
1191
1192 add_coerce _co (Pair s1 k1) cont -- co :: ty~ty
1193 | s1 `eqType` k1 = cont -- is a no-op
1194
1195 add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont)
1196 | (Pair _l1 t1) <- coercionKind co2
1197 -- e |> (g1 :: S1~L) |> (g2 :: L~T1)
1198 -- ==>
1199 -- e, if S1=T1
1200 -- e |> (g1 . g2 :: S1~T1) otherwise
1201 --
1202 -- For example, in the initial form of a worker
1203 -- we may find (coerce T (coerce S (\x.e))) y
1204 -- and we'd like it to simplify to e[y/x] in one round
1205 -- of simplification
1206 , s1 `eqType` t1 = cont -- The coerces cancel out
1207 | otherwise = CoerceIt (mkTransCo co1 co2) cont
1208
1209 add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
1210 -- (f |> g) ty ---> (f ty) |> (g @ ty)
1211 -- This implements the PushT rule from the paper
1212 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
1213 = ASSERT( isTyVar tyvar )
1214 ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont)
1215 where
1216 new_cast = mkInstCo co arg_ty'
1217 arg_ty' | isSimplified dup = arg_ty
1218 | otherwise = substTy (arg_se `setInScope` env) arg_ty
1219
1220 add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont)
1221 | isFunTy s1s2 -- This implements the Push rule from the paper
1222 , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg
1223 -- (e |> (g :: s1s2 ~ t1->t2)) f
1224 -- ===>
1225 -- (e (f |> (arg g :: t1~s1))
1226 -- |> (res g :: s2->t2)
1227 --
1228 -- t1t2 must be a function type, t1->t2, because it's applied
1229 -- to something but s1s2 might conceivably not be
1230 --
1231 -- When we build the ApplyTo we can't mix the out-types
1232 -- with the InExpr in the argument, so we simply substitute
1233 -- to make it all consistent. It's a bit messy.
1234 -- But it isn't a common case.
1235 --
1236 -- Example of use: Trac #995
1237 = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont)
1238 where
1239 -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
1240 -- t2 ~ s2 with left and right on the curried form:
1241 -- (->) t1 t2 ~ (->) s1 s2
1242 [co1, co2] = decomposeCo 2 co
1243 new_arg = mkCast arg' (mkSymCo co1)
1244 arg' = substExpr (text "move-cast") arg_se' arg
1245 arg_se' = arg_se `setInScope` env
1246
1247 add_coerce co _ cont = CoerceIt co cont
1248
1249 {-
1250 ************************************************************************
1251 * *
1252 \subsection{Lambdas}
1253 * *
1254 ************************************************************************
1255
1256 Note [Zap unfolding when beta-reducing]
1257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1258 Lambda-bound variables can have stable unfoldings, such as
1259 $j = \x. \b{Unf=Just x}. e
1260 See Note [Case binders and join points] below; the unfolding for lets
1261 us optimise e better. However when we beta-reduce it we want to
1262 revert to using the actual value, otherwise we can end up in the
1263 stupid situation of
1264 let x = blah in
1265 let b{Unf=Just x} = y
1266 in ...b...
1267 Here it'd be far better to drop the unfolding and use the actual RHS.
1268 -}
1269
1270 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
1271 -> SimplM (SimplEnv, OutExpr)
1272
1273 simplLam env [] body cont = simplExprF env body cont
1274
1275 -- Beta reduction
1276 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
1277 = do { tick (BetaReduction bndr)
1278 ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
1279 where
1280 zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing]
1281 | isId bndr, isStableUnfolding (realIdUnfolding bndr)
1282 = setIdUnfolding bndr NoUnfolding
1283 | otherwise = bndr
1284
1285 -- discard a non-counting tick on a lambda. This may change the
1286 -- cost attribution slightly (moving the allocation of the
1287 -- lambda elsewhere), but we don't care: optimisation changes
1288 -- cost attribution all the time.
1289 simplLam env bndrs body (TickIt tickish cont)
1290 | not (tickishCounts tickish)
1291 = simplLam env bndrs body cont
1292
1293 -- Not enough args, so there are real lambdas left to put in the result
1294 simplLam env bndrs body cont
1295 = do { (env', bndrs') <- simplLamBndrs env bndrs
1296 ; body' <- simplExpr env' body
1297 ; new_lam <- mkLam bndrs' body' cont
1298 ; rebuild env' new_lam cont }
1299
1300 ------------------
1301 simplNonRecE :: SimplEnv
1302 -> InBndr -- The binder
1303 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
1304 -> ([InBndr], InExpr) -- Body of the let/lambda
1305 -- \xs.e
1306 -> SimplCont
1307 -> SimplM (SimplEnv, OutExpr)
1308
1309 -- simplNonRecE is used for
1310 -- * non-top-level non-recursive lets in expressions
1311 -- * beta reduction
1312 --
1313 -- It deals with strict bindings, via the StrictBind continuation,
1314 -- which may abort the whole process
1315 --
1316 -- Precondition: rhs satisfies the let/app invariant
1317 -- Note [CoreSyn let/app invariant] in CoreSyn
1318 --
1319 -- The "body" of the binding comes as a pair of ([InId],InExpr)
1320 -- representing a lambda; so we recurse back to simplLam
1321 -- Why? Because of the binder-occ-info-zapping done before
1322 -- the call to simplLam in simplExprF (Lam ...)
1323
1324 -- First deal with type applications and type lets
1325 -- (/\a. e) (Type ty) and (let a = Type ty in e)
1326 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
1327 = ASSERT( isTyVar bndr )
1328 do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
1329 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
1330
1331 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
1332 = do dflags <- getDynFlags
1333 case () of
1334 _ | preInlineUnconditionally dflags env NotTopLevel bndr rhs
1335 -> do { tick (PreInlineUnconditionally bndr)
1336 ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
1337 simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
1338
1339 | isStrictId bndr -- Includes coercions
1340 -> simplExprF (rhs_se `setFloats` env) rhs
1341 (StrictBind bndr bndrs body env cont)
1342
1343 | otherwise
1344 -> ASSERT( not (isTyVar bndr) )
1345 do { (env1, bndr1) <- simplNonRecBndr env bndr
1346 ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
1347 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
1348 ; simplLam env3 bndrs body cont }
1349
1350 {-
1351 ************************************************************************
1352 * *
1353 Variables
1354 * *
1355 ************************************************************************
1356 -}
1357
1358 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
1359 -- Look up an InVar in the environment
1360 simplVar env var
1361 | isTyVar var = return (Type (substTyVar env var))
1362 | isCoVar var = return (Coercion (substCoVar env var))
1363 | otherwise
1364 = case substId env var of
1365 DoneId var1 -> return (Var var1)
1366 DoneEx e -> return e
1367 ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
1368
1369 simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
1370 simplIdF env var cont
1371 = case substId env var of
1372 DoneEx e -> simplExprF (zapSubstEnv env) e cont
1373 ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
1374 DoneId var1 -> completeCall env var1 cont
1375 -- Note [zapSubstEnv]
1376 -- The template is already simplified, so don't re-substitute.
1377 -- This is VITAL. Consider
1378 -- let x = e in
1379 -- let y = \z -> ...x... in
1380 -- \ x -> ...y...
1381 -- We'll clone the inner \x, adding x->x' in the id_subst
1382 -- Then when we inline y, we must *not* replace x by x' in
1383 -- the inlined copy!!
1384
1385 ---------------------------------------------------------
1386 -- Dealing with a call site
1387
1388 completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr)
1389 completeCall env var cont
1390 = do { ------------- Try inlining ----------------
1391 dflags <- getDynFlags
1392 ; let (lone_variable, arg_infos, call_cont) = contArgs cont
1393 n_val_args = length arg_infos
1394 interesting_cont = interestingCallContext call_cont
1395 unfolding = activeUnfolding env var
1396 maybe_inline = callSiteInline dflags var unfolding
1397 lone_variable arg_infos interesting_cont
1398 ; case maybe_inline of {
1399 Just expr -- There is an inlining!
1400 -> do { checkedTick (UnfoldingDone var)
1401 ; dump_inline dflags expr cont
1402 ; simplExprF (zapSubstEnv env) expr cont }
1403
1404 ; Nothing -> do -- No inlining!
1405
1406 { rule_base <- getSimplRules
1407 ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
1408 ; rebuildCall env info cont
1409 }}}
1410 where
1411 dump_inline dflags unfolding cont
1412 | not (dopt Opt_D_dump_inlinings dflags) = return ()
1413 | not (dopt Opt_D_verbose_core2core dflags)
1414 = when (isExternalName (idName var)) $
1415 liftIO $ printInfoForUser dflags alwaysQualify $
1416 sep [text "Inlining done:", nest 4 (ppr var)]
1417 | otherwise
1418 = liftIO $ printInfoForUser dflags alwaysQualify $
1419 sep [text "Inlining done: " <> ppr var,
1420 nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
1421 text "Cont: " <+> ppr cont])]
1422
1423 rebuildCall :: SimplEnv
1424 -> ArgInfo
1425 -> SimplCont
1426 -> SimplM (SimplEnv, OutExpr)
1427 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
1428 -- When we run out of strictness args, it means
1429 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1430 -- Then we want to discard the entire strict continuation. E.g.
1431 -- * case (error "hello") of { ... }
1432 -- * (error "Hello") arg
1433 -- * f (error "Hello") where f is strict
1434 -- etc
1435 -- Then, especially in the first of these cases, we'd like to discard
1436 -- the continuation, leaving just the bottoming expression. But the
1437 -- type might not be right, so we may have to add a coerce.
1438 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1439 = return (env, castBottomExpr res cont_ty) -- contination to discard, else we do it
1440 where -- again and again!
1441 res = argInfoExpr fun rev_args
1442 cont_ty = contResultType cont
1443
1444 rebuildCall env info (CoerceIt co cont)
1445 = rebuildCall env (addCastTo info co) cont
1446
1447 rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
1448 = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
1449 else simplType (se `setInScope` env) arg_ty
1450 ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
1451
1452 rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
1453 , ai_strs = str:strs, ai_discs = disc:discs })
1454 (ApplyTo dup_flag arg arg_se cont)
1455 | isSimplified dup_flag -- See Note [Avoid redundant simplification]
1456 = rebuildCall env (addArgTo info' arg) cont
1457
1458 | str -- Strict argument
1459 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1460 simplExprF (arg_se `setFloats` env) arg
1461 (StrictArg info' cci cont)
1462 -- Note [Shadowing]
1463
1464 | otherwise -- Lazy argument
1465 -- DO NOT float anything outside, hence simplExprC
1466 -- There is no benefit (unlike in a let-binding), and we'd
1467 -- have to be very careful about bogus strictness through
1468 -- floating a demanded let.
1469 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1470 (mkLazyArgStop (funArgTy fun_ty) cci)
1471 ; rebuildCall env (addArgTo info' arg') cont }
1472 where
1473 info' = info { ai_strs = strs, ai_discs = discs }
1474 cci | encl_rules = RuleArgCtxt
1475 | disc > 0 = DiscArgCtxt -- Be keener here
1476 | otherwise = BoringCtxt -- Nothing interesting
1477
1478 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
1479 | null rules
1480 = rebuild env (argInfoExpr fun rev_args) cont -- No rules, common case
1481
1482 | otherwise
1483 = do { -- We've accumulated a simplified call in <fun,rev_args>
1484 -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
1485 -- See also Note [Rules for recursive functions]
1486 ; let env' = zapSubstEnv env
1487 (args, cont') = argInfoValArgs env' rev_args cont
1488 ; mb_rule <- tryRules env' rules fun args cont'
1489 ; case mb_rule of {
1490 Just (rule_rhs, cont'') -> simplExprF env' rule_rhs cont''
1491
1492 -- Rules don't match
1493 ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules
1494 } }
1495
1496 {-
1497 Note [RULES apply to simplified arguments]
1498 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1499 It's very desirable to try RULES once the arguments have been simplified, because
1500 doing so ensures that rule cascades work in one pass. Consider
1501 {-# RULES g (h x) = k x
1502 f (k x) = x #-}
1503 ...f (g (h x))...
1504 Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
1505 we match f's rules against the un-simplified RHS, it won't match. This
1506 makes a particularly big difference when superclass selectors are involved:
1507 op ($p1 ($p2 (df d)))
1508 We want all this to unravel in one sweeep.
1509
1510 Note [Avoid redundant simplification]
1511 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1512 Because RULES apply to simplified arguments, there's a danger of repeatedly
1513 simplifying already-simplified arguments. An important example is that of
1514 (>>=) d e1 e2
1515 Here e1, e2 are simplified before the rule is applied, but don't really
1516 participate in the rule firing. So we mark them as Simplified to avoid
1517 re-simplifying them.
1518
1519 Note [Shadowing]
1520 ~~~~~~~~~~~~~~~~
1521 This part of the simplifier may break the no-shadowing invariant
1522 Consider
1523 f (...(\a -> e)...) (case y of (a,b) -> e')
1524 where f is strict in its second arg
1525 If we simplify the innermost one first we get (...(\a -> e)...)
1526 Simplifying the second arg makes us float the case out, so we end up with
1527 case y of (a,b) -> f (...(\a -> e)...) e'
1528 So the output does not have the no-shadowing invariant. However, there is
1529 no danger of getting name-capture, because when the first arg was simplified
1530 we used an in-scope set that at least mentioned all the variables free in its
1531 static environment, and that is enough.
1532
1533 We can't just do innermost first, or we'd end up with a dual problem:
1534 case x of (a,b) -> f e (...(\a -> e')...)
1535
1536 I spent hours trying to recover the no-shadowing invariant, but I just could
1537 not think of an elegant way to do it. The simplifier is already knee-deep in
1538 continuations. We have to keep the right in-scope set around; AND we have
1539 to get the effect that finding (error "foo") in a strict arg position will
1540 discard the entire application and replace it with (error "foo"). Getting
1541 all this at once is TOO HARD!
1542
1543
1544 ************************************************************************
1545 * *
1546 Rewrite rules
1547 * *
1548 ************************************************************************
1549 -}
1550
1551 tryRules :: SimplEnv -> [CoreRule]
1552 -> Id -> [OutExpr] -> SimplCont
1553 -> SimplM (Maybe (CoreExpr, SimplCont))
1554 -- The SimplEnv already has zapSubstEnv applied to it
1555
1556 tryRules env rules fn args call_cont
1557 | null rules
1558 = return Nothing
1559 {- Disabled until we fix #8326
1560 | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#]
1561 , [_type_arg, val_arg] <- args
1562 , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont
1563 , isDeadBinder bndr
1564 = do { dflags <- getDynFlags
1565 ; let enum_to_tag :: CoreAlt -> CoreAlt
1566 -- Takes K -> e into tagK# -> e
1567 -- where tagK# is the tag of constructor K
1568 enum_to_tag (DataAlt con, [], rhs)
1569 = ASSERT( isEnumerationTyCon (dataConTyCon con) )
1570 (LitAlt tag, [], rhs)
1571 where
1572 tag = mkMachInt dflags (toInteger (dataConTag con - fIRST_TAG))
1573 enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)
1574
1575 new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts
1576 new_bndr = setIdType bndr intPrimTy
1577 -- The binder is dead, but should have the right type
1578 ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
1579 -}
1580 | otherwise
1581 = do { dflags <- getDynFlags
1582 ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)
1583 fn args rules of {
1584 Nothing -> return Nothing ; -- No rule matches
1585 Just (rule, rule_rhs) ->
1586 do { checkedTick (RuleFired (ru_name rule))
1587 ; dump dflags rule rule_rhs
1588 ; let cont' = pushSimplifiedArgs env
1589 (drop (ruleArity rule) args)
1590 call_cont
1591 -- (ruleArity rule) says how many args the rule consumed
1592 ; return (Just (rule_rhs, cont')) }}}
1593 where
1594 dump dflags rule rule_rhs
1595 | dopt Opt_D_dump_rule_rewrites dflags
1596 = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
1597 [ text "Rule:" <+> ftext (ru_name rule)
1598 , text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args))
1599 , text "After: " <+> pprCoreExpr rule_rhs
1600 , text "Cont: " <+> ppr call_cont ]
1601
1602 | dopt Opt_D_dump_rule_firings dflags
1603 = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
1604 ftext (ru_name rule)
1605
1606 | otherwise
1607 = return ()
1608
1609 log_rule dflags flag hdr details
1610 = liftIO . dumpSDoc dflags alwaysQualify flag "" $
1611 sep [text hdr, nest 4 details]
1612
1613 {-
1614 Note [Optimising tagToEnum#]
1615 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1616 If we have an enumeration data type:
1617
1618 data Foo = A | B | C
1619
1620 Then we want to transform
1621
1622 case tagToEnum# x of ==> case x of
1623 A -> e1 DEFAULT -> e1
1624 B -> e2 1# -> e2
1625 C -> e3 2# -> e3
1626
1627 thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT
1628 alternative we retain it (remember it comes first). If not the case must
1629 be exhaustive, and we reflect that in the transformed version by adding
1630 a DEFAULT. Otherwise Lint complains that the new case is not exhaustive.
1631 See #8317.
1632
1633 Note [Rules for recursive functions]
1634 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1635 You might think that we shouldn't apply rules for a loop breaker:
1636 doing so might give rise to an infinite loop, because a RULE is
1637 rather like an extra equation for the function:
1638 RULE: f (g x) y = x+y
1639 Eqn: f a y = a-y
1640
1641 But it's too drastic to disable rules for loop breakers.
1642 Even the foldr/build rule would be disabled, because foldr
1643 is recursive, and hence a loop breaker:
1644 foldr k z (build g) = g k z
1645 So it's up to the programmer: rules can cause divergence
1646
1647
1648 ************************************************************************
1649 * *
1650 Rebuilding a case expression
1651 * *
1652 ************************************************************************
1653
1654 Note [Case elimination]
1655 ~~~~~~~~~~~~~~~~~~~~~~~
1656 The case-elimination transformation discards redundant case expressions.
1657 Start with a simple situation:
1658
1659 case x# of ===> let y# = x# in e
1660 y# -> e
1661
1662 (when x#, y# are of primitive type, of course). We can't (in general)
1663 do this for algebraic cases, because we might turn bottom into
1664 non-bottom!
1665
1666 The code in SimplUtils.prepareAlts has the effect of generalise this
1667 idea to look for a case where we're scrutinising a variable, and we
1668 know that only the default case can match. For example:
1669
1670 case x of
1671 0# -> ...
1672 DEFAULT -> ...(case x of
1673 0# -> ...
1674 DEFAULT -> ...) ...
1675
1676 Here the inner case is first trimmed to have only one alternative, the
1677 DEFAULT, after which it's an instance of the previous case. This
1678 really only shows up in eliminating error-checking code.
1679
1680 Note that SimplUtils.mkCase combines identical RHSs. So
1681
1682 case e of ===> case e of DEFAULT -> r
1683 True -> r
1684 False -> r
1685
1686 Now again the case may be elminated by the CaseElim transformation.
1687 This includes things like (==# a# b#)::Bool so that we simplify
1688 case ==# a# b# of { True -> x; False -> x }
1689 to just
1690 x
1691 This particular example shows up in default methods for
1692 comparison operations (e.g. in (>=) for Int.Int32)
1693
1694 Note [Case elimination: lifted case]
1695 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1696 If a case over a lifted type has a single alternative, and is being used
1697 as a strict 'let' (all isDeadBinder bndrs), we may want to do this
1698 transformation:
1699
1700 case e of r ===> let r = e in ...r...
1701 _ -> ...r...
1702
1703 (a) 'e' is already evaluated (it may so if e is a variable)
1704 Specifically we check (exprIsHNF e). In this case
1705 we can just allocate the WHNF directly with a let.
1706 or
1707 (b) 'x' is not used at all and e is ok-for-speculation
1708 The ok-for-spec bit checks that we don't lose any
1709 exceptions or divergence.
1710
1711 NB: it'd be *sound* to switch from case to let if the
1712 scrutinee was not yet WHNF but was guaranteed to
1713 converge; but sticking with case means we won't build a
1714 thunk
1715
1716 or
1717 (c) 'x' is used strictly in the body, and 'e' is a variable
1718 Then we can just substitute 'e' for 'x' in the body.
1719 See Note [Eliminating redundant seqs]
1720
1721 For (b), the "not used at all" test is important. Consider
1722 case (case a ># b of { True -> (p,q); False -> (q,p) }) of
1723 r -> blah
1724 The scrutinee is ok-for-speculation (it looks inside cases), but we do
1725 not want to transform to
1726 let r = case a ># b of { True -> (p,q); False -> (q,p) }
1727 in blah
1728 because that builds an unnecessary thunk.
1729
1730 Note [Eliminating redundant seqs]
1731 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1732 If we have this:
1733 case x of r { _ -> ..r.. }
1734 where 'r' is used strictly in (..r..), the case is effectively a 'seq'
1735 on 'x', but since 'r' is used strictly anyway, we can safely transform to
1736 (...x...)
1737
1738 Note that this can change the error behaviour. For example, we might
1739 transform
1740 case x of { _ -> error "bad" }
1741 --> error "bad"
1742 which is might be puzzling if 'x' currently lambda-bound, but later gets
1743 let-bound to (error "good").
1744
1745 Nevertheless, the paper "A semantics for imprecise exceptions" allows
1746 this transformation. If you want to fix the evaluation order, use
1747 'pseq'. See Trac #8900 for an example where the loss of this
1748 transformation bit us in practice.
1749
1750 See also Note [Empty case alternatives] in CoreSyn.
1751
1752 Just for reference, the original code (added Jan 13) looked like this:
1753 || case_bndr_evald_next rhs
1754
1755 case_bndr_evald_next :: CoreExpr -> Bool
1756 -- See Note [Case binder next]
1757 case_bndr_evald_next (Var v) = v == case_bndr
1758 case_bndr_evald_next (Cast e _) = case_bndr_evald_next e
1759 case_bndr_evald_next (App e _) = case_bndr_evald_next e
1760 case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e
1761 case_bndr_evald_next _ = False
1762
1763 (This came up when fixing Trac #7542. See also Note [Eta reduction of
1764 an eval'd function] in CoreUtils.)
1765
1766
1767 Note [Case elimination: unlifted case]
1768 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1769 Consider
1770 case a +# b of r -> ...r...
1771 Then we do case-elimination (to make a let) followed by inlining,
1772 to get
1773 .....(a +# b)....
1774 If we have
1775 case indexArray# a i of r -> ...r...
1776 we might like to do the same, and inline the (indexArray# a i).
1777 But indexArray# is not okForSpeculation, so we don't build a let
1778 in rebuildCase (lest it get floated *out*), so the inlining doesn't
1779 happen either.
1780
1781 This really isn't a big deal I think. The let can be
1782
1783
1784 Further notes about case elimination
1785 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1786 Consider: test :: Integer -> IO ()
1787 test = print
1788
1789 Turns out that this compiles to:
1790 Print.test
1791 = \ eta :: Integer
1792 eta1 :: Void# ->
1793 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1794 case hPutStr stdout
1795 (PrelNum.jtos eta ($w[] @ Char))
1796 eta1
1797 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1798
1799 Notice the strange '<' which has no effect at all. This is a funny one.
1800 It started like this:
1801
1802 f x y = if x < 0 then jtos x
1803 else if y==0 then "" else jtos x
1804
1805 At a particular call site we have (f v 1). So we inline to get
1806
1807 if v < 0 then jtos x
1808 else if 1==0 then "" else jtos x
1809
1810 Now simplify the 1==0 conditional:
1811
1812 if v<0 then jtos v else jtos v
1813
1814 Now common-up the two branches of the case:
1815
1816 case (v<0) of DEFAULT -> jtos v
1817
1818 Why don't we drop the case? Because it's strict in v. It's technically
1819 wrong to drop even unnecessary evaluations, and in practice they
1820 may be a result of 'seq' so we *definitely* don't want to drop those.
1821 I don't really know how to improve this situation.
1822 -}
1823
1824 ---------------------------------------------------------
1825 -- Eliminate the case if possible
1826
1827 rebuildCase, reallyRebuildCase
1828 :: SimplEnv
1829 -> OutExpr -- Scrutinee
1830 -> InId -- Case binder
1831 -> [InAlt] -- Alternatives (inceasing order)
1832 -> SimplCont
1833 -> SimplM (SimplEnv, OutExpr)
1834
1835 --------------------------------------------------
1836 -- 1. Eliminate the case if there's a known constructor
1837 --------------------------------------------------
1838
1839 rebuildCase env scrut case_bndr alts cont
1840 | Lit lit <- scrut -- No need for same treatment as constructors
1841 -- because literals are inlined more vigorously
1842 , not (litIsLifted lit)
1843 = do { tick (KnownBranch case_bndr)
1844 ; case findAlt (LitAlt lit) alts of
1845 Nothing -> missingAlt env case_bndr alts cont
1846 Just (_, bs, rhs) -> simple_rhs bs rhs }
1847
1848 | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
1849 -- Works when the scrutinee is a variable with a known unfolding
1850 -- as well as when it's an explicit constructor application
1851 = do { tick (KnownBranch case_bndr)
1852 ; case findAlt (DataAlt con) alts of
1853 Nothing -> missingAlt env case_bndr alts cont
1854 Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
1855 Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args
1856 case_bndr bs rhs cont
1857 }
1858 where
1859 simple_rhs bs rhs = ASSERT( null bs )
1860 do { env' <- simplNonRecX env case_bndr scrut
1861 -- scrut is a constructor application,
1862 -- hence satisfies let/app invariant
1863 ; simplExprF env' rhs cont }
1864
1865
1866 --------------------------------------------------
1867 -- 2. Eliminate the case if scrutinee is evaluated
1868 --------------------------------------------------
1869
1870 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
1871 -- See if we can get rid of the case altogether
1872 -- See Note [Case elimination]
1873 -- mkCase made sure that if all the alternatives are equal,
1874 -- then there is now only one (DEFAULT) rhs
1875
1876 -- 2a. Dropping the case altogether, if
1877 -- a) it binds nothing (so it's really just a 'seq')
1878 -- b) evaluating the scrutinee has no side effects
1879 | is_plain_seq
1880 , exprOkForSideEffects scrut
1881 -- The entire case is dead, so we can drop it
1882 -- if the scrutinee converges without having imperative
1883 -- side effects or raising a Haskell exception
1884 -- See Note [PrimOp can_fail and has_side_effects] in PrimOp
1885 = simplExprF env rhs cont
1886
1887 -- 2b. Turn the case into a let, if
1888 -- a) it binds only the case-binder
1889 -- b) unlifted case: the scrutinee is ok-for-speculation
1890 -- lifted case: the scrutinee is in HNF (or will later be demanded)
1891 | all_dead_bndrs
1892 , if is_unlifted
1893 then exprOkForSpeculation scrut -- See Note [Case elimination: unlifted case]
1894 else exprIsHNF scrut -- See Note [Case elimination: lifted case]
1895 || scrut_is_demanded_var scrut
1896 = do { tick (CaseElim case_bndr)
1897 ; env' <- simplNonRecX env case_bndr scrut
1898 ; simplExprF env' rhs cont }
1899
1900 -- 2c. Try the seq rules if
1901 -- a) it binds only the case binder
1902 -- b) a rule for seq applies
1903 -- See Note [User-defined RULES for seq] in MkId
1904 | is_plain_seq
1905 = do { let rhs' = substExpr (text "rebuild-case") env rhs
1906 env' = zapSubstEnv env
1907 out_args = [Type (substTy env (idType case_bndr)),
1908 Type (exprType rhs'), scrut, rhs']
1909 -- Lazily evaluated, so we don't do most of this
1910
1911 ; rule_base <- getSimplRules
1912 ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args cont
1913 ; case mb_rule of
1914 Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont'
1915 Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
1916 where
1917 is_unlifted = isUnLiftedType (idType case_bndr)
1918 all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId]
1919 is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
1920
1921 scrut_is_demanded_var :: CoreExpr -> Bool
1922 -- See Note [Eliminating redundant seqs]
1923 scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
1924 scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr)
1925 scrut_is_demanded_var _ = False
1926
1927
1928 rebuildCase env scrut case_bndr alts cont
1929 = reallyRebuildCase env scrut case_bndr alts cont
1930
1931 --------------------------------------------------
1932 -- 3. Catch-all case
1933 --------------------------------------------------
1934
1935 reallyRebuildCase env scrut case_bndr alts cont
1936 = do { -- Prepare the continuation;
1937 -- The new subst_env is in place
1938 (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1939
1940 -- Simplify the alternatives
1941 ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1942
1943 ; dflags <- getDynFlags
1944 ; let alts_ty' = contResultType dup_cont
1945 ; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts'
1946
1947 -- Notice that rebuild gets the in-scope set from env', not alt_env
1948 -- (which in any case is only build in simplAlts)
1949 -- The case binder *not* scope over the whole returned case-expression
1950 ; rebuild env' case_expr nodup_cont }
1951
1952 {-
1953 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1954 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1955 way, there's a chance that v will now only be used once, and hence
1956 inlined.
1957
1958 Historical note: we use to do the "case binder swap" in the Simplifier
1959 so there were additional complications if the scrutinee was a variable.
1960 Now the binder-swap stuff is done in the occurrence analyer; see
1961 OccurAnal Note [Binder swap].
1962
1963 Note [knownCon occ info]
1964 ~~~~~~~~~~~~~~~~~~~~~~~~
1965 If the case binder is not dead, then neither are the pattern bound
1966 variables:
1967 case <any> of x { (a,b) ->
1968 case x of { (p,q) -> p } }
1969 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1970 The point is that we bring into the envt a binding
1971 let x = (a,b)
1972 after the outer case, and that makes (a,b) alive. At least we do unless
1973 the case binder is guaranteed dead.
1974
1975 Note [Case alternative occ info]
1976 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1977 When we are simply reconstructing a case (the common case), we always
1978 zap the occurrence info on the binders in the alternatives. Even
1979 if the case binder is dead, the scrutinee is usually a variable, and *that*
1980 can bring the case-alternative binders back to life.
1981 See Note [Add unfolding for scrutinee]
1982
1983 Note [Improving seq]
1984 ~~~~~~~~~~~~~~~~~~~
1985 Consider
1986 type family F :: * -> *
1987 type instance F Int = Int
1988
1989 ... case e of x { DEFAULT -> rhs } ...
1990
1991 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
1992
1993 case e `cast` co of x'::Int
1994 I# x# -> let x = x' `cast` sym co
1995 in rhs
1996
1997 so that 'rhs' can take advantage of the form of x'.
1998
1999 Notice that Note [Case of cast] (in OccurAnal) may then apply to the result.
2000
2001 Nota Bene: We only do the [Improving seq] transformation if the
2002 case binder 'x' is actually used in the rhs; that is, if the case
2003 is *not* a *pure* seq.
2004 a) There is no point in adding the cast to a pure seq.
2005 b) There is a good reason not to: doing so would interfere
2006 with seq rules (Note [Built-in RULES for seq] in MkId).
2007 In particular, this [Improving seq] thing *adds* a cast
2008 while [Built-in RULES for seq] *removes* one, so they
2009 just flip-flop.
2010
2011 You might worry about
2012 case v of x { __DEFAULT ->
2013 ... case (v `cast` co) of y { I# -> ... }}
2014 This is a pure seq (since x is unused), so [Improving seq] won't happen.
2015 But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get
2016 case v of x { __DEFAULT ->
2017 ... case (x `cast` co) of y { I# -> ... }}
2018 Now the outer case is not a pure seq, so [Improving seq] will happen,
2019 and then the inner case will disappear.
2020
2021 The need for [Improving seq] showed up in Roman's experiments. Example:
2022 foo :: F Int -> Int -> Int
2023 foo t n = t `seq` bar n
2024 where
2025 bar 0 = 0
2026 bar n = bar (n - case t of TI i -> i)
2027 Here we'd like to avoid repeated evaluating t inside the loop, by
2028 taking advantage of the `seq`.
2029
2030 At one point I did transformation in LiberateCase, but it's more
2031 robust here. (Otherwise, there's a danger that we'll simply drop the
2032 'seq' altogether, before LiberateCase gets to see it.)
2033 -}
2034
2035 simplAlts :: SimplEnv
2036 -> OutExpr
2037 -> InId -- Case binder
2038 -> [InAlt] -- Non-empty
2039 -> SimplCont
2040 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
2041 -- Like simplExpr, this just returns the simplified alternatives;
2042 -- it does not return an environment
2043 -- The returned alternatives can be empty, none are possible
2044
2045 simplAlts env scrut case_bndr alts cont'
2046 = do { let env0 = zapFloats env
2047
2048 ; (env1, case_bndr1) <- simplBinder env0 case_bndr
2049
2050 ; fam_envs <- getFamEnvs
2051 ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut
2052 case_bndr case_bndr1 alts
2053
2054 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
2055 -- NB: it's possible that the returned in_alts is empty: this is handled
2056 -- by the caller (rebuildCase) in the missingAlt function
2057
2058 ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
2059 ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
2060 return (scrut', case_bndr', alts') }
2061
2062
2063 ------------------------------------
2064 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
2065 -> OutExpr -> InId -> OutId -> [InAlt]
2066 -> SimplM (SimplEnv, OutExpr, OutId)
2067 -- Note [Improving seq]
2068 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
2069 | not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq]
2070 , Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
2071 = do { case_bndr2 <- newId (fsLit "nt") ty2
2072 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
2073 env2 = extendIdSubst env case_bndr rhs
2074 ; return (env2, scrut `Cast` co, case_bndr2) }
2075
2076 improveSeq _ env scrut _ case_bndr1 _
2077 = return (env, scrut, case_bndr1)
2078
2079
2080 ------------------------------------
2081 simplAlt :: SimplEnv
2082 -> Maybe OutExpr -- The scrutinee
2083 -> [AltCon] -- These constructors can't be present when
2084 -- matching the DEFAULT alternative
2085 -> OutId -- The case binder
2086 -> SimplCont
2087 -> InAlt
2088 -> SimplM OutAlt
2089
2090 simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
2091 = ASSERT( null bndrs )
2092 do { let env' = addBinderUnfolding env case_bndr'
2093 (mkOtherCon imposs_deflt_cons)
2094 -- Record the constructors that the case-binder *can't* be.
2095 ; rhs' <- simplExprC env' rhs cont'
2096 ; return (DEFAULT, [], rhs') }
2097
2098 simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
2099 = ASSERT( null bndrs )
2100 do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)
2101 ; rhs' <- simplExprC env' rhs cont'
2102 ; return (LitAlt lit, [], rhs') }
2103
2104 simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
2105 = do { -- Deal with the pattern-bound variables
2106 -- Mark the ones that are in ! positions in the
2107 -- data constructor as certainly-evaluated.
2108 -- NB: simplLamBinders preserves this eval info
2109 ; let vs_with_evals = add_evals (dataConRepStrictness con)
2110 ; (env', vs') <- simplLamBndrs env vs_with_evals
2111
2112 -- Bind the case-binder to (con args)
2113 ; let inst_tys' = tyConAppArgs (idType case_bndr')
2114 con_app :: OutExpr
2115 con_app = mkConApp2 con inst_tys' vs'
2116
2117 ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
2118 ; rhs' <- simplExprC env'' rhs cont'
2119 ; return (DataAlt con, vs', rhs') }
2120 where
2121 -- add_evals records the evaluated-ness of the bound variables of
2122 -- a case pattern. This is *important*. Consider
2123 -- data T = T !Int !Int
2124 --
2125 -- case x of { T a b -> T (a+1) b }
2126 --
2127 -- We really must record that b is already evaluated so that we don't
2128 -- go and re-evaluate it when constructing the result.
2129 -- See Note [Data-con worker strictness] in MkId.lhs
2130 add_evals the_strs
2131 = go vs the_strs
2132 where
2133 go [] [] = []
2134 go (v:vs') strs | isTyVar v = v : go vs' strs
2135 go (v:vs') (str:strs)
2136 | isMarkedStrict str = evald_v : go vs' strs
2137 | otherwise = zapped_v : go vs' strs
2138 where
2139 zapped_v = zapIdOccInfo v -- See Note [Case alternative occ info]
2140 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
2141 go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
2142
2143
2144 addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
2145 addAltUnfoldings env scrut case_bndr con_app
2146 = do { dflags <- getDynFlags
2147 ; let con_app_unf = mkSimpleUnfolding dflags con_app
2148 env1 = addBinderUnfolding env case_bndr con_app_unf
2149
2150 -- See Note [Add unfolding for scrutinee]
2151 env2 = case scrut of
2152 Just (Var v) -> addBinderUnfolding env1 v con_app_unf
2153 Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
2154 mkSimpleUnfolding dflags (Cast con_app (mkSymCo co))
2155 _ -> env1
2156
2157 ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
2158 ; return env2 }
2159
2160 addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
2161 addBinderUnfolding env bndr unf
2162 | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
2163 = WARN( not (eqType (idType bndr) (exprType tmpl)),
2164 ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )
2165 modifyInScope env (bndr `setIdUnfolding` unf)
2166
2167 | otherwise
2168 = modifyInScope env (bndr `setIdUnfolding` unf)
2169
2170 zapBndrOccInfo :: Bool -> Id -> Id
2171 -- Consider case e of b { (a,b) -> ... }
2172 -- Then if we bind b to (a,b) in "...", and b is not dead,
2173 -- then we must zap the deadness info on a,b
2174 zapBndrOccInfo keep_occ_info pat_id
2175 | keep_occ_info = pat_id
2176 | otherwise = zapIdOccInfo pat_id
2177
2178 {-
2179 Note [Add unfolding for scrutinee]
2180 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2181 In general it's unlikely that a variable scrutinee will appear
2182 in the case alternatives case x of { ...x unlikely to appear... }
2183 because the binder-swap in OccAnal has got rid of all such occcurrences
2184 See Note [Binder swap] in OccAnal.
2185
2186 BUT it is still VERY IMPORTANT to add a suitable unfolding for a
2187 variable scrutinee, in simplAlt. Here's why
2188 case x of y
2189 (a,b) -> case b of c
2190 I# v -> ...(f y)...
2191 There is no occurrence of 'b' in the (...(f y)...). But y gets
2192 the unfolding (a,b), and *that* mentions b. If f has a RULE
2193 RULE f (p, I# q) = ...
2194 we want that rule to match, so we must extend the in-scope env with a
2195 suitable unfolding for 'y'. It's *essential* for rule matching; but
2196 it's also good for case-elimintation -- suppose that 'f' was inlined
2197 and did multi-level case analysis, then we'd solve it in one
2198 simplifier sweep instead of two.
2199
2200 Exactly the same issue arises in SpecConstr;
2201 see Note [Add scrutinee to ValueEnv too] in SpecConstr
2202
2203 HOWEVER, given
2204 case x of y { Just a -> r1; Nothing -> r2 }
2205 we do not want to add the unfolding x -> y to 'x', which might seem cool,
2206 since 'y' itself has different unfoldings in r1 and r2. Reason: if we
2207 did that, we'd have to zap y's deadness info and that is a very useful
2208 piece of information.
2209
2210 So instead we add the unfolding x -> Just a, and x -> Nothing in the
2211 respective RHSs.
2212
2213
2214 ************************************************************************
2215 * *
2216 \subsection{Known constructor}
2217 * *
2218 ************************************************************************
2219
2220 We are a bit careful with occurrence info. Here's an example
2221
2222 (\x* -> case x of (a*, b) -> f a) (h v, e)
2223
2224 where the * means "occurs once". This effectively becomes
2225 case (h v, e) of (a*, b) -> f a)
2226 and then
2227 let a* = h v; b = e in f a
2228 and then
2229 f (h v)
2230
2231 All this should happen in one sweep.
2232 -}
2233
2234 knownCon :: SimplEnv
2235 -> OutExpr -- The scrutinee
2236 -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces)
2237 -> InId -> [InBndr] -> InExpr -- The alternative
2238 -> SimplCont
2239 -> SimplM (SimplEnv, OutExpr)
2240
2241 knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
2242 = do { env' <- bind_args env bs dc_args
2243 ; env'' <- bind_case_bndr env'
2244 ; simplExprF env'' rhs cont }
2245 where
2246 zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId
2247
2248 -- Ugh!
2249 bind_args env' [] _ = return env'
2250
2251 bind_args env' (b:bs') (Type ty : args)
2252 = ASSERT( isTyVar b )
2253 bind_args (extendTvSubst env' b ty) bs' args
2254
2255 bind_args env' (b:bs') (arg : args)
2256 = ASSERT( isId b )
2257 do { let b' = zap_occ b
2258 -- Note that the binder might be "dead", because it doesn't
2259 -- occur in the RHS; and simplNonRecX may therefore discard
2260 -- it via postInlineUnconditionally.
2261 -- Nevertheless we must keep it if the case-binder is alive,
2262 -- because it may be used in the con_app. See Note [knownCon occ info]
2263 ; env'' <- simplNonRecX env' b' arg -- arg satisfies let/app invariant
2264 ; bind_args env'' bs' args }
2265
2266 bind_args _ _ _ =
2267 pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
2268 text "scrut:" <+> ppr scrut
2269
2270 -- It's useful to bind bndr to scrut, rather than to a fresh
2271 -- binding x = Con arg1 .. argn
2272 -- because very often the scrut is a variable, so we avoid
2273 -- creating, and then subsequently eliminating, a let-binding
2274 -- BUT, if scrut is a not a variable, we must be careful
2275 -- about duplicating the arg redexes; in that case, make
2276 -- a new con-app from the args
2277 bind_case_bndr env
2278 | isDeadBinder bndr = return env
2279 | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut))
2280 | otherwise = do { dc_args <- mapM (simplVar env) bs
2281 -- dc_ty_args are aready OutTypes,
2282 -- but bs are InBndrs
2283 ; let con_app = Var (dataConWorkId dc)
2284 `mkTyApps` dc_ty_args
2285 `mkApps` dc_args
2286 ; simplNonRecX env bndr con_app }
2287
2288 -------------------
2289 missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
2290 -- This isn't strictly an error, although it is unusual.
2291 -- It's possible that the simplifer might "see" that
2292 -- an inner case has no accessible alternatives before
2293 -- it "sees" that the entire branch of an outer case is
2294 -- inaccessible. So we simply put an error case here instead.
2295 missingAlt env case_bndr _ cont
2296 = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
2297 return (env, mkImpossibleExpr (contResultType cont))
2298
2299 {-
2300 ************************************************************************
2301 * *
2302 \subsection{Duplicating continuations}
2303 * *
2304 ************************************************************************
2305 -}
2306
2307 prepareCaseCont :: SimplEnv
2308 -> [InAlt] -> SimplCont
2309 -> SimplM (SimplEnv,
2310 SimplCont, -- Dupable part
2311 SimplCont) -- Non-dupable part
2312 -- We are considering
2313 -- K[case _ of { p1 -> r1; ...; pn -> rn }]
2314 -- where K is some enclosing continuation for the case
2315 -- Goal: split K into two pieces Kdup,Knodup so that
2316 -- a) Kdup can be duplicated
2317 -- b) Knodup[Kdup[e]] = K[e]
2318 -- The idea is that we'll transform thus:
2319 -- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
2320 --
2321 -- We may also return some extra bindings in SimplEnv (that scope over
2322 -- the entire continuation)
2323 --
2324 -- When case-of-case is off, just make the entire continuation non-dupable
2325
2326 prepareCaseCont env alts cont
2327 | not (sm_case_case (getMode env)) = return (env, mkBoringStop (contInputType cont), cont)
2328 | not (many_alts alts) = return (env, cont, mkBoringStop (contResultType cont))
2329 | otherwise = mkDupableCont env cont
2330 where
2331 many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
2332 many_alts [] = False -- See Note [Bottom alternatives]
2333 many_alts [_] = False
2334 many_alts (alt:alts)
2335 | is_bot_alt alt = many_alts alts
2336 | otherwise = not (all is_bot_alt alts)
2337
2338 is_bot_alt (_,_,rhs) = exprIsBottom rhs
2339
2340 {-
2341 Note [Bottom alternatives]
2342 ~~~~~~~~~~~~~~~~~~~~~~~~~~
2343 When we have
2344 case (case x of { A -> error .. ; B -> e; C -> error ..)
2345 of alts
2346 then we can just duplicate those alts because the A and C cases
2347 will disappear immediately. This is more direct than creating
2348 join points and inlining them away; and in some cases we would
2349 not even create the join points (see Note [Single-alternative case])
2350 and we would keep the case-of-case which is silly. See Trac #4930.
2351 -}
2352
2353 mkDupableCont :: SimplEnv -> SimplCont
2354 -> SimplM (SimplEnv, SimplCont, SimplCont)
2355
2356 mkDupableCont env cont
2357 | contIsDupable cont
2358 = return (env, cont, mkBoringStop (contResultType cont))
2359
2360 mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
2361
2362 mkDupableCont env (CoerceIt ty cont)
2363 = do { (env', dup, nodup) <- mkDupableCont env cont
2364 ; return (env', CoerceIt ty dup, nodup) }
2365
2366 -- Duplicating ticks for now, not sure if this is good or not
2367 mkDupableCont env cont@(TickIt{})
2368 = return (env, mkBoringStop (contInputType cont), cont)
2369
2370 mkDupableCont env cont@(StrictBind {})
2371 = return (env, mkBoringStop (contInputType cont), cont)
2372 -- See Note [Duplicating StrictBind]
2373
2374 mkDupableCont env (StrictArg info cci cont)
2375 -- See Note [Duplicating StrictArg]
2376 = do { (env', dup, nodup) <- mkDupableCont env cont
2377 ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info)
2378 ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
2379
2380 mkDupableCont env (ApplyTo _ arg se cont)
2381 = -- e.g. [...hole...] (...arg...)
2382 -- ==>
2383 -- let a = ...arg...
2384 -- in [...hole...] a
2385 do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
2386 ; arg' <- simplExpr (se `setInScope` env') arg
2387 ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
2388 ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
2389 ; return (env'', app_cont, nodup_cont) }
2390
2391 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
2392 -- See Note [Single-alternative case]
2393 -- | not (exprIsDupable rhs && contIsDupable case_cont)
2394 -- | not (isDeadBinder case_bndr)
2395 | all isDeadBinder bs -- InIds
2396 && not (isUnLiftedType (idType case_bndr))
2397 -- Note [Single-alternative-unlifted]
2398 = return (env, mkBoringStop (contInputType cont), cont)
2399
2400 mkDupableCont env (Select _ case_bndr alts se cont)
2401 = -- e.g. (case [...hole...] of { pi -> ei })
2402 -- ===>
2403 -- let ji = \xij -> ei
2404 -- in case [...hole...] of { pi -> ji xij }
2405 do { tick (CaseOfCase case_bndr)
2406 ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
2407 -- NB: We call prepareCaseCont here. If there is only one
2408 -- alternative, then dup_cont may be big, but that's ok
2409 -- because we push it into the single alternative, and then
2410 -- use mkDupableAlt to turn that simplified alternative into
2411 -- a join point if it's too big to duplicate.
2412 -- And this is important: see Note [Fusing case continuations]
2413
2414 ; let alt_env = se `setInScope` env'
2415
2416 ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
2417 ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
2418 -- Safe to say that there are no handled-cons for the DEFAULT case
2419 -- NB: simplBinder does not zap deadness occ-info, so
2420 -- a dead case_bndr' will still advertise its deadness
2421 -- This is really important because in
2422 -- case e of b { (# p,q #) -> ... }
2423 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
2424 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
2425 -- In the new alts we build, we have the new case binder, so it must retain
2426 -- its deadness.
2427 -- NB: we don't use alt_env further; it has the substEnv for
2428 -- the alternatives, and we don't want that
2429
2430 ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
2431 ; return (env'', -- Note [Duplicated env]
2432 Select OkToDup case_bndr' alts'' (zapSubstEnv env'')
2433 (mkBoringStop (contInputType nodup_cont)),
2434 nodup_cont) }
2435
2436
2437 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
2438 -> SimplM (SimplEnv, [InAlt])
2439 -- Absorbs the continuation into the new alternatives
2440
2441 mkDupableAlts env case_bndr' the_alts
2442 = go env the_alts
2443 where
2444 go env0 [] = return (env0, [])
2445 go env0 (alt:alts)
2446 = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
2447 ; (env2, alts') <- go env1 alts
2448 ; return (env2, alt' : alts' ) }
2449
2450 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
2451 -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
2452 mkDupableAlt env case_bndr (con, bndrs', rhs') = do
2453 dflags <- getDynFlags
2454 if exprIsDupable dflags rhs' -- Note [Small alternative rhs]
2455 then return (env, (con, bndrs', rhs'))
2456 else
2457 do { let rhs_ty' = exprType rhs'
2458 scrut_ty = idType case_bndr
2459 case_bndr_w_unf
2460 = case con of
2461 DEFAULT -> case_bndr
2462 DataAlt dc -> setIdUnfolding case_bndr unf
2463 where
2464 -- See Note [Case binders and join points]
2465 unf = mkInlineUnfolding Nothing rhs
2466 rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
2467
2468 LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
2469 <+> ppr case_bndr <+> ppr con )
2470 case_bndr
2471 -- The case binder is alive but trivial, so why has
2472 -- it not been substituted away?
2473
2474 used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs'
2475 | otherwise = bndrs' ++ [case_bndr_w_unf]
2476
2477 abstract_over bndr
2478 | isTyVar bndr = True -- Abstract over all type variables just in case
2479 | otherwise = not (isDeadBinder bndr)
2480 -- The deadness info on the new Ids is preserved by simplBinders
2481
2482 ; (final_bndrs', final_args) -- Note [Join point abstraction]
2483 <- if (any isId used_bndrs')
2484 then return (used_bndrs', varsToCoreExprs used_bndrs')
2485 else do { rw_id <- newId (fsLit "w") voidPrimTy
2486 ; return ([setOneShotLambda rw_id], [Var voidPrimId]) }
2487
2488 ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
2489 -- Note [Funky mkPiTypes]
2490
2491 ; let -- We make the lambdas into one-shot-lambdas. The
2492 -- join point is sure to be applied at most once, and doing so
2493 -- prevents the body of the join point being floated out by
2494 -- the full laziness pass
2495 really_final_bndrs = map one_shot final_bndrs'
2496 one_shot v | isId v = setOneShotLambda v
2497 | otherwise = v
2498 join_rhs = mkLams really_final_bndrs rhs'
2499 join_arity = exprArity join_rhs
2500 join_call = mkApps (Var join_bndr) final_args
2501
2502 ; env' <- addPolyBind NotTopLevel env (NonRec (join_bndr `setIdArity` join_arity) join_rhs)
2503 ; return (env', (con, bndrs', join_call)) }
2504 -- See Note [Duplicated env]
2505
2506 {-
2507 Note [Fusing case continuations]
2508 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2509 It's important to fuse two successive case continuations when the
2510 first has one alternative. That's why we call prepareCaseCont here.
2511 Consider this, which arises from thunk splitting (see Note [Thunk
2512 splitting] in WorkWrap):
2513
2514 let
2515 x* = case (case v of {pn -> rn}) of
2516 I# a -> I# a
2517 in body
2518
2519 The simplifier will find
2520 (Var v) with continuation
2521 Select (pn -> rn) (
2522 Select [I# a -> I# a] (
2523 StrictBind body Stop
2524
2525 So we'll call mkDupableCont on
2526 Select [I# a -> I# a] (StrictBind body Stop)
2527 There is just one alternative in the first Select, so we want to
2528 simplify the rhs (I# a) with continuation (StricgtBind body Stop)
2529 Supposing that body is big, we end up with
2530 let $j a = <let x = I# a in body>
2531 in case v of { pn -> case rn of
2532 I# a -> $j a }
2533 This is just what we want because the rn produces a box that
2534 the case rn cancels with.
2535
2536 See Trac #4957 a fuller example.
2537
2538 Note [Case binders and join points]
2539 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2540 Consider this
2541 case (case .. ) of c {
2542 I# c# -> ....c....
2543
2544 If we make a join point with c but not c# we get
2545 $j = \c -> ....c....
2546
2547 But if later inlining scrutines the c, thus
2548
2549 $j = \c -> ... case c of { I# y -> ... } ...
2550
2551 we won't see that 'c' has already been scrutinised. This actually
2552 happens in the 'tabulate' function in wave4main, and makes a significant
2553 difference to allocation.
2554
2555 An alternative plan is this:
2556
2557 $j = \c# -> let c = I# c# in ...c....
2558
2559 but that is bad if 'c' is *not* later scrutinised.
2560
2561 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
2562 (a stable unfolding) that it's really I# c#, thus
2563
2564 $j = \c# -> \c[=I# c#] -> ...c....
2565
2566 Absence analysis may later discard 'c'.
2567
2568 NB: take great care when doing strictness analysis;
2569 see Note [Lamba-bound unfoldings] in DmdAnal.
2570
2571 Also note that we can still end up passing stuff that isn't used. Before
2572 strictness analysis we have
2573 let $j x y c{=(x,y)} = (h c, ...)
2574 in ...
2575 After strictness analysis we see that h is strict, we end up with
2576 let $j x y c{=(x,y)} = ($wh x y, ...)
2577 and c is unused.
2578
2579 Note [Duplicated env]
2580 ~~~~~~~~~~~~~~~~~~~~~
2581 Some of the alternatives are simplified, but have not been turned into a join point
2582 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
2583 bind the join point, because it might to do PostInlineUnconditionally, and
2584 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
2585 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
2586 at worst delays the join-point inlining.
2587
2588 Note [Small alternative rhs]
2589 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2590 It is worth checking for a small RHS because otherwise we
2591 get extra let bindings that may cause an extra iteration of the simplifier to
2592 inline back in place. Quite often the rhs is just a variable or constructor.
2593 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
2594 iterations because the version with the let bindings looked big, and so wasn't
2595 inlined, but after the join points had been inlined it looked smaller, and so
2596 was inlined.
2597
2598 NB: we have to check the size of rhs', not rhs.
2599 Duplicating a small InAlt might invalidate occurrence information
2600 However, if it *is* dupable, we return the *un* simplified alternative,
2601 because otherwise we'd need to pair it up with an empty subst-env....
2602 but we only have one env shared between all the alts.
2603 (Remember we must zap the subst-env before re-simplifying something).
2604 Rather than do this we simply agree to re-simplify the original (small) thing later.
2605
2606 Note [Funky mkPiTypes]
2607 ~~~~~~~~~~~~~~~~~~~~~~
2608 Notice the funky mkPiTypes. If the contructor has existentials
2609 it's possible that the join point will be abstracted over
2610 type varaibles as well as term variables.
2611 Example: Suppose we have
2612 data T = forall t. C [t]
2613 Then faced with
2614 case (case e of ...) of
2615 C t xs::[t] -> rhs
2616 We get the join point
2617 let j :: forall t. [t] -> ...
2618 j = /\t \xs::[t] -> rhs
2619 in
2620 case (case e of ...) of
2621 C t xs::[t] -> j t xs
2622
2623 Note [Join point abstraction]
2624 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2625 Join points always have at least one value argument,
2626 for several reasons
2627
2628 * If we try to lift a primitive-typed something out
2629 for let-binding-purposes, we will *caseify* it (!),
2630 with potentially-disastrous strictness results. So
2631 instead we turn it into a function: \v -> e
2632 where v::Void#. The value passed to this function is void,
2633 which generates (almost) no code.
2634
2635 * CPR. We used to say "&& isUnLiftedType rhs_ty'" here, but now
2636 we make the join point into a function whenever used_bndrs'
2637 is empty. This makes the join-point more CPR friendly.
2638 Consider: let j = if .. then I# 3 else I# 4
2639 in case .. of { A -> j; B -> j; C -> ... }
2640
2641 Now CPR doesn't w/w j because it's a thunk, so
2642 that means that the enclosing function can't w/w either,
2643 which is a lose. Here's the example that happened in practice:
2644 kgmod :: Int -> Int -> Int
2645 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2646 then 78
2647 else 5
2648
2649 * Let-no-escape. We want a join point to turn into a let-no-escape
2650 so that it is implemented as a jump, and one of the conditions
2651 for LNE is that it's not updatable. In CoreToStg, see
2652 Note [What is a non-escaping let]
2653
2654 * Floating. Since a join point will be entered once, no sharing is
2655 gained by floating out, but something might be lost by doing
2656 so because it might be allocated.
2657
2658 I have seen a case alternative like this:
2659 True -> \v -> ...
2660 It's a bit silly to add the realWorld dummy arg in this case, making
2661 $j = \s v -> ...
2662 True -> $j s
2663 (the \v alone is enough to make CPR happy) but I think it's rare
2664
2665 There's a slight infelicity here: we pass the overall
2666 case_bndr to all the join points if it's used in *any* RHS,
2667 because we don't know its usage in each RHS separately
2668
2669
2670 Note [Duplicating StrictArg]
2671 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2672 The original plan had (where E is a big argument)
2673 e.g. f E [..hole..]
2674 ==> let $j = \a -> f E a
2675 in $j [..hole..]
2676
2677 But this is terrible! Here's an example:
2678 && E (case x of { T -> F; F -> T })
2679 Now, && is strict so we end up simplifying the case with
2680
2681 an ArgOf continuation. If we let-bind it, we get
2682 let $j = \v -> && E v
2683 in simplExpr (case x of { T -> F; F -> T })
2684 (ArgOf (\r -> $j r)
2685 And after simplifying more we get
2686 let $j = \v -> && E v
2687 in case x of { T -> $j F; F -> $j T }
2688 Which is a Very Bad Thing
2689
2690 What we do now is this
2691 f E [..hole..]
2692 ==> let a = E
2693 in f a [..hole..]
2694 Now if the thing in the hole is a case expression (which is when
2695 we'll call mkDupableCont), we'll push the function call into the
2696 branches, which is what we want. Now RULES for f may fire, and
2697 call-pattern specialisation. Here's an example from Trac #3116
2698 go (n+1) (case l of
2699 1 -> bs'
2700 _ -> Chunk p fpc (o+1) (l-1) bs')
2701 If we can push the call for 'go' inside the case, we get
2702 call-pattern specialisation for 'go', which is *crucial* for
2703 this program.
2704
2705 Here is the (&&) example:
2706 && E (case x of { T -> F; F -> T })
2707 ==> let a = E in
2708 case x of { T -> && a F; F -> && a T }
2709 Much better!
2710
2711 Notice that
2712 * Arguments to f *after* the strict one are handled by
2713 the ApplyTo case of mkDupableCont. Eg
2714 f [..hole..] E
2715
2716 * We can only do the let-binding of E because the function
2717 part of a StrictArg continuation is an explicit syntax
2718 tree. In earlier versions we represented it as a function
2719 (CoreExpr -> CoreEpxr) which we couldn't take apart.
2720
2721 Do *not* duplicate StrictBind and StritArg continuations. We gain
2722 nothing by propagating them into the expressions, and we do lose a
2723 lot.
2724
2725 The desire not to duplicate is the entire reason that
2726 mkDupableCont returns a pair of continuations.
2727
2728 Note [Duplicating StrictBind]
2729 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2730 Unlike StrictArg, there doesn't seem anything to gain from
2731 duplicating a StrictBind continuation, so we don't.
2732
2733
2734 Note [Single-alternative cases]
2735 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2736 This case is just like the ArgOf case. Here's an example:
2737 data T a = MkT !a
2738 ...(MkT (abs x))...
2739 Then we get
2740 case (case x of I# x' ->
2741 case x' <# 0# of
2742 True -> I# (negate# x')
2743 False -> I# x') of y {
2744 DEFAULT -> MkT y
2745 Because the (case x) has only one alternative, we'll transform to
2746 case x of I# x' ->
2747 case (case x' <# 0# of
2748 True -> I# (negate# x')
2749 False -> I# x') of y {
2750 DEFAULT -> MkT y
2751 But now we do *NOT* want to make a join point etc, giving
2752 case x of I# x' ->
2753 let $j = \y -> MkT y
2754 in case x' <# 0# of
2755 True -> $j (I# (negate# x'))
2756 False -> $j (I# x')
2757 In this case the $j will inline again, but suppose there was a big
2758 strict computation enclosing the orginal call to MkT. Then, it won't
2759 "see" the MkT any more, because it's big and won't get duplicated.
2760 And, what is worse, nothing was gained by the case-of-case transform.
2761
2762 So, in circumstances like these, we don't want to build join points
2763 and push the outer case into the branches of the inner one. Instead,
2764 don't duplicate the continuation.
2765
2766 When should we use this strategy? We should not use it on *every*
2767 single-alternative case:
2768 e.g. case (case ....) of (a,b) -> (# a,b #)
2769 Here we must push the outer case into the inner one!
2770 Other choices:
2771
2772 * Match [(DEFAULT,_,_)], but in the common case of Int,
2773 the alternative-filling-in code turned the outer case into
2774 case (...) of y { I# _ -> MkT y }
2775
2776 * Match on single alternative plus (not (isDeadBinder case_bndr))
2777 Rationale: pushing the case inwards won't eliminate the construction.
2778 But there's a risk of
2779 case (...) of y { (a,b) -> let z=(a,b) in ... }
2780 Now y looks dead, but it'll come alive again. Still, this
2781 seems like the best option at the moment.
2782
2783 * Match on single alternative plus (all (isDeadBinder bndrs))
2784 Rationale: this is essentially seq.
2785
2786 * Match when the rhs is *not* duplicable, and hence would lead to a
2787 join point. This catches the disaster-case above. We can test
2788 the *un-simplified* rhs, which is fine. It might get bigger or
2789 smaller after simplification; if it gets smaller, this case might
2790 fire next time round. NB also that we must test contIsDupable
2791 case_cont *too, because case_cont might be big!
2792
2793 HOWEVER: I found that this version doesn't work well, because
2794 we can get let x = case (...) of { small } in ...case x...
2795 When x is inlined into its full context, we find that it was a bad
2796 idea to have pushed the outer case inside the (...) case.
2797
2798 Note [Single-alternative-unlifted]
2799 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2800 Here's another single-alternative where we really want to do case-of-case:
2801
2802 data Mk1 = Mk1 Int# | Mk2 Int#
2803
2804 M1.f =
2805 \r [x_s74 y_s6X]
2806 case
2807 case y_s6X of tpl_s7m {
2808 M1.Mk1 ipv_s70 -> ipv_s70;
2809 M1.Mk2 ipv_s72 -> ipv_s72;
2810 }
2811 of
2812 wild_s7c
2813 { __DEFAULT ->
2814 case
2815 case x_s74 of tpl_s7n {
2816 M1.Mk1 ipv_s77 -> ipv_s77;
2817 M1.Mk2 ipv_s79 -> ipv_s79;
2818 }
2819 of
2820 wild1_s7b
2821 { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2822 };
2823 };
2824
2825 So the outer case is doing *nothing at all*, other than serving as a
2826 join-point. In this case we really want to do case-of-case and decide
2827 whether to use a real join point or just duplicate the continuation:
2828
2829 let $j s7c = case x of
2830 Mk1 ipv77 -> (==) s7c ipv77
2831 Mk1 ipv79 -> (==) s7c ipv79
2832 in
2833 case y of
2834 Mk1 ipv70 -> $j ipv70
2835 Mk2 ipv72 -> $j ipv72
2836
2837 Hence: check whether the case binder's type is unlifted, because then
2838 the outer case is *not* a seq.
2839 -}