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