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