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