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