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