Fix an obscure but terrible bug in the simplifier (Trac #9567)
[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 ( 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 arg = return (env, arg) -- CastBy, TyArg
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
929 simplExprF1 env (App fun arg) cont
930 = simplExprF env fun $
931 case arg of
932 Type ty -> ApplyToTy { sc_arg_ty = substTy env ty
933 , sc_hole_ty = substTy env (exprType fun)
934 , sc_cont = cont }
935 _ -> ApplyToVal { sc_arg = arg, sc_env = env
936 , sc_dup = NoDup, sc_cont = cont }
937
938 simplExprF1 env expr@(Lam {}) cont
939 = simplLam env zapped_bndrs body cont
940 -- The main issue here is under-saturated lambdas
941 -- (\x1. \x2. e) arg1
942 -- Here x1 might have "occurs-once" occ-info, because occ-info
943 -- is computed assuming that a group of lambdas is applied
944 -- all at once. If there are too few args, we must zap the
945 -- occ-info, UNLESS the remaining binders are one-shot
946 where
947 (bndrs, body) = collectBinders expr
948 zapped_bndrs | need_to_zap = map zap bndrs
949 | otherwise = bndrs
950
951 need_to_zap = any zappable_bndr (drop n_args bndrs)
952 n_args = countArgs cont
953 -- NB: countArgs counts all the args (incl type args)
954 -- and likewise drop counts all binders (incl type lambdas)
955
956 zappable_bndr b = isId b && not (isOneShotBndr b)
957 zap b | isTyVar b = b
958 | otherwise = zapLamIdInfo b
959
960 simplExprF1 env (Case scrut bndr _ alts) cont
961 = simplExprF env scrut (Select NoDup bndr alts env cont)
962
963 simplExprF1 env (Let (Rec pairs) body) cont
964 = do { env' <- simplRecBndrs env (map fst pairs)
965 -- NB: bndrs' don't have unfoldings or rules
966 -- We add them as we go down
967
968 ; env'' <- simplRecBind env' NotTopLevel pairs
969 ; simplExprF env'' body cont }
970
971 simplExprF1 env (Let (NonRec bndr rhs) body) cont
972 = simplNonRecE env bndr (rhs, env) ([], body) cont
973
974 ---------------------------------
975 simplType :: SimplEnv -> InType -> SimplM OutType
976 -- Kept monadic just so we can do the seqType
977 simplType env ty
978 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
979 seqType new_ty `seq` return new_ty
980 where
981 new_ty = substTy env ty
982
983 ---------------------------------
984 simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
985 -> SimplM (SimplEnv, OutExpr)
986 simplCoercionF env co cont
987 = do { co' <- simplCoercion env co
988 ; rebuild env (Coercion co') cont }
989
990 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
991 simplCoercion env co
992 = let opt_co = optCoercion (getCvSubst env) co
993 in seqCo opt_co `seq` return opt_co
994
995 -----------------------------------
996 -- | Push a TickIt context outwards past applications and cases, as
997 -- long as this is a non-scoping tick, to let case and application
998 -- optimisations apply.
999
1000 simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
1001 -> SimplM (SimplEnv, OutExpr)
1002 simplTick env tickish expr cont
1003 -- A scoped tick turns into a continuation, so that we can spot
1004 -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do
1005 -- it this way, then it would take two passes of the simplifier to
1006 -- reduce ((scc t (\x . e)) e').
1007 -- NB, don't do this with counting ticks, because if the expr is
1008 -- bottom, then rebuildCall will discard the continuation.
1009
1010 -- XXX: we cannot do this, because the simplifier assumes that
1011 -- the context can be pushed into a case with a single branch. e.g.
1012 -- scc<f> case expensive of p -> e
1013 -- becomes
1014 -- case expensive of p -> scc<f> e
1015 --
1016 -- So I'm disabling this for now. It just means we will do more
1017 -- simplifier iterations that necessary in some cases.
1018
1019 -- | tickishScoped tickish && not (tickishCounts tickish)
1020 -- = simplExprF env expr (TickIt tickish cont)
1021
1022 -- For non-scoped ticks, we push the continuation inside the
1023 -- tick. This has the effect of moving the tick to the outside of a
1024 -- case or application context, allowing the normal case and
1025 -- application optimisations to fire.
1026 | not (tickishScoped tickish)
1027 = do { (env', expr') <- simplExprF env expr cont
1028 ; return (env', mkTick tickish expr')
1029 }
1030
1031 -- For breakpoints, we cannot do any floating of bindings around the
1032 -- tick, because breakpoints cannot be split into tick/scope pairs.
1033 | not (tickishCanSplit tickish)
1034 = no_floating_past_tick
1035
1036 | interesting_cont, Just expr' <- push_tick_inside tickish expr
1037 -- see Note [case-of-scc-of-case]
1038 = simplExprF env expr' cont
1039
1040 | otherwise
1041 = no_floating_past_tick -- was: wrap_floats, see below
1042
1043 where
1044 interesting_cont = case cont of
1045 Select {} -> True
1046 _ -> False
1047
1048 push_tick_inside t expr0
1049 = ASSERT(tickishScoped t)
1050 case expr0 of
1051 Tick t' expr
1052 -- scc t (tick t' E)
1053 -- Pull the tick to the outside
1054 -- This one is important for #5363
1055 | not (tickishScoped t')
1056 -> Just (Tick t' (Tick t expr))
1057
1058 -- scc t (scc t' E)
1059 -- Try to push t' into E first, and if that works,
1060 -- try to push t in again
1061 | Just expr' <- push_tick_inside t' expr
1062 -> push_tick_inside t expr'
1063
1064 | otherwise -> Nothing
1065
1066 Case scrut bndr ty alts
1067 | not (tickishCanSplit t) -> Nothing
1068 | otherwise -> Just (Case (mkTick t scrut) bndr ty alts')
1069 where t_scope = mkNoCount t -- drop the tick on the dup'd ones
1070 alts' = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
1071
1072 _other -> Nothing
1073 where
1074
1075 no_floating_past_tick =
1076 do { let (inc,outc) = splitCont cont
1077 ; (env', expr') <- simplExprF (zapFloats env) expr inc
1078 ; let tickish' = simplTickish env tickish
1079 ; (env'', expr'') <- rebuild (zapFloats env')
1080 (wrapFloats env' expr')
1081 (TickIt tickish' outc)
1082 ; return (addFloats env env'', expr'')
1083 }
1084
1085 -- Alternative version that wraps outgoing floats with the tick. This
1086 -- results in ticks being duplicated, as we don't make any attempt to
1087 -- eliminate the tick if we re-inline the binding (because the tick
1088 -- semantics allows unrestricted inlining of HNFs), so I'm not doing
1089 -- this any more. FloatOut will catch any real opportunities for
1090 -- floating.
1091 --
1092 -- wrap_floats =
1093 -- do { let (inc,outc) = splitCont cont
1094 -- ; (env', expr') <- simplExprF (zapFloats env) expr inc
1095 -- ; let tickish' = simplTickish env tickish
1096 -- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),
1097 -- mkTick (mkNoCount tickish') rhs)
1098 -- -- when wrapping a float with mkTick, we better zap the Id's
1099 -- -- strictness info and arity, because it might be wrong now.
1100 -- ; let env'' = addFloats env (mapFloats env' wrap_float)
1101 -- ; rebuild env'' expr' (TickIt tickish' outc)
1102 -- }
1103
1104
1105 simplTickish env tickish
1106 | Breakpoint n ids <- tickish
1107 = Breakpoint n (map (getDoneId . substId env) ids)
1108 | otherwise = tickish
1109
1110 -- Push type application and coercion inside a tick
1111 splitCont :: SimplCont -> (SimplCont, SimplCont)
1112 splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)
1113 where (inc,outc) = splitCont tail
1114 splitCont (CastIt co c) = (CastIt co inc, outc)
1115 where (inc,outc) = splitCont c
1116 splitCont other = (mkBoringStop (contHoleType other), other)
1117
1118 getDoneId (DoneId id) = id
1119 getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
1120 getDoneId other = pprPanic "getDoneId" (ppr other)
1121
1122 -- Note [case-of-scc-of-case]
1123 -- It's pretty important to be able to transform case-of-case when
1124 -- there's an SCC in the way. For example, the following comes up
1125 -- in nofib/real/compress/Encode.hs:
1126 --
1127 -- case scctick<code_string.r1>
1128 -- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje
1129 -- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->
1130 -- (ww1_s13f, ww2_s13g, ww3_s13h)
1131 -- }
1132 -- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->
1133 -- tick<code_string.f1>
1134 -- (ww_s12Y,
1135 -- ww1_s12Z,
1136 -- PTTrees.PT
1137 -- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)
1138 -- }
1139 --
1140 -- We really want this case-of-case to fire, because then the 3-tuple
1141 -- will go away (indeed, the CPR optimisation is relying on this
1142 -- happening). But the scctick is in the way - we need to push it
1143 -- inside to expose the case-of-case. So we perform this
1144 -- transformation on the inner case:
1145 --
1146 -- scctick c (case e of { p1 -> e1; ...; pn -> en })
1147 -- ==>
1148 -- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }
1149 --
1150 -- So we've moved a constant amount of work out of the scc to expose
1151 -- the case. We only do this when the continuation is interesting: in
1152 -- for now, it has to be another Case (maybe generalise this later).
1153
1154 {-
1155 ************************************************************************
1156 * *
1157 \subsection{The main rebuilder}
1158 * *
1159 ************************************************************************
1160 -}
1161
1162 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
1163 -- At this point the substitution in the SimplEnv should be irrelevant
1164 -- only the in-scope set and floats should matter
1165 rebuild env expr cont
1166 = case cont of
1167 Stop {} -> return (env, expr)
1168 TickIt t cont -> rebuild env (mkTick t expr) cont
1169 CastIt co cont -> rebuild env (mkCast expr co) cont
1170 -- NB: mkCast implements the (Coercion co |> g) optimisation
1171
1172 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
1173 StrictArg info _ cont -> rebuildCall env (info `addValArgTo` expr) cont
1174
1175 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
1176 -- expr satisfies let/app since it started life
1177 -- in a call to simplNonRecE
1178 ; simplLam env' bs body cont }
1179
1180 ApplyToTy { sc_arg_ty = ty, sc_cont = cont}
1181 -> rebuild env (App expr (Type ty)) cont
1182 ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}
1183 -- See Note [Avoid redundant simplification]
1184 | isSimplified dup_flag -> rebuild env (App expr arg) cont
1185 | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg
1186 ; rebuild env (App expr arg') cont }
1187
1188
1189 {-
1190 ************************************************************************
1191 * *
1192 \subsection{Lambdas}
1193 * *
1194 ************************************************************************
1195 -}
1196
1197 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
1198 -> SimplM (SimplEnv, OutExpr)
1199 simplCast env body co0 cont0
1200 = do { co1 <- simplCoercion env co0
1201 ; -- pprTrace "simplCast" (ppr co1) $
1202 simplExprF env body (addCoerce co1 cont0) }
1203 where
1204 addCoerce co cont = add_coerce co (coercionKind co) cont
1205
1206 add_coerce _co (Pair s1 k1) cont -- co :: ty~ty
1207 | s1 `eqType` k1 = cont -- is a no-op
1208
1209 add_coerce co1 (Pair s1 _k2) (CastIt co2 cont)
1210 | (Pair _l1 t1) <- coercionKind co2
1211 -- e |> (g1 :: S1~L) |> (g2 :: L~T1)
1212 -- ==>
1213 -- e, if S1=T1
1214 -- e |> (g1 . g2 :: S1~T1) otherwise
1215 --
1216 -- For example, in the initial form of a worker
1217 -- we may find (coerce T (coerce S (\x.e))) y
1218 -- and we'd like it to simplify to e[y/x] in one round
1219 -- of simplification
1220 , s1 `eqType` t1 = cont -- The coerces cancel out
1221 | otherwise = CastIt (mkTransCo co1 co2) cont
1222
1223 add_coerce co (Pair s1s2 _t1t2) cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
1224 -- (f |> g) ty ---> (f ty) |> (g @ ty)
1225 -- This implements the PushT rule from the paper
1226 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
1227 = ASSERT( isTyVar tyvar )
1228 cont { sc_cont = addCoerce new_cast tail }
1229 where
1230 new_cast = mkInstCo co arg_ty
1231
1232 add_coerce co (Pair s1s2 t1t2) (ApplyToVal { sc_arg = arg, sc_env = arg_se
1233 , sc_dup = dup, sc_cont = cont })
1234 | isFunTy s1s2 -- This implements the Push rule from the paper
1235 , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg
1236 -- (e |> (g :: s1s2 ~ t1->t2)) f
1237 -- ===>
1238 -- (e (f |> (arg g :: t1~s1))
1239 -- |> (res g :: s2->t2)
1240 --
1241 -- t1t2 must be a function type, t1->t2, because it's applied
1242 -- to something but s1s2 might conceivably not be
1243 --
1244 -- When we build the ApplyTo we can't mix the out-types
1245 -- with the InExpr in the argument, so we simply substitute
1246 -- to make it all consistent. It's a bit messy.
1247 -- But it isn't a common case.
1248 --
1249 -- Example of use: Trac #995
1250 = ApplyToVal { sc_arg = mkCast arg' (mkSymCo co1)
1251 , sc_env = zapSubstEnv arg_se
1252 , sc_dup = dup
1253 , sc_cont = addCoerce co2 cont }
1254 where
1255 -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
1256 -- t2 ~ s2 with left and right on the curried form:
1257 -- (->) t1 t2 ~ (->) s1 s2
1258 [co1, co2] = decomposeCo 2 co
1259 arg' = substExpr (text "move-cast") arg_se' arg
1260 arg_se' = arg_se `setInScope` env
1261
1262 add_coerce co _ cont = CastIt co cont
1263
1264 {-
1265 ************************************************************************
1266 * *
1267 \subsection{Lambdas}
1268 * *
1269 ************************************************************************
1270
1271 Note [Zap unfolding when beta-reducing]
1272 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1273 Lambda-bound variables can have stable unfoldings, such as
1274 $j = \x. \b{Unf=Just x}. e
1275 See Note [Case binders and join points] below; the unfolding for lets
1276 us optimise e better. However when we beta-reduce it we want to
1277 revert to using the actual value, otherwise we can end up in the
1278 stupid situation of
1279 let x = blah in
1280 let b{Unf=Just x} = y
1281 in ...b...
1282 Here it'd be far better to drop the unfolding and use the actual RHS.
1283 -}
1284
1285 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
1286 -> SimplM (SimplEnv, OutExpr)
1287
1288 simplLam env [] body cont = simplExprF env body cont
1289
1290 -- Beta reduction
1291
1292 simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
1293 = do { tick (BetaReduction bndr)
1294 ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }
1295
1296 simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se
1297 , sc_cont = cont })
1298 = do { tick (BetaReduction bndr)
1299 ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
1300 where
1301 zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing]
1302 | isId bndr, isStableUnfolding (realIdUnfolding bndr)
1303 = setIdUnfolding bndr NoUnfolding
1304 | otherwise = bndr
1305
1306 -- discard a non-counting tick on a lambda. This may change the
1307 -- cost attribution slightly (moving the allocation of the
1308 -- lambda elsewhere), but we don't care: optimisation changes
1309 -- cost attribution all the time.
1310 simplLam env bndrs body (TickIt tickish cont)
1311 | not (tickishCounts tickish)
1312 = simplLam env bndrs body cont
1313
1314 -- Not enough args, so there are real lambdas left to put in the result
1315 simplLam env bndrs body cont
1316 = do { (env', bndrs') <- simplLamBndrs env bndrs
1317 ; body' <- simplExpr env' body
1318 ; new_lam <- mkLam bndrs' body' cont
1319 ; rebuild env' new_lam cont }
1320
1321 ------------------
1322 simplNonRecE :: SimplEnv
1323 -> InBndr -- The binder
1324 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
1325 -> ([InBndr], InExpr) -- Body of the let/lambda
1326 -- \xs.e
1327 -> SimplCont
1328 -> SimplM (SimplEnv, OutExpr)
1329
1330 -- simplNonRecE is used for
1331 -- * non-top-level non-recursive lets in expressions
1332 -- * beta reduction
1333 --
1334 -- It deals with strict bindings, via the StrictBind continuation,
1335 -- which may abort the whole process
1336 --
1337 -- Precondition: rhs satisfies the let/app invariant
1338 -- Note [CoreSyn let/app invariant] in CoreSyn
1339 --
1340 -- The "body" of the binding comes as a pair of ([InId],InExpr)
1341 -- representing a lambda; so we recurse back to simplLam
1342 -- Why? Because of the binder-occ-info-zapping done before
1343 -- the call to simplLam in simplExprF (Lam ...)
1344
1345 -- First deal with type applications and type lets
1346 -- (/\a. e) (Type ty) and (let a = Type ty in e)
1347 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
1348 = ASSERT( isTyVar bndr )
1349 do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
1350 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
1351
1352 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
1353 = do dflags <- getDynFlags
1354 case () of
1355 _ | preInlineUnconditionally dflags env NotTopLevel bndr rhs
1356 -> do { tick (PreInlineUnconditionally bndr)
1357 ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
1358 simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
1359
1360 | isStrictId bndr -- Includes coercions
1361 -> simplExprF (rhs_se `setFloats` env) rhs
1362 (StrictBind bndr bndrs body env cont)
1363
1364 | otherwise
1365 -> ASSERT( not (isTyVar bndr) )
1366 do { (env1, bndr1) <- simplNonRecBndr env bndr
1367 ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
1368 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
1369 ; simplLam env3 bndrs body cont }
1370
1371 {-
1372 ************************************************************************
1373 * *
1374 Variables
1375 * *
1376 ************************************************************************
1377 -}
1378
1379 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
1380 -- Look up an InVar in the environment
1381 simplVar env var
1382 | isTyVar var = return (Type (substTyVar env var))
1383 | isCoVar var = return (Coercion (substCoVar env var))
1384 | otherwise
1385 = case substId env var of
1386 DoneId var1 -> return (Var var1)
1387 DoneEx e -> return e
1388 ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
1389
1390 simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
1391 simplIdF env var cont
1392 = case substId env var of
1393 DoneEx e -> simplExprF (zapSubstEnv env) e cont
1394 ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
1395 DoneId var1 -> completeCall env var1 cont
1396 -- Note [zapSubstEnv]
1397 -- The template is already simplified, so don't re-substitute.
1398 -- This is VITAL. Consider
1399 -- let x = e in
1400 -- let y = \z -> ...x... in
1401 -- \ x -> ...y...
1402 -- We'll clone the inner \x, adding x->x' in the id_subst
1403 -- Then when we inline y, we must *not* replace x by x' in
1404 -- the inlined copy!!
1405
1406 ---------------------------------------------------------
1407 -- Dealing with a call site
1408
1409 completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr)
1410 completeCall env var cont
1411 = do { ------------- Try inlining ----------------
1412 dflags <- getDynFlags
1413 ; let (lone_variable, arg_infos, call_cont) = contArgs cont
1414 n_val_args = length arg_infos
1415 interesting_cont = interestingCallContext call_cont
1416 unfolding = activeUnfolding env var
1417 maybe_inline = callSiteInline dflags var unfolding
1418 lone_variable arg_infos interesting_cont
1419 ; case maybe_inline of {
1420 Just expr -- There is an inlining!
1421 -> do { checkedTick (UnfoldingDone var)
1422 ; dump_inline dflags expr cont
1423 ; simplExprF (zapSubstEnv env) expr cont }
1424
1425 ; Nothing -> do -- No inlining!
1426
1427 { rule_base <- getSimplRules
1428 ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
1429 ; rebuildCall env info cont
1430 }}}
1431 where
1432 dump_inline dflags unfolding cont
1433 | not (dopt Opt_D_dump_inlinings dflags) = return ()
1434 | not (dopt Opt_D_verbose_core2core dflags)
1435 = when (isExternalName (idName var)) $
1436 liftIO $ printInfoForUser dflags alwaysQualify $
1437 sep [text "Inlining done:", nest 4 (ppr var)]
1438 | otherwise
1439 = liftIO $ printInfoForUser dflags alwaysQualify $
1440 sep [text "Inlining done: " <> ppr var,
1441 nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
1442 text "Cont: " <+> ppr cont])]
1443
1444 rebuildCall :: SimplEnv
1445 -> ArgInfo
1446 -> SimplCont
1447 -> SimplM (SimplEnv, OutExpr)
1448 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
1449 -- When we run out of strictness args, it means
1450 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1451 -- Then we want to discard the entire strict continuation. E.g.
1452 -- * case (error "hello") of { ... }
1453 -- * (error "Hello") arg
1454 -- * f (error "Hello") where f is strict
1455 -- etc
1456 -- Then, especially in the first of these cases, we'd like to discard
1457 -- the continuation, leaving just the bottoming expression. But the
1458 -- type might not be right, so we may have to add a coerce.
1459 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1460 = return (env, castBottomExpr res cont_ty) -- contination to discard, else we do it
1461 where -- again and again!
1462 res = argInfoExpr fun rev_args
1463 cont_ty = contResultType cont
1464
1465 rebuildCall env info (CastIt co cont)
1466 = rebuildCall env (addCastTo info co) cont
1467
1468 rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
1469 = rebuildCall env (info `addTyArgTo` arg_ty) cont
1470
1471 rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
1472 , ai_strs = str:strs, ai_discs = disc:discs })
1473 (ApplyToVal { sc_arg = arg, sc_env = arg_se
1474 , sc_dup = dup_flag, sc_cont = cont })
1475 | isSimplified dup_flag -- See Note [Avoid redundant simplification]
1476 = rebuildCall env (addValArgTo info' arg) cont
1477
1478 | str -- Strict argument
1479 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1480 simplExprF (arg_se `setFloats` env) arg
1481 (StrictArg info' cci cont)
1482 -- Note [Shadowing]
1483
1484 | otherwise -- Lazy argument
1485 -- DO NOT float anything outside, hence simplExprC
1486 -- There is no benefit (unlike in a let-binding), and we'd
1487 -- have to be very careful about bogus strictness through
1488 -- floating a demanded let.
1489 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1490 (mkLazyArgStop (funArgTy fun_ty) cci)
1491 ; rebuildCall env (addValArgTo info' arg') cont }
1492 where
1493 info' = info { ai_strs = strs, ai_discs = discs }
1494 cci | encl_rules = RuleArgCtxt
1495 | disc > 0 = DiscArgCtxt -- Be keener here
1496 | otherwise = BoringCtxt -- Nothing interesting
1497
1498 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
1499 | null rules
1500 = rebuild env (argInfoExpr fun rev_args) cont -- No rules, common case
1501
1502 | otherwise
1503 = do { -- We've accumulated a simplified call in <fun,rev_args>
1504 -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
1505 -- See also Note [Rules for recursive functions]
1506 ; let env' = zapSubstEnv env -- See Note [zapSubstEnv];
1507 -- and NB that 'rev_args' are all fully simplified
1508 ; mb_rule <- tryRules env' rules fun (reverse rev_args) cont
1509 ; case mb_rule of {
1510 Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont'
1511
1512 -- Rules don't match
1513 ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules
1514 } }
1515
1516 {-
1517 Note [RULES apply to simplified arguments]
1518 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1519 It's very desirable to try RULES once the arguments have been simplified, because
1520 doing so ensures that rule cascades work in one pass. Consider
1521 {-# RULES g (h x) = k x
1522 f (k x) = x #-}
1523 ...f (g (h x))...
1524 Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
1525 we match f's rules against the un-simplified RHS, it won't match. This
1526 makes a particularly big difference when superclass selectors are involved:
1527 op ($p1 ($p2 (df d)))
1528 We want all this to unravel in one sweeep.
1529
1530 Note [Avoid redundant simplification]
1531 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1532 Because RULES apply to simplified arguments, there's a danger of repeatedly
1533 simplifying already-simplified arguments. An important example is that of
1534 (>>=) d e1 e2
1535 Here e1, e2 are simplified before the rule is applied, but don't really
1536 participate in the rule firing. So we mark them as Simplified to avoid
1537 re-simplifying them.
1538
1539 Note [Shadowing]
1540 ~~~~~~~~~~~~~~~~
1541 This part of the simplifier may break the no-shadowing invariant
1542 Consider
1543 f (...(\a -> e)...) (case y of (a,b) -> e')
1544 where f is strict in its second arg
1545 If we simplify the innermost one first we get (...(\a -> e)...)
1546 Simplifying the second arg makes us float the case out, so we end up with
1547 case y of (a,b) -> f (...(\a -> e)...) e'
1548 So the output does not have the no-shadowing invariant. However, there is
1549 no danger of getting name-capture, because when the first arg was simplified
1550 we used an in-scope set that at least mentioned all the variables free in its
1551 static environment, and that is enough.
1552
1553 We can't just do innermost first, or we'd end up with a dual problem:
1554 case x of (a,b) -> f e (...(\a -> e')...)
1555
1556 I spent hours trying to recover the no-shadowing invariant, but I just could
1557 not think of an elegant way to do it. The simplifier is already knee-deep in
1558 continuations. We have to keep the right in-scope set around; AND we have
1559 to get the effect that finding (error "foo") in a strict arg position will
1560 discard the entire application and replace it with (error "foo"). Getting
1561 all this at once is TOO HARD!
1562
1563
1564 ************************************************************************
1565 * *
1566 Rewrite rules
1567 * *
1568 ************************************************************************
1569 -}
1570
1571 tryRules :: SimplEnv -> [CoreRule]
1572 -> Id -> [ArgSpec] -> SimplCont
1573 -> SimplM (Maybe (CoreExpr, SimplCont))
1574 -- The SimplEnv already has zapSubstEnv applied to it
1575
1576 tryRules env rules fn args call_cont
1577 | null rules
1578 = return Nothing
1579 {- Disabled until we fix #8326
1580 | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#]
1581 , [_type_arg, val_arg] <- args
1582 , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont
1583 , isDeadBinder bndr
1584 = do { dflags <- getDynFlags
1585 ; let enum_to_tag :: CoreAlt -> CoreAlt
1586 -- Takes K -> e into tagK# -> e
1587 -- where tagK# is the tag of constructor K
1588 enum_to_tag (DataAlt con, [], rhs)
1589 = ASSERT( isEnumerationTyCon (dataConTyCon con) )
1590 (LitAlt tag, [], rhs)
1591 where
1592 tag = mkMachInt dflags (toInteger (dataConTag con - fIRST_TAG))
1593 enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)
1594
1595 new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts
1596 new_bndr = setIdType bndr intPrimTy
1597 -- The binder is dead, but should have the right type
1598 ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
1599 -}
1600 | otherwise
1601 = do { dflags <- getDynFlags
1602 ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)
1603 fn (argInfoAppArgs args) rules of {
1604 Nothing -> return Nothing ; -- No rule matches
1605 Just (rule, rule_rhs) ->
1606 do { checkedTick (RuleFired (ru_name rule))
1607 ; let cont' = pushSimplifiedArgs env
1608 (drop (ruleArity rule) args)
1609 call_cont
1610 -- (ruleArity rule) says how many args the rule consumed
1611 ; dump dflags rule rule_rhs
1612 ; return (Just (rule_rhs, cont')) }}}
1613 where
1614 dump dflags rule rule_rhs
1615 | dopt Opt_D_dump_rule_rewrites dflags
1616 = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
1617 [ text "Rule:" <+> ftext (ru_name rule)
1618 , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))
1619 , text "After: " <+> pprCoreExpr rule_rhs
1620 , text "Cont: " <+> ppr call_cont ]
1621
1622 | dopt Opt_D_dump_rule_firings dflags
1623 = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
1624 ftext (ru_name rule)
1625
1626 | otherwise
1627 = return ()
1628
1629 log_rule dflags flag hdr details
1630 = liftIO . dumpSDoc dflags alwaysQualify flag "" $
1631 sep [text hdr, nest 4 details]
1632
1633 {-
1634 Note [Optimising tagToEnum#]
1635 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1636 If we have an enumeration data type:
1637
1638 data Foo = A | B | C
1639
1640 Then we want to transform
1641
1642 case tagToEnum# x of ==> case x of
1643 A -> e1 DEFAULT -> e1
1644 B -> e2 1# -> e2
1645 C -> e3 2# -> e3
1646
1647 thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT
1648 alternative we retain it (remember it comes first). If not the case must
1649 be exhaustive, and we reflect that in the transformed version by adding
1650 a DEFAULT. Otherwise Lint complains that the new case is not exhaustive.
1651 See #8317.
1652
1653 Note [Rules for recursive functions]
1654 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1655 You might think that we shouldn't apply rules for a loop breaker:
1656 doing so might give rise to an infinite loop, because a RULE is
1657 rather like an extra equation for the function:
1658 RULE: f (g x) y = x+y
1659 Eqn: f a y = a-y
1660
1661 But it's too drastic to disable rules for loop breakers.
1662 Even the foldr/build rule would be disabled, because foldr
1663 is recursive, and hence a loop breaker:
1664 foldr k z (build g) = g k z
1665 So it's up to the programmer: rules can cause divergence
1666
1667
1668 ************************************************************************
1669 * *
1670 Rebuilding a case expression
1671 * *
1672 ************************************************************************
1673
1674 Note [Case elimination]
1675 ~~~~~~~~~~~~~~~~~~~~~~~
1676 The case-elimination transformation discards redundant case expressions.
1677 Start with a simple situation:
1678
1679 case x# of ===> let y# = x# in e
1680 y# -> e
1681
1682 (when x#, y# are of primitive type, of course). We can't (in general)
1683 do this for algebraic cases, because we might turn bottom into
1684 non-bottom!
1685
1686 The code in SimplUtils.prepareAlts has the effect of generalise this
1687 idea to look for a case where we're scrutinising a variable, and we
1688 know that only the default case can match. For example:
1689
1690 case x of
1691 0# -> ...
1692 DEFAULT -> ...(case x of
1693 0# -> ...
1694 DEFAULT -> ...) ...
1695
1696 Here the inner case is first trimmed to have only one alternative, the
1697 DEFAULT, after which it's an instance of the previous case. This
1698 really only shows up in eliminating error-checking code.
1699
1700 Note that SimplUtils.mkCase combines identical RHSs. So
1701
1702 case e of ===> case e of DEFAULT -> r
1703 True -> r
1704 False -> r
1705
1706 Now again the case may be elminated by the CaseElim transformation.
1707 This includes things like (==# a# b#)::Bool so that we simplify
1708 case ==# a# b# of { True -> x; False -> x }
1709 to just
1710 x
1711 This particular example shows up in default methods for
1712 comparison operations (e.g. in (>=) for Int.Int32)
1713
1714 Note [Case elimination: lifted case]
1715 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1716 If a case over a lifted type has a single alternative, and is being used
1717 as a strict 'let' (all isDeadBinder bndrs), we may want to do this
1718 transformation:
1719
1720 case e of r ===> let r = e in ...r...
1721 _ -> ...r...
1722
1723 (a) 'e' is already evaluated (it may so if e is a variable)
1724 Specifically we check (exprIsHNF e). In this case
1725 we can just allocate the WHNF directly with a let.
1726 or
1727 (b) 'x' is not used at all and e is ok-for-speculation
1728 The ok-for-spec bit checks that we don't lose any
1729 exceptions or divergence.
1730
1731 NB: it'd be *sound* to switch from case to let if the
1732 scrutinee was not yet WHNF but was guaranteed to
1733 converge; but sticking with case means we won't build a
1734 thunk
1735
1736 or
1737 (c) 'x' is used strictly in the body, and 'e' is a variable
1738 Then we can just substitute 'e' for 'x' in the body.
1739 See Note [Eliminating redundant seqs]
1740
1741 For (b), the "not used at all" test is important. Consider
1742 case (case a ># b of { True -> (p,q); False -> (q,p) }) of
1743 r -> blah
1744 The scrutinee is ok-for-speculation (it looks inside cases), but we do
1745 not want to transform to
1746 let r = case a ># b of { True -> (p,q); False -> (q,p) }
1747 in blah
1748 because that builds an unnecessary thunk.
1749
1750 Note [Eliminating redundant seqs]
1751 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1752 If we have this:
1753 case x of r { _ -> ..r.. }
1754 where 'r' is used strictly in (..r..), the case is effectively a 'seq'
1755 on 'x', but since 'r' is used strictly anyway, we can safely transform to
1756 (...x...)
1757
1758 Note that this can change the error behaviour. For example, we might
1759 transform
1760 case x of { _ -> error "bad" }
1761 --> error "bad"
1762 which is might be puzzling if 'x' currently lambda-bound, but later gets
1763 let-bound to (error "good").
1764
1765 Nevertheless, the paper "A semantics for imprecise exceptions" allows
1766 this transformation. If you want to fix the evaluation order, use
1767 'pseq'. See Trac #8900 for an example where the loss of this
1768 transformation bit us in practice.
1769
1770 See also Note [Empty case alternatives] in CoreSyn.
1771
1772 Just for reference, the original code (added Jan 13) looked like this:
1773 || case_bndr_evald_next rhs
1774
1775 case_bndr_evald_next :: CoreExpr -> Bool
1776 -- See Note [Case binder next]
1777 case_bndr_evald_next (Var v) = v == case_bndr
1778 case_bndr_evald_next (Cast e _) = case_bndr_evald_next e
1779 case_bndr_evald_next (App e _) = case_bndr_evald_next e
1780 case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e
1781 case_bndr_evald_next _ = False
1782
1783 (This came up when fixing Trac #7542. See also Note [Eta reduction of
1784 an eval'd function] in CoreUtils.)
1785
1786
1787 Note [Case elimination: unlifted case]
1788 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1789 Consider
1790 case a +# b of r -> ...r...
1791 Then we do case-elimination (to make a let) followed by inlining,
1792 to get
1793 .....(a +# b)....
1794 If we have
1795 case indexArray# a i of r -> ...r...
1796 we might like to do the same, and inline the (indexArray# a i).
1797 But indexArray# is not okForSpeculation, so we don't build a let
1798 in rebuildCase (lest it get floated *out*), so the inlining doesn't
1799 happen either.
1800
1801 This really isn't a big deal I think. The let can be
1802
1803
1804 Further notes about case elimination
1805 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1806 Consider: test :: Integer -> IO ()
1807 test = print
1808
1809 Turns out that this compiles to:
1810 Print.test
1811 = \ eta :: Integer
1812 eta1 :: Void# ->
1813 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1814 case hPutStr stdout
1815 (PrelNum.jtos eta ($w[] @ Char))
1816 eta1
1817 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1818
1819 Notice the strange '<' which has no effect at all. This is a funny one.
1820 It started like this:
1821
1822 f x y = if x < 0 then jtos x
1823 else if y==0 then "" else jtos x
1824
1825 At a particular call site we have (f v 1). So we inline to get
1826
1827 if v < 0 then jtos x
1828 else if 1==0 then "" else jtos x
1829
1830 Now simplify the 1==0 conditional:
1831
1832 if v<0 then jtos v else jtos v
1833
1834 Now common-up the two branches of the case:
1835
1836 case (v<0) of DEFAULT -> jtos v
1837
1838 Why don't we drop the case? Because it's strict in v. It's technically
1839 wrong to drop even unnecessary evaluations, and in practice they
1840 may be a result of 'seq' so we *definitely* don't want to drop those.
1841 I don't really know how to improve this situation.
1842 -}
1843
1844 ---------------------------------------------------------
1845 -- Eliminate the case if possible
1846
1847 rebuildCase, reallyRebuildCase
1848 :: SimplEnv
1849 -> OutExpr -- Scrutinee
1850 -> InId -- Case binder
1851 -> [InAlt] -- Alternatives (inceasing order)
1852 -> SimplCont
1853 -> SimplM (SimplEnv, OutExpr)
1854
1855 --------------------------------------------------
1856 -- 1. Eliminate the case if there's a known constructor
1857 --------------------------------------------------
1858
1859 rebuildCase env scrut case_bndr alts cont
1860 | Lit lit <- scrut -- No need for same treatment as constructors
1861 -- because literals are inlined more vigorously
1862 , not (litIsLifted lit)
1863 = do { tick (KnownBranch case_bndr)
1864 ; case findAlt (LitAlt lit) alts of
1865 Nothing -> missingAlt env case_bndr alts cont
1866 Just (_, bs, rhs) -> simple_rhs bs rhs }
1867
1868 | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
1869 -- Works when the scrutinee is a variable with a known unfolding
1870 -- as well as when it's an explicit constructor application
1871 = do { tick (KnownBranch case_bndr)
1872 ; case findAlt (DataAlt con) alts of
1873 Nothing -> missingAlt env case_bndr alts cont
1874 Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
1875 Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args
1876 case_bndr bs rhs cont
1877 }
1878 where
1879 simple_rhs bs rhs = ASSERT( null bs )
1880 do { env' <- simplNonRecX env case_bndr scrut
1881 -- scrut is a constructor application,
1882 -- hence satisfies let/app invariant
1883 ; simplExprF env' rhs cont }
1884
1885
1886 --------------------------------------------------
1887 -- 2. Eliminate the case if scrutinee is evaluated
1888 --------------------------------------------------
1889
1890 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
1891 -- See if we can get rid of the case altogether
1892 -- See Note [Case elimination]
1893 -- mkCase made sure that if all the alternatives are equal,
1894 -- then there is now only one (DEFAULT) rhs
1895
1896 -- 2a. Dropping the case altogether, if
1897 -- a) it binds nothing (so it's really just a 'seq')
1898 -- b) evaluating the scrutinee has no side effects
1899 | is_plain_seq
1900 , exprOkForSideEffects scrut
1901 -- The entire case is dead, so we can drop it
1902 -- if the scrutinee converges without having imperative
1903 -- side effects or raising a Haskell exception
1904 -- See Note [PrimOp can_fail and has_side_effects] in PrimOp
1905 = simplExprF env rhs cont
1906
1907 -- 2b. Turn the case into a let, if
1908 -- a) it binds only the case-binder
1909 -- b) unlifted case: the scrutinee is ok-for-speculation
1910 -- lifted case: the scrutinee is in HNF (or will later be demanded)
1911 | all_dead_bndrs
1912 , if is_unlifted
1913 then exprOkForSpeculation scrut -- See Note [Case elimination: unlifted case]
1914 else exprIsHNF scrut -- See Note [Case elimination: lifted case]
1915 || scrut_is_demanded_var scrut
1916 = do { tick (CaseElim case_bndr)
1917 ; env' <- simplNonRecX env case_bndr scrut
1918 ; simplExprF env' rhs cont }
1919
1920 -- 2c. Try the seq rules if
1921 -- a) it binds only the case binder
1922 -- b) a rule for seq applies
1923 -- See Note [User-defined RULES for seq] in MkId
1924 | is_plain_seq
1925 = do { let rhs' = substExpr (text "rebuild-case") env rhs
1926 env' = zapSubstEnv env
1927 scrut_ty = substTy env (idType case_bndr)
1928 out_args = [ TyArg { as_arg_ty = scrut_ty
1929 , as_hole_ty = seq_id_ty }
1930 , TyArg { as_arg_ty = exprType rhs'
1931 , as_hole_ty = applyTy seq_id_ty scrut_ty }
1932 , ValArg scrut, ValArg rhs']
1933 -- Lazily evaluated, so we don't do most of this
1934
1935 ; rule_base <- getSimplRules
1936 ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args cont
1937 ; case mb_rule of
1938 Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont'
1939 Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
1940 where
1941 is_unlifted = isUnLiftedType (idType case_bndr)
1942 all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId]
1943 is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
1944 seq_id_ty = idType seqId
1945
1946 scrut_is_demanded_var :: CoreExpr -> Bool
1947 -- See Note [Eliminating redundant seqs]
1948 scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
1949 scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr)
1950 scrut_is_demanded_var _ = False
1951
1952
1953 rebuildCase env scrut case_bndr alts cont
1954 = reallyRebuildCase env scrut case_bndr alts cont
1955
1956 --------------------------------------------------
1957 -- 3. Catch-all case
1958 --------------------------------------------------
1959
1960 reallyRebuildCase env scrut case_bndr alts cont
1961 = do { -- Prepare the continuation;
1962 -- The new subst_env is in place
1963 (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1964
1965 -- Simplify the alternatives
1966 ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1967
1968 ; dflags <- getDynFlags
1969 ; let alts_ty' = contResultType dup_cont
1970 ; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts'
1971
1972 -- Notice that rebuild gets the in-scope set from env', not alt_env
1973 -- (which in any case is only build in simplAlts)
1974 -- The case binder *not* scope over the whole returned case-expression
1975 ; rebuild env' case_expr nodup_cont }
1976
1977 {-
1978 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1979 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1980 way, there's a chance that v will now only be used once, and hence
1981 inlined.
1982
1983 Historical note: we use to do the "case binder swap" in the Simplifier
1984 so there were additional complications if the scrutinee was a variable.
1985 Now the binder-swap stuff is done in the occurrence analyer; see
1986 OccurAnal Note [Binder swap].
1987
1988 Note [knownCon occ info]
1989 ~~~~~~~~~~~~~~~~~~~~~~~~
1990 If the case binder is not dead, then neither are the pattern bound
1991 variables:
1992 case <any> of x { (a,b) ->
1993 case x of { (p,q) -> p } }
1994 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1995 The point is that we bring into the envt a binding
1996 let x = (a,b)
1997 after the outer case, and that makes (a,b) alive. At least we do unless
1998 the case binder is guaranteed dead.
1999
2000 Note [Case alternative occ info]
2001 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2002 When we are simply reconstructing a case (the common case), we always
2003 zap the occurrence info on the binders in the alternatives. Even
2004 if the case binder is dead, the scrutinee is usually a variable, and *that*
2005 can bring the case-alternative binders back to life.
2006 See Note [Add unfolding for scrutinee]
2007
2008 Note [Improving seq]
2009 ~~~~~~~~~~~~~~~~~~~
2010 Consider
2011 type family F :: * -> *
2012 type instance F Int = Int
2013
2014 ... case e of x { DEFAULT -> rhs } ...
2015
2016 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
2017
2018 case e `cast` co of x'::Int
2019 I# x# -> let x = x' `cast` sym co
2020 in rhs
2021
2022 so that 'rhs' can take advantage of the form of x'.
2023
2024 Notice that Note [Case of cast] (in OccurAnal) may then apply to the result.
2025
2026 Nota Bene: We only do the [Improving seq] transformation if the
2027 case binder 'x' is actually used in the rhs; that is, if the case
2028 is *not* a *pure* seq.
2029 a) There is no point in adding the cast to a pure seq.
2030 b) There is a good reason not to: doing so would interfere
2031 with seq rules (Note [Built-in RULES for seq] in MkId).
2032 In particular, this [Improving seq] thing *adds* a cast
2033 while [Built-in RULES for seq] *removes* one, so they
2034 just flip-flop.
2035
2036 You might worry about
2037 case v of x { __DEFAULT ->
2038 ... case (v `cast` co) of y { I# -> ... }}
2039 This is a pure seq (since x is unused), so [Improving seq] won't happen.
2040 But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get
2041 case v of x { __DEFAULT ->
2042 ... case (x `cast` co) of y { I# -> ... }}
2043 Now the outer case is not a pure seq, so [Improving seq] will happen,
2044 and then the inner case will disappear.
2045
2046 The need for [Improving seq] showed up in Roman's experiments. Example:
2047 foo :: F Int -> Int -> Int
2048 foo t n = t `seq` bar n
2049 where
2050 bar 0 = 0
2051 bar n = bar (n - case t of TI i -> i)
2052 Here we'd like to avoid repeated evaluating t inside the loop, by
2053 taking advantage of the `seq`.
2054
2055 At one point I did transformation in LiberateCase, but it's more
2056 robust here. (Otherwise, there's a danger that we'll simply drop the
2057 'seq' altogether, before LiberateCase gets to see it.)
2058 -}
2059
2060 simplAlts :: SimplEnv
2061 -> OutExpr
2062 -> InId -- Case binder
2063 -> [InAlt] -- Non-empty
2064 -> SimplCont
2065 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
2066 -- Like simplExpr, this just returns the simplified alternatives;
2067 -- it does not return an environment
2068 -- The returned alternatives can be empty, none are possible
2069
2070 simplAlts env scrut case_bndr alts cont'
2071 = do { let env0 = zapFloats env
2072
2073 ; (env1, case_bndr1) <- simplBinder env0 case_bndr
2074
2075 ; fam_envs <- getFamEnvs
2076 ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut
2077 case_bndr case_bndr1 alts
2078
2079 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
2080 -- NB: it's possible that the returned in_alts is empty: this is handled
2081 -- by the caller (rebuildCase) in the missingAlt function
2082
2083 ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
2084 ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
2085 return (scrut', case_bndr', alts') }
2086
2087
2088 ------------------------------------
2089 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
2090 -> OutExpr -> InId -> OutId -> [InAlt]
2091 -> SimplM (SimplEnv, OutExpr, OutId)
2092 -- Note [Improving seq]
2093 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
2094 | not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq]
2095 , Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
2096 = do { case_bndr2 <- newId (fsLit "nt") ty2
2097 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
2098 env2 = extendIdSubst env case_bndr rhs
2099 ; return (env2, scrut `Cast` co, case_bndr2) }
2100
2101 improveSeq _ env scrut _ case_bndr1 _
2102 = return (env, scrut, case_bndr1)
2103
2104
2105 ------------------------------------
2106 simplAlt :: SimplEnv
2107 -> Maybe OutExpr -- The scrutinee
2108 -> [AltCon] -- These constructors can't be present when
2109 -- matching the DEFAULT alternative
2110 -> OutId -- The case binder
2111 -> SimplCont
2112 -> InAlt
2113 -> SimplM OutAlt
2114
2115 simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
2116 = ASSERT( null bndrs )
2117 do { let env' = addBinderUnfolding env case_bndr'
2118 (mkOtherCon imposs_deflt_cons)
2119 -- Record the constructors that the case-binder *can't* be.
2120 ; rhs' <- simplExprC env' rhs cont'
2121 ; return (DEFAULT, [], rhs') }
2122
2123 simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
2124 = ASSERT( null bndrs )
2125 do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)
2126 ; rhs' <- simplExprC env' rhs cont'
2127 ; return (LitAlt lit, [], rhs') }
2128
2129 simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
2130 = do { -- Deal with the pattern-bound variables
2131 -- Mark the ones that are in ! positions in the
2132 -- data constructor as certainly-evaluated.
2133 -- NB: simplLamBinders preserves this eval info
2134 ; let vs_with_evals = add_evals (dataConRepStrictness con)
2135 ; (env', vs') <- simplLamBndrs env vs_with_evals
2136
2137 -- Bind the case-binder to (con args)
2138 ; let inst_tys' = tyConAppArgs (idType case_bndr')
2139 con_app :: OutExpr
2140 con_app = mkConApp2 con inst_tys' vs'
2141
2142 ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
2143 ; rhs' <- simplExprC env'' rhs cont'
2144 ; return (DataAlt con, vs', rhs') }
2145 where
2146 -- add_evals records the evaluated-ness of the bound variables of
2147 -- a case pattern. This is *important*. Consider
2148 -- data T = T !Int !Int
2149 --
2150 -- case x of { T a b -> T (a+1) b }
2151 --
2152 -- We really must record that b is already evaluated so that we don't
2153 -- go and re-evaluate it when constructing the result.
2154 -- See Note [Data-con worker strictness] in MkId.lhs
2155 add_evals the_strs
2156 = go vs the_strs
2157 where
2158 go [] [] = []
2159 go (v:vs') strs | isTyVar v = v : go vs' strs
2160 go (v:vs') (str:strs)
2161 | isMarkedStrict str = evald_v : go vs' strs
2162 | otherwise = zapped_v : go vs' strs
2163 where
2164 zapped_v = zapIdOccInfo v -- See Note [Case alternative occ info]
2165 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
2166 go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
2167
2168
2169 addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
2170 addAltUnfoldings env scrut case_bndr con_app
2171 = do { dflags <- getDynFlags
2172 ; let con_app_unf = mkSimpleUnfolding dflags con_app
2173 env1 = addBinderUnfolding env case_bndr con_app_unf
2174
2175 -- See Note [Add unfolding for scrutinee]
2176 env2 = case scrut of
2177 Just (Var v) -> addBinderUnfolding env1 v con_app_unf
2178 Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
2179 mkSimpleUnfolding dflags (Cast con_app (mkSymCo co))
2180 _ -> env1
2181
2182 ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
2183 ; return env2 }
2184
2185 addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
2186 addBinderUnfolding env bndr unf
2187 | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
2188 = WARN( not (eqType (idType bndr) (exprType tmpl)),
2189 ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )
2190 modifyInScope env (bndr `setIdUnfolding` unf)
2191
2192 | otherwise
2193 = modifyInScope env (bndr `setIdUnfolding` unf)
2194
2195 zapBndrOccInfo :: Bool -> Id -> Id
2196 -- Consider case e of b { (a,b) -> ... }
2197 -- Then if we bind b to (a,b) in "...", and b is not dead,
2198 -- then we must zap the deadness info on a,b
2199 zapBndrOccInfo keep_occ_info pat_id
2200 | keep_occ_info = pat_id
2201 | otherwise = zapIdOccInfo pat_id
2202
2203 {-
2204 Note [Add unfolding for scrutinee]
2205 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2206 In general it's unlikely that a variable scrutinee will appear
2207 in the case alternatives case x of { ...x unlikely to appear... }
2208 because the binder-swap in OccAnal has got rid of all such occcurrences
2209 See Note [Binder swap] in OccAnal.
2210
2211 BUT it is still VERY IMPORTANT to add a suitable unfolding for a
2212 variable scrutinee, in simplAlt. Here's why
2213 case x of y
2214 (a,b) -> case b of c
2215 I# v -> ...(f y)...
2216 There is no occurrence of 'b' in the (...(f y)...). But y gets
2217 the unfolding (a,b), and *that* mentions b. If f has a RULE
2218 RULE f (p, I# q) = ...
2219 we want that rule to match, so we must extend the in-scope env with a
2220 suitable unfolding for 'y'. It's *essential* for rule matching; but
2221 it's also good for case-elimintation -- suppose that 'f' was inlined
2222 and did multi-level case analysis, then we'd solve it in one
2223 simplifier sweep instead of two.
2224
2225 Exactly the same issue arises in SpecConstr;
2226 see Note [Add scrutinee to ValueEnv too] in SpecConstr
2227
2228 HOWEVER, given
2229 case x of y { Just a -> r1; Nothing -> r2 }
2230 we do not want to add the unfolding x -> y to 'x', which might seem cool,
2231 since 'y' itself has different unfoldings in r1 and r2. Reason: if we
2232 did that, we'd have to zap y's deadness info and that is a very useful
2233 piece of information.
2234
2235 So instead we add the unfolding x -> Just a, and x -> Nothing in the
2236 respective RHSs.
2237
2238
2239 ************************************************************************
2240 * *
2241 \subsection{Known constructor}
2242 * *
2243 ************************************************************************
2244
2245 We are a bit careful with occurrence info. Here's an example
2246
2247 (\x* -> case x of (a*, b) -> f a) (h v, e)
2248
2249 where the * means "occurs once". This effectively becomes
2250 case (h v, e) of (a*, b) -> f a)
2251 and then
2252 let a* = h v; b = e in f a
2253 and then
2254 f (h v)
2255
2256 All this should happen in one sweep.
2257 -}
2258
2259 knownCon :: SimplEnv
2260 -> OutExpr -- The scrutinee
2261 -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces)
2262 -> InId -> [InBndr] -> InExpr -- The alternative
2263 -> SimplCont
2264 -> SimplM (SimplEnv, OutExpr)
2265
2266 knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
2267 = do { env' <- bind_args env bs dc_args
2268 ; env'' <- bind_case_bndr env'
2269 ; simplExprF env'' rhs cont }
2270 where
2271 zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId
2272
2273 -- Ugh!
2274 bind_args env' [] _ = return env'
2275
2276 bind_args env' (b:bs') (Type ty : args)
2277 = ASSERT( isTyVar b )
2278 bind_args (extendTvSubst env' b ty) bs' args
2279
2280 bind_args env' (b:bs') (arg : args)
2281 = ASSERT( isId b )
2282 do { let b' = zap_occ b
2283 -- Note that the binder might be "dead", because it doesn't
2284 -- occur in the RHS; and simplNonRecX may therefore discard
2285 -- it via postInlineUnconditionally.
2286 -- Nevertheless we must keep it if the case-binder is alive,
2287 -- because it may be used in the con_app. See Note [knownCon occ info]
2288 ; env'' <- simplNonRecX env' b' arg -- arg satisfies let/app invariant
2289 ; bind_args env'' bs' args }
2290
2291 bind_args _ _ _ =
2292 pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
2293 text "scrut:" <+> ppr scrut
2294
2295 -- It's useful to bind bndr to scrut, rather than to a fresh
2296 -- binding x = Con arg1 .. argn
2297 -- because very often the scrut is a variable, so we avoid
2298 -- creating, and then subsequently eliminating, a let-binding
2299 -- BUT, if scrut is a not a variable, we must be careful
2300 -- about duplicating the arg redexes; in that case, make
2301 -- a new con-app from the args
2302 bind_case_bndr env
2303 | isDeadBinder bndr = return env
2304 | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut))
2305 | otherwise = do { dc_args <- mapM (simplVar env) bs
2306 -- dc_ty_args are aready OutTypes,
2307 -- but bs are InBndrs
2308 ; let con_app = Var (dataConWorkId dc)
2309 `mkTyApps` dc_ty_args
2310 `mkApps` dc_args
2311 ; simplNonRecX env bndr con_app }
2312
2313 -------------------
2314 missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
2315 -- This isn't strictly an error, although it is unusual.
2316 -- It's possible that the simplifer might "see" that
2317 -- an inner case has no accessible alternatives before
2318 -- it "sees" that the entire branch of an outer case is
2319 -- inaccessible. So we simply put an error case here instead.
2320 missingAlt env case_bndr _ cont
2321 = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
2322 return (env, mkImpossibleExpr (contResultType cont))
2323
2324 {-
2325 ************************************************************************
2326 * *
2327 \subsection{Duplicating continuations}
2328 * *
2329 ************************************************************************
2330 -}
2331
2332 prepareCaseCont :: SimplEnv
2333 -> [InAlt] -> SimplCont
2334 -> SimplM (SimplEnv,
2335 SimplCont, -- Dupable part
2336 SimplCont) -- Non-dupable part
2337 -- We are considering
2338 -- K[case _ of { p1 -> r1; ...; pn -> rn }]
2339 -- where K is some enclosing continuation for the case
2340 -- Goal: split K into two pieces Kdup,Knodup so that
2341 -- a) Kdup can be duplicated
2342 -- b) Knodup[Kdup[e]] = K[e]
2343 -- The idea is that we'll transform thus:
2344 -- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
2345 --
2346 -- We may also return some extra bindings in SimplEnv (that scope over
2347 -- the entire continuation)
2348 --
2349 -- When case-of-case is off, just make the entire continuation non-dupable
2350
2351 prepareCaseCont env alts cont
2352 | not (sm_case_case (getMode env)) = return (env, mkBoringStop (contHoleType cont), cont)
2353 | not (many_alts alts) = return (env, cont, mkBoringStop (contResultType cont))
2354 | otherwise = mkDupableCont env cont
2355 where
2356 many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
2357 many_alts [] = False -- See Note [Bottom alternatives]
2358 many_alts [_] = False
2359 many_alts (alt:alts)
2360 | is_bot_alt alt = many_alts alts
2361 | otherwise = not (all is_bot_alt alts)
2362
2363 is_bot_alt (_,_,rhs) = exprIsBottom rhs
2364
2365 {-
2366 Note [Bottom alternatives]
2367 ~~~~~~~~~~~~~~~~~~~~~~~~~~
2368 When we have
2369 case (case x of { A -> error .. ; B -> e; C -> error ..)
2370 of alts
2371 then we can just duplicate those alts because the A and C cases
2372 will disappear immediately. This is more direct than creating
2373 join points and inlining them away; and in some cases we would
2374 not even create the join points (see Note [Single-alternative case])
2375 and we would keep the case-of-case which is silly. See Trac #4930.
2376 -}
2377
2378 mkDupableCont :: SimplEnv -> SimplCont
2379 -> SimplM (SimplEnv, SimplCont, SimplCont)
2380
2381 mkDupableCont env cont
2382 | contIsDupable cont
2383 = return (env, cont, mkBoringStop (contResultType cont))
2384
2385 mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
2386
2387 mkDupableCont env (CastIt ty cont)
2388 = do { (env', dup, nodup) <- mkDupableCont env cont
2389 ; return (env', CastIt ty dup, nodup) }
2390
2391 -- Duplicating ticks for now, not sure if this is good or not
2392 mkDupableCont env cont@(TickIt{})
2393 = return (env, mkBoringStop (contHoleType cont), cont)
2394
2395 mkDupableCont env cont@(StrictBind {})
2396 = return (env, mkBoringStop (contHoleType cont), cont)
2397 -- See Note [Duplicating StrictBind]
2398
2399 mkDupableCont env (StrictArg info cci cont)
2400 -- See Note [Duplicating StrictArg]
2401 = do { (env', dup, nodup) <- mkDupableCont env cont
2402 ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info)
2403 ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
2404
2405 mkDupableCont env cont@(ApplyToTy { sc_cont = tail })
2406 = do { (env', dup_cont, nodup_cont) <- mkDupableCont env tail
2407 ; return (env', cont { sc_cont = dup_cont }, nodup_cont ) }
2408
2409 mkDupableCont env (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = cont })
2410 = -- e.g. [...hole...] (...arg...)
2411 -- ==>
2412 -- let a = ...arg...
2413 -- in [...hole...] a
2414 do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
2415 ; arg' <- simplExpr (se `setInScope` env') arg
2416 ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
2417 ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = zapSubstEnv env''
2418 , sc_dup = OkToDup, sc_cont = dup_cont }
2419 ; return (env'', app_cont, nodup_cont) }
2420
2421 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
2422 -- See Note [Single-alternative case]
2423 -- | not (exprIsDupable rhs && contIsDupable case_cont)
2424 -- | not (isDeadBinder case_bndr)
2425 | all isDeadBinder bs -- InIds
2426 && not (isUnLiftedType (idType case_bndr))
2427 -- Note [Single-alternative-unlifted]
2428 = return (env, mkBoringStop (contHoleType cont), cont)
2429
2430 mkDupableCont env (Select _ case_bndr alts se cont)
2431 = -- e.g. (case [...hole...] of { pi -> ei })
2432 -- ===>
2433 -- let ji = \xij -> ei
2434 -- in case [...hole...] of { pi -> ji xij }
2435 do { tick (CaseOfCase case_bndr)
2436 ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
2437 -- NB: We call prepareCaseCont here. If there is only one
2438 -- alternative, then dup_cont may be big, but that's ok
2439 -- because we push it into the single alternative, and then
2440 -- use mkDupableAlt to turn that simplified alternative into
2441 -- a join point if it's too big to duplicate.
2442 -- And this is important: see Note [Fusing case continuations]
2443
2444 ; let alt_env = se `setInScope` env'
2445
2446 ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
2447 ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
2448 -- Safe to say that there are no handled-cons for the DEFAULT case
2449 -- NB: simplBinder does not zap deadness occ-info, so
2450 -- a dead case_bndr' will still advertise its deadness
2451 -- This is really important because in
2452 -- case e of b { (# p,q #) -> ... }
2453 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
2454 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
2455 -- In the new alts we build, we have the new case binder, so it must retain
2456 -- its deadness.
2457 -- NB: we don't use alt_env further; it has the substEnv for
2458 -- the alternatives, and we don't want that
2459
2460 ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
2461 ; return (env'', -- Note [Duplicated env]
2462 Select OkToDup case_bndr' alts'' (zapSubstEnv env'')
2463 (mkBoringStop (contHoleType nodup_cont)),
2464 nodup_cont) }
2465
2466
2467 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
2468 -> SimplM (SimplEnv, [InAlt])
2469 -- Absorbs the continuation into the new alternatives
2470
2471 mkDupableAlts env case_bndr' the_alts
2472 = go env the_alts
2473 where
2474 go env0 [] = return (env0, [])
2475 go env0 (alt:alts)
2476 = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
2477 ; (env2, alts') <- go env1 alts
2478 ; return (env2, alt' : alts' ) }
2479
2480 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
2481 -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
2482 mkDupableAlt env case_bndr (con, bndrs', rhs') = do
2483 dflags <- getDynFlags
2484 if exprIsDupable dflags rhs' -- Note [Small alternative rhs]
2485 then return (env, (con, bndrs', rhs'))
2486 else
2487 do { let rhs_ty' = exprType rhs'
2488 scrut_ty = idType case_bndr
2489 case_bndr_w_unf
2490 = case con of
2491 DEFAULT -> case_bndr
2492 DataAlt dc -> setIdUnfolding case_bndr unf
2493 where
2494 -- See Note [Case binders and join points]
2495 unf = mkInlineUnfolding Nothing rhs
2496 rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
2497
2498 LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
2499 <+> ppr case_bndr <+> ppr con )
2500 case_bndr
2501 -- The case binder is alive but trivial, so why has
2502 -- it not been substituted away?
2503
2504 used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs'
2505 | otherwise = bndrs' ++ [case_bndr_w_unf]
2506
2507 abstract_over bndr
2508 | isTyVar bndr = True -- Abstract over all type variables just in case
2509 | otherwise = not (isDeadBinder bndr)
2510 -- The deadness info on the new Ids is preserved by simplBinders
2511
2512 ; (final_bndrs', final_args) -- Note [Join point abstraction]
2513 <- if (any isId used_bndrs')
2514 then return (used_bndrs', varsToCoreExprs used_bndrs')
2515 else do { rw_id <- newId (fsLit "w") voidPrimTy
2516 ; return ([setOneShotLambda rw_id], [Var voidPrimId]) }
2517
2518 ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
2519 -- Note [Funky mkPiTypes]
2520
2521 ; let -- We make the lambdas into one-shot-lambdas. The
2522 -- join point is sure to be applied at most once, and doing so
2523 -- prevents the body of the join point being floated out by
2524 -- the full laziness pass
2525 really_final_bndrs = map one_shot final_bndrs'
2526 one_shot v | isId v = setOneShotLambda v
2527 | otherwise = v
2528 join_rhs = mkLams really_final_bndrs rhs'
2529 join_arity = exprArity join_rhs
2530 join_call = mkApps (Var join_bndr) final_args
2531
2532 ; env' <- addPolyBind NotTopLevel env (NonRec (join_bndr `setIdArity` join_arity) join_rhs)
2533 ; return (env', (con, bndrs', join_call)) }
2534 -- See Note [Duplicated env]
2535
2536 {-
2537 Note [Fusing case continuations]
2538 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2539 It's important to fuse two successive case continuations when the
2540 first has one alternative. That's why we call prepareCaseCont here.
2541 Consider this, which arises from thunk splitting (see Note [Thunk
2542 splitting] in WorkWrap):
2543
2544 let
2545 x* = case (case v of {pn -> rn}) of
2546 I# a -> I# a
2547 in body
2548
2549 The simplifier will find
2550 (Var v) with continuation
2551 Select (pn -> rn) (
2552 Select [I# a -> I# a] (
2553 StrictBind body Stop
2554
2555 So we'll call mkDupableCont on
2556 Select [I# a -> I# a] (StrictBind body Stop)
2557 There is just one alternative in the first Select, so we want to
2558 simplify the rhs (I# a) with continuation (StricgtBind body Stop)
2559 Supposing that body is big, we end up with
2560 let $j a = <let x = I# a in body>
2561 in case v of { pn -> case rn of
2562 I# a -> $j a }
2563 This is just what we want because the rn produces a box that
2564 the case rn cancels with.
2565
2566 See Trac #4957 a fuller example.
2567
2568 Note [Case binders and join points]
2569 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2570 Consider this
2571 case (case .. ) of c {
2572 I# c# -> ....c....
2573
2574 If we make a join point with c but not c# we get
2575 $j = \c -> ....c....
2576
2577 But if later inlining scrutines the c, thus
2578
2579 $j = \c -> ... case c of { I# y -> ... } ...
2580
2581 we won't see that 'c' has already been scrutinised. This actually
2582 happens in the 'tabulate' function in wave4main, and makes a significant
2583 difference to allocation.
2584
2585 An alternative plan is this:
2586
2587 $j = \c# -> let c = I# c# in ...c....
2588
2589 but that is bad if 'c' is *not* later scrutinised.
2590
2591 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
2592 (a stable unfolding) that it's really I# c#, thus
2593
2594 $j = \c# -> \c[=I# c#] -> ...c....
2595
2596 Absence analysis may later discard 'c'.
2597
2598 NB: take great care when doing strictness analysis;
2599 see Note [Lamba-bound unfoldings] in DmdAnal.
2600
2601 Also note that we can still end up passing stuff that isn't used. Before
2602 strictness analysis we have
2603 let $j x y c{=(x,y)} = (h c, ...)
2604 in ...
2605 After strictness analysis we see that h is strict, we end up with
2606 let $j x y c{=(x,y)} = ($wh x y, ...)
2607 and c is unused.
2608
2609 Note [Duplicated env]
2610 ~~~~~~~~~~~~~~~~~~~~~
2611 Some of the alternatives are simplified, but have not been turned into a join point
2612 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
2613 bind the join point, because it might to do PostInlineUnconditionally, and
2614 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
2615 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
2616 at worst delays the join-point inlining.
2617
2618 Note [Small alternative rhs]
2619 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2620 It is worth checking for a small RHS because otherwise we
2621 get extra let bindings that may cause an extra iteration of the simplifier to
2622 inline back in place. Quite often the rhs is just a variable or constructor.
2623 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
2624 iterations because the version with the let bindings looked big, and so wasn't
2625 inlined, but after the join points had been inlined it looked smaller, and so
2626 was inlined.
2627
2628 NB: we have to check the size of rhs', not rhs.
2629 Duplicating a small InAlt might invalidate occurrence information
2630 However, if it *is* dupable, we return the *un* simplified alternative,
2631 because otherwise we'd need to pair it up with an empty subst-env....
2632 but we only have one env shared between all the alts.
2633 (Remember we must zap the subst-env before re-simplifying something).
2634 Rather than do this we simply agree to re-simplify the original (small) thing later.
2635
2636 Note [Funky mkPiTypes]
2637 ~~~~~~~~~~~~~~~~~~~~~~
2638 Notice the funky mkPiTypes. If the contructor has existentials
2639 it's possible that the join point will be abstracted over
2640 type varaibles as well as term variables.
2641 Example: Suppose we have
2642 data T = forall t. C [t]
2643 Then faced with
2644 case (case e of ...) of
2645 C t xs::[t] -> rhs
2646 We get the join point
2647 let j :: forall t. [t] -> ...
2648 j = /\t \xs::[t] -> rhs
2649 in
2650 case (case e of ...) of
2651 C t xs::[t] -> j t xs
2652
2653 Note [Join point abstraction]
2654 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2655 Join points always have at least one value argument,
2656 for several reasons
2657
2658 * If we try to lift a primitive-typed something out
2659 for let-binding-purposes, we will *caseify* it (!),
2660 with potentially-disastrous strictness results. So
2661 instead we turn it into a function: \v -> e
2662 where v::Void#. The value passed to this function is void,
2663 which generates (almost) no code.
2664
2665 * CPR. We used to say "&& isUnLiftedType rhs_ty'" here, but now
2666 we make the join point into a function whenever used_bndrs'
2667 is empty. This makes the join-point more CPR friendly.
2668 Consider: let j = if .. then I# 3 else I# 4
2669 in case .. of { A -> j; B -> j; C -> ... }
2670
2671 Now CPR doesn't w/w j because it's a thunk, so
2672 that means that the enclosing function can't w/w either,
2673 which is a lose. Here's the example that happened in practice:
2674 kgmod :: Int -> Int -> Int
2675 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2676 then 78
2677 else 5
2678
2679 * Let-no-escape. We want a join point to turn into a let-no-escape
2680 so that it is implemented as a jump, and one of the conditions
2681 for LNE is that it's not updatable. In CoreToStg, see
2682 Note [What is a non-escaping let]
2683
2684 * Floating. Since a join point will be entered once, no sharing is
2685 gained by floating out, but something might be lost by doing
2686 so because it might be allocated.
2687
2688 I have seen a case alternative like this:
2689 True -> \v -> ...
2690 It's a bit silly to add the realWorld dummy arg in this case, making
2691 $j = \s v -> ...
2692 True -> $j s
2693 (the \v alone is enough to make CPR happy) but I think it's rare
2694
2695 There's a slight infelicity here: we pass the overall
2696 case_bndr to all the join points if it's used in *any* RHS,
2697 because we don't know its usage in each RHS separately
2698
2699
2700 Note [Duplicating StrictArg]
2701 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2702 The original plan had (where E is a big argument)
2703 e.g. f E [..hole..]
2704 ==> let $j = \a -> f E a
2705 in $j [..hole..]
2706
2707 But this is terrible! Here's an example:
2708 && E (case x of { T -> F; F -> T })
2709 Now, && is strict so we end up simplifying the case with
2710
2711 an ArgOf continuation. If we let-bind it, we get
2712 let $j = \v -> && E v
2713 in simplExpr (case x of { T -> F; F -> T })
2714 (ArgOf (\r -> $j r)
2715 And after simplifying more we get
2716 let $j = \v -> && E v
2717 in case x of { T -> $j F; F -> $j T }
2718 Which is a Very Bad Thing
2719
2720 What we do now is this
2721 f E [..hole..]
2722 ==> let a = E
2723 in f a [..hole..]
2724 Now if the thing in the hole is a case expression (which is when
2725 we'll call mkDupableCont), we'll push the function call into the
2726 branches, which is what we want. Now RULES for f may fire, and
2727 call-pattern specialisation. Here's an example from Trac #3116
2728 go (n+1) (case l of
2729 1 -> bs'
2730 _ -> Chunk p fpc (o+1) (l-1) bs')
2731 If we can push the call for 'go' inside the case, we get
2732 call-pattern specialisation for 'go', which is *crucial* for
2733 this program.
2734
2735 Here is the (&&) example:
2736 && E (case x of { T -> F; F -> T })
2737 ==> let a = E in
2738 case x of { T -> && a F; F -> && a T }
2739 Much better!
2740
2741 Notice that
2742 * Arguments to f *after* the strict one are handled by
2743 the ApplyToVal case of mkDupableCont. Eg
2744 f [..hole..] E
2745
2746 * We can only do the let-binding of E because the function
2747 part of a StrictArg continuation is an explicit syntax
2748 tree. In earlier versions we represented it as a function
2749 (CoreExpr -> CoreEpxr) which we couldn't take apart.
2750
2751 Do *not* duplicate StrictBind and StritArg continuations. We gain
2752 nothing by propagating them into the expressions, and we do lose a
2753 lot.
2754
2755 The desire not to duplicate is the entire reason that
2756 mkDupableCont returns a pair of continuations.
2757
2758 Note [Duplicating StrictBind]
2759 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2760 Unlike StrictArg, there doesn't seem anything to gain from
2761 duplicating a StrictBind continuation, so we don't.
2762
2763
2764 Note [Single-alternative cases]
2765 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2766 This case is just like the ArgOf case. Here's an example:
2767 data T a = MkT !a
2768 ...(MkT (abs x))...
2769 Then we get
2770 case (case x of I# x' ->
2771 case x' <# 0# of
2772 True -> I# (negate# x')
2773 False -> I# x') of y {
2774 DEFAULT -> MkT y
2775 Because the (case x) has only one alternative, we'll transform to
2776 case x of I# x' ->
2777 case (case x' <# 0# of
2778 True -> I# (negate# x')
2779 False -> I# x') of y {
2780 DEFAULT -> MkT y
2781 But now we do *NOT* want to make a join point etc, giving
2782 case x of I# x' ->
2783 let $j = \y -> MkT y
2784 in case x' <# 0# of
2785 True -> $j (I# (negate# x'))
2786 False -> $j (I# x')
2787 In this case the $j will inline again, but suppose there was a big
2788 strict computation enclosing the orginal call to MkT. Then, it won't
2789 "see" the MkT any more, because it's big and won't get duplicated.
2790 And, what is worse, nothing was gained by the case-of-case transform.
2791
2792 So, in circumstances like these, we don't want to build join points
2793 and push the outer case into the branches of the inner one. Instead,
2794 don't duplicate the continuation.
2795
2796 When should we use this strategy? We should not use it on *every*
2797 single-alternative case:
2798 e.g. case (case ....) of (a,b) -> (# a,b #)
2799 Here we must push the outer case into the inner one!
2800 Other choices:
2801
2802 * Match [(DEFAULT,_,_)], but in the common case of Int,
2803 the alternative-filling-in code turned the outer case into
2804 case (...) of y { I# _ -> MkT y }
2805
2806 * Match on single alternative plus (not (isDeadBinder case_bndr))
2807 Rationale: pushing the case inwards won't eliminate the construction.
2808 But there's a risk of
2809 case (...) of y { (a,b) -> let z=(a,b) in ... }
2810 Now y looks dead, but it'll come alive again. Still, this
2811 seems like the best option at the moment.
2812
2813 * Match on single alternative plus (all (isDeadBinder bndrs))
2814 Rationale: this is essentially seq.
2815
2816 * Match when the rhs is *not* duplicable, and hence would lead to a
2817 join point. This catches the disaster-case above. We can test
2818 the *un-simplified* rhs, which is fine. It might get bigger or
2819 smaller after simplification; if it gets smaller, this case might
2820 fire next time round. NB also that we must test contIsDupable
2821 case_cont *too, because case_cont might be big!
2822
2823 HOWEVER: I found that this version doesn't work well, because
2824 we can get let x = case (...) of { small } in ...case x...
2825 When x is inlined into its full context, we find that it was a bad
2826 idea to have pushed the outer case inside the (...) case.
2827
2828 Note [Single-alternative-unlifted]
2829 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2830 Here's another single-alternative where we really want to do case-of-case:
2831
2832 data Mk1 = Mk1 Int# | Mk2 Int#
2833
2834 M1.f =
2835 \r [x_s74 y_s6X]
2836 case
2837 case y_s6X of tpl_s7m {
2838 M1.Mk1 ipv_s70 -> ipv_s70;
2839 M1.Mk2 ipv_s72 -> ipv_s72;
2840 }
2841 of
2842 wild_s7c
2843 { __DEFAULT ->
2844 case
2845 case x_s74 of tpl_s7n {
2846 M1.Mk1 ipv_s77 -> ipv_s77;
2847 M1.Mk2 ipv_s79 -> ipv_s79;
2848 }
2849 of
2850 wild1_s7b
2851 { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2852 };
2853 };
2854
2855 So the outer case is doing *nothing at all*, other than serving as a
2856 join-point. In this case we really want to do case-of-case and decide
2857 whether to use a real join point or just duplicate the continuation:
2858
2859 let $j s7c = case x of
2860 Mk1 ipv77 -> (==) s7c ipv77
2861 Mk1 ipv79 -> (==) s7c ipv79
2862 in
2863 case y of
2864 Mk1 ipv70 -> $j ipv70
2865 Mk2 ipv72 -> $j ipv72
2866
2867 Hence: check whether the case binder's type is unlifted, because then
2868 the outer case is *not* a seq.
2869 -}