Fix nasty bug in w/w for absence analysis
[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 to let transformation]
2140 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2141 If a case over a lifted type has a single alternative, and is being
2142 used as a strict 'let' (all isDeadBinder bndrs), we may want to do
2143 this transformation:
2144
2145 case e of r ===> let r = e in ...r...
2146 _ -> ...r...
2147
2148 We treat the unlifted and lifted cases separately:
2149
2150 * Unlifted case: 'e' satisfies exprOkForSpeculation
2151 (ok-for-spec is needed to satisfy the let/app invariant).
2152 This turns case a +# b of r -> ...r...
2153 into let r = a +# b in ...r...
2154 and thence .....(a +# b)....
2155
2156 However, if we have
2157 case indexArray# a i of r -> ...r...
2158 we might like to do the same, and inline the (indexArray# a i).
2159 But indexArray# is not okForSpeculation, so we don't build a let
2160 in rebuildCase (lest it get floated *out*), so the inlining doesn't
2161 happen either. Annoying.
2162
2163 * Lifted case: we need to be sure that the expression is already
2164 evaluated (exprIsHNF). If it's not already evaluated
2165 - we risk losing exceptions, divergence or
2166 user-specified thunk-forcing
2167 - even if 'e' is guaranteed to converge, we don't want to
2168 create a thunk (call by need) instead of evaluating it
2169 right away (call by value)
2170
2171 However, we can turn the case into a /strict/ let if the 'r' is
2172 used strictly in the body. Then we won't lose divergence; and
2173 we won't build a thunk because the let is strict.
2174 See also Note [Eliminating redundant seqs]
2175
2176 NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore.
2177 We want to turn
2178 case (absentError "foo") of r -> ...MkT r...
2179 into
2180 let r = absentError "foo" in ...MkT r...
2181
2182
2183 Note [Eliminating redundant seqs]
2184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2185 If we have this:
2186 case x of r { _ -> ..r.. }
2187 where 'r' is used strictly in (..r..), the case is effectively a 'seq'
2188 on 'x', but since 'r' is used strictly anyway, we can safely transform to
2189 (...x...)
2190
2191 Note that this can change the error behaviour. For example, we might
2192 transform
2193 case x of { _ -> error "bad" }
2194 --> error "bad"
2195 which is might be puzzling if 'x' currently lambda-bound, but later gets
2196 let-bound to (error "good").
2197
2198 Nevertheless, the paper "A semantics for imprecise exceptions" allows
2199 this transformation. If you want to fix the evaluation order, use
2200 'pseq'. See Trac #8900 for an example where the loss of this
2201 transformation bit us in practice.
2202
2203 See also Note [Empty case alternatives] in CoreSyn.
2204
2205 Just for reference, the original code (added Jan 13) looked like this:
2206 || case_bndr_evald_next rhs
2207
2208 case_bndr_evald_next :: CoreExpr -> Bool
2209 -- See Note [Case binder next]
2210 case_bndr_evald_next (Var v) = v == case_bndr
2211 case_bndr_evald_next (Cast e _) = case_bndr_evald_next e
2212 case_bndr_evald_next (App e _) = case_bndr_evald_next e
2213 case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e
2214 case_bndr_evald_next _ = False
2215
2216 (This came up when fixing Trac #7542. See also Note [Eta reduction of
2217 an eval'd function] in CoreUtils.)
2218
2219
2220 Further notes about case elimination
2221 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2222 Consider: test :: Integer -> IO ()
2223 test = print
2224
2225 Turns out that this compiles to:
2226 Print.test
2227 = \ eta :: Integer
2228 eta1 :: Void# ->
2229 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
2230 case hPutStr stdout
2231 (PrelNum.jtos eta ($w[] @ Char))
2232 eta1
2233 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
2234
2235 Notice the strange '<' which has no effect at all. This is a funny one.
2236 It started like this:
2237
2238 f x y = if x < 0 then jtos x
2239 else if y==0 then "" else jtos x
2240
2241 At a particular call site we have (f v 1). So we inline to get
2242
2243 if v < 0 then jtos x
2244 else if 1==0 then "" else jtos x
2245
2246 Now simplify the 1==0 conditional:
2247
2248 if v<0 then jtos v else jtos v
2249
2250 Now common-up the two branches of the case:
2251
2252 case (v<0) of DEFAULT -> jtos v
2253
2254 Why don't we drop the case? Because it's strict in v. It's technically
2255 wrong to drop even unnecessary evaluations, and in practice they
2256 may be a result of 'seq' so we *definitely* don't want to drop those.
2257 I don't really know how to improve this situation.
2258 -}
2259
2260 ---------------------------------------------------------
2261 -- Eliminate the case if possible
2262
2263 rebuildCase, reallyRebuildCase
2264 :: SimplEnv
2265 -> OutExpr -- Scrutinee
2266 -> InId -- Case binder
2267 -> [InAlt] -- Alternatives (inceasing order)
2268 -> SimplCont
2269 -> SimplM (SimplFloats, OutExpr)
2270
2271 --------------------------------------------------
2272 -- 1. Eliminate the case if there's a known constructor
2273 --------------------------------------------------
2274
2275 rebuildCase env scrut case_bndr alts cont
2276 | Lit lit <- scrut -- No need for same treatment as constructors
2277 -- because literals are inlined more vigorously
2278 , not (litIsLifted lit)
2279 = do { tick (KnownBranch case_bndr)
2280 ; case findAlt (LitAlt lit) alts of
2281 Nothing -> missingAlt env case_bndr alts cont
2282 Just (_, bs, rhs) -> simple_rhs bs rhs }
2283
2284 | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
2285 -- Works when the scrutinee is a variable with a known unfolding
2286 -- as well as when it's an explicit constructor application
2287 = do { tick (KnownBranch case_bndr)
2288 ; case findAlt (DataAlt con) alts of
2289 Nothing -> missingAlt env case_bndr alts cont
2290 Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
2291 Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args
2292 case_bndr bs rhs cont
2293 }
2294 where
2295 simple_rhs bs rhs = ASSERT( null bs )
2296 do { (floats1, env') <- simplNonRecX env case_bndr scrut
2297 -- scrut is a constructor application,
2298 -- hence satisfies let/app invariant
2299 ; (floats2, expr') <- simplExprF env' rhs cont
2300 ; return (floats1 `addFloats` floats2, expr') }
2301
2302
2303 --------------------------------------------------
2304 -- 2. Eliminate the case if scrutinee is evaluated
2305 --------------------------------------------------
2306
2307 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
2308 -- See if we can get rid of the case altogether
2309 -- See Note [Case elimination]
2310 -- mkCase made sure that if all the alternatives are equal,
2311 -- then there is now only one (DEFAULT) rhs
2312
2313 -- 2a. Dropping the case altogether, if
2314 -- a) it binds nothing (so it's really just a 'seq')
2315 -- b) evaluating the scrutinee has no side effects
2316 | is_plain_seq
2317 , exprOkForSideEffects scrut
2318 -- The entire case is dead, so we can drop it
2319 -- if the scrutinee converges without having imperative
2320 -- side effects or raising a Haskell exception
2321 -- See Note [PrimOp can_fail and has_side_effects] in PrimOp
2322 = simplExprF env rhs cont
2323
2324 -- 2b. Turn the case into a let, if
2325 -- a) it binds only the case-binder
2326 -- b) unlifted case: the scrutinee is ok-for-speculation
2327 -- lifted case: the scrutinee is in HNF (or will later be demanded)
2328 -- See Note [Case to let transformation]
2329 | all_dead_bndrs
2330 , if isUnliftedType (idType case_bndr)
2331 then exprOkForSpeculation scrut
2332 else exprIsHNF scrut || scrut_is_demanded_var scrut
2333 = do { tick (CaseElim case_bndr)
2334 ; (floats1, env') <- simplNonRecX env case_bndr scrut
2335 ; (floats2, expr') <- simplExprF env' rhs cont
2336 ; return (floats1 `addFloats` floats2, expr') }
2337
2338 -- 2c. Try the seq rules if
2339 -- a) it binds only the case binder
2340 -- b) a rule for seq applies
2341 -- See Note [User-defined RULES for seq] in MkId
2342 | is_plain_seq
2343 = do { mb_rule <- trySeqRules env scrut rhs cont
2344 ; case mb_rule of
2345 Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'
2346 Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
2347 where
2348 all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId]
2349 is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
2350
2351 scrut_is_demanded_var :: CoreExpr -> Bool
2352 -- See Note [Eliminating redundant seqs]
2353 scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
2354 scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr)
2355 scrut_is_demanded_var _ = False
2356
2357
2358 rebuildCase env scrut case_bndr alts cont
2359 = reallyRebuildCase env scrut case_bndr alts cont
2360
2361 --------------------------------------------------
2362 -- 3. Catch-all case
2363 --------------------------------------------------
2364
2365 reallyRebuildCase env scrut case_bndr alts cont
2366 | not (sm_case_case (getMode env))
2367 = do { case_expr <- simplAlts env scrut case_bndr alts
2368 (mkBoringStop (contHoleType cont))
2369 ; rebuild env case_expr cont }
2370
2371 | otherwise
2372 = do { (floats, cont') <- mkDupableCaseCont env alts cont
2373 ; case_expr <- simplAlts (env `setInScopeFromF` floats)
2374 scrut case_bndr alts cont'
2375 ; return (floats, case_expr) }
2376
2377 {-
2378 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
2379 try to eliminate uses of v in the RHSs in favour of case_bndr; that
2380 way, there's a chance that v will now only be used once, and hence
2381 inlined.
2382
2383 Historical note: we use to do the "case binder swap" in the Simplifier
2384 so there were additional complications if the scrutinee was a variable.
2385 Now the binder-swap stuff is done in the occurrence analyser; see
2386 OccurAnal Note [Binder swap].
2387
2388 Note [knownCon occ info]
2389 ~~~~~~~~~~~~~~~~~~~~~~~~
2390 If the case binder is not dead, then neither are the pattern bound
2391 variables:
2392 case <any> of x { (a,b) ->
2393 case x of { (p,q) -> p } }
2394 Here (a,b) both look dead, but come alive after the inner case is eliminated.
2395 The point is that we bring into the envt a binding
2396 let x = (a,b)
2397 after the outer case, and that makes (a,b) alive. At least we do unless
2398 the case binder is guaranteed dead.
2399
2400 Note [Case alternative occ info]
2401 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2402 When we are simply reconstructing a case (the common case), we always
2403 zap the occurrence info on the binders in the alternatives. Even
2404 if the case binder is dead, the scrutinee is usually a variable, and *that*
2405 can bring the case-alternative binders back to life.
2406 See Note [Add unfolding for scrutinee]
2407
2408 Note [Improving seq]
2409 ~~~~~~~~~~~~~~~~~~~
2410 Consider
2411 type family F :: * -> *
2412 type instance F Int = Int
2413
2414 We'd like to transform
2415 case e of (x :: F Int) { DEFAULT -> rhs }
2416 ===>
2417 case e `cast` co of (x'::Int)
2418 I# x# -> let x = x' `cast` sym co
2419 in rhs
2420
2421 so that 'rhs' can take advantage of the form of x'. Notice that Note
2422 [Case of cast] (in OccurAnal) may then apply to the result.
2423
2424 We'd also like to eliminate empty types (Trac #13468). So if
2425
2426 data Void
2427 type instance F Bool = Void
2428
2429 then we'd like to transform
2430 case (x :: F Bool) of { _ -> error "urk" }
2431 ===>
2432 case (x |> co) of (x' :: Void) of {}
2433
2434 Nota Bene: we used to have a built-in rule for 'seq' that dropped
2435 casts, so that
2436 case (x |> co) of { _ -> blah }
2437 dropped the cast; in order to improve the chances of trySeqRules
2438 firing. But that works in the /opposite/ direction to Note [Improving
2439 seq] so there's a danger of flip/flopping. Better to make trySeqRules
2440 insensitive to the cast, which is now is.
2441
2442 The need for [Improving seq] showed up in Roman's experiments. Example:
2443 foo :: F Int -> Int -> Int
2444 foo t n = t `seq` bar n
2445 where
2446 bar 0 = 0
2447 bar n = bar (n - case t of TI i -> i)
2448 Here we'd like to avoid repeated evaluating t inside the loop, by
2449 taking advantage of the `seq`.
2450
2451 At one point I did transformation in LiberateCase, but it's more
2452 robust here. (Otherwise, there's a danger that we'll simply drop the
2453 'seq' altogether, before LiberateCase gets to see it.)
2454 -}
2455
2456 simplAlts :: SimplEnv
2457 -> OutExpr -- Scrutinee
2458 -> InId -- Case binder
2459 -> [InAlt] -- Non-empty
2460 -> SimplCont
2461 -> SimplM OutExpr -- Returns the complete simplified case expression
2462
2463 simplAlts env0 scrut case_bndr alts cont'
2464 = do { (env1, case_bndr1) <- simplBinder env0 case_bndr
2465 ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding
2466 env2 = modifyInScope env1 case_bndr2
2467 -- See Note [Case binder evaluated-ness]
2468
2469 ; fam_envs <- getFamEnvs
2470 ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut
2471 case_bndr case_bndr2 alts
2472
2473 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
2474 -- NB: it's possible that the returned in_alts is empty: this is handled
2475 -- by the caller (rebuildCase) in the missingAlt function
2476
2477 ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
2478 ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
2479
2480 ; let alts_ty' = contResultType cont'
2481 -- See Note [Avoiding space leaks in OutType]
2482 ; seqType alts_ty' `seq`
2483 mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }
2484
2485
2486 ------------------------------------
2487 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
2488 -> OutExpr -> InId -> OutId -> [InAlt]
2489 -> SimplM (SimplEnv, OutExpr, OutId)
2490 -- Note [Improving seq]
2491 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
2492 | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
2493 = do { case_bndr2 <- newId (fsLit "nt") ty2
2494 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing
2495 env2 = extendIdSubst env case_bndr rhs
2496 ; return (env2, scrut `Cast` co, case_bndr2) }
2497
2498 improveSeq _ env scrut _ case_bndr1 _
2499 = return (env, scrut, case_bndr1)
2500
2501
2502 ------------------------------------
2503 simplAlt :: SimplEnv
2504 -> Maybe OutExpr -- The scrutinee
2505 -> [AltCon] -- These constructors can't be present when
2506 -- matching the DEFAULT alternative
2507 -> OutId -- The case binder
2508 -> SimplCont
2509 -> InAlt
2510 -> SimplM OutAlt
2511
2512 simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
2513 = ASSERT( null bndrs )
2514 do { let env' = addBinderUnfolding env case_bndr'
2515 (mkOtherCon imposs_deflt_cons)
2516 -- Record the constructors that the case-binder *can't* be.
2517 ; rhs' <- simplExprC env' rhs cont'
2518 ; return (DEFAULT, [], rhs') }
2519
2520 simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
2521 = ASSERT( null bndrs )
2522 do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)
2523 ; rhs' <- simplExprC env' rhs cont'
2524 ; return (LitAlt lit, [], rhs') }
2525
2526 simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
2527 = do { -- Deal with the pattern-bound variables
2528 -- Mark the ones that are in ! positions in the
2529 -- data constructor as certainly-evaluated.
2530 -- NB: simplLamBinders preserves this eval info
2531 ; let vs_with_evals = add_evals (dataConRepStrictness con)
2532 ; (env', vs') <- simplLamBndrs env vs_with_evals
2533
2534 -- Bind the case-binder to (con args)
2535 ; let inst_tys' = tyConAppArgs (idType case_bndr')
2536 con_app :: OutExpr
2537 con_app = mkConApp2 con inst_tys' vs'
2538
2539 ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
2540 ; rhs' <- simplExprC env'' rhs cont'
2541 ; return (DataAlt con, vs', rhs') }
2542 where
2543 -- add_evals records the evaluated-ness of the bound variables of
2544 -- a case pattern. This is *important*. Consider
2545 -- data T = T !Int !Int
2546 --
2547 -- case x of { T a b -> T (a+1) b }
2548 --
2549 -- We really must record that b is already evaluated so that we don't
2550 -- go and re-evaluate it when constructing the result.
2551 -- See Note [Data-con worker strictness] in MkId.hs
2552 add_evals the_strs
2553 = go vs the_strs
2554 where
2555 go [] [] = []
2556 go (v:vs') strs | isTyVar v = v : go vs' strs
2557 go (v:vs') (str:strs) = zap str v : go vs' strs
2558 go _ _ = pprPanic "cat_evals"
2559 (ppr con $$
2560 ppr vs $$
2561 ppr_with_length the_strs $$
2562 ppr_with_length (dataConRepArgTys con) $$
2563 ppr_with_length (dataConRepStrictness con))
2564 where
2565 ppr_with_length list
2566 = ppr list <+> parens (text "length =" <+> ppr (length list))
2567 -- NB: If this panic triggers, note that
2568 -- NoStrictnessMark doesn't print!
2569
2570 zap str v = setCaseBndrEvald str $ -- Add eval'dness info
2571 zapIdOccInfo v -- And kill occ info;
2572 -- see Note [Case alternative occ info]
2573
2574 addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
2575 addAltUnfoldings env scrut case_bndr con_app
2576 = do { let con_app_unf = mk_simple_unf con_app
2577 env1 = addBinderUnfolding env case_bndr con_app_unf
2578
2579 -- See Note [Add unfolding for scrutinee]
2580 env2 = case scrut of
2581 Just (Var v) -> addBinderUnfolding env1 v con_app_unf
2582 Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
2583 mk_simple_unf (Cast con_app (mkSymCo co))
2584 _ -> env1
2585
2586 ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
2587 ; return env2 }
2588 where
2589 mk_simple_unf = mkSimpleUnfolding (seDynFlags env)
2590
2591 addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
2592 addBinderUnfolding env bndr unf
2593 | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
2594 = WARN( not (eqType (idType bndr) (exprType tmpl)),
2595 ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )
2596 modifyInScope env (bndr `setIdUnfolding` unf)
2597
2598 | otherwise
2599 = modifyInScope env (bndr `setIdUnfolding` unf)
2600
2601 zapBndrOccInfo :: Bool -> Id -> Id
2602 -- Consider case e of b { (a,b) -> ... }
2603 -- Then if we bind b to (a,b) in "...", and b is not dead,
2604 -- then we must zap the deadness info on a,b
2605 zapBndrOccInfo keep_occ_info pat_id
2606 | keep_occ_info = pat_id
2607 | otherwise = zapIdOccInfo pat_id
2608
2609 {- Note [Case binder evaluated-ness]
2610 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2611 We pin on a (OtherCon []) unfolding to the case-binder of a Case,
2612 even though it'll be over-ridden in every case alternative with a more
2613 informative unfolding. Why? Because suppose a later, less clever, pass
2614 simply replaces all occurrences of the case binder with the binder itself;
2615 then Lint may complain about the let/app invariant. Example
2616 case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....
2617 ; K -> blah }
2618
2619 The let/app invariant requires that y is evaluated in the call to
2620 reallyUnsafePtrEq#, which it is. But we still want that to be true if we
2621 propagate binders to occurrences.
2622
2623 This showed up in Trac #13027.
2624
2625 Note [Add unfolding for scrutinee]
2626 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2627 In general it's unlikely that a variable scrutinee will appear
2628 in the case alternatives case x of { ...x unlikely to appear... }
2629 because the binder-swap in OccAnal has got rid of all such occurrences
2630 See Note [Binder swap] in OccAnal.
2631
2632 BUT it is still VERY IMPORTANT to add a suitable unfolding for a
2633 variable scrutinee, in simplAlt. Here's why
2634 case x of y
2635 (a,b) -> case b of c
2636 I# v -> ...(f y)...
2637 There is no occurrence of 'b' in the (...(f y)...). But y gets
2638 the unfolding (a,b), and *that* mentions b. If f has a RULE
2639 RULE f (p, I# q) = ...
2640 we want that rule to match, so we must extend the in-scope env with a
2641 suitable unfolding for 'y'. It's *essential* for rule matching; but
2642 it's also good for case-elimintation -- suppose that 'f' was inlined
2643 and did multi-level case analysis, then we'd solve it in one
2644 simplifier sweep instead of two.
2645
2646 Exactly the same issue arises in SpecConstr;
2647 see Note [Add scrutinee to ValueEnv too] in SpecConstr
2648
2649 HOWEVER, given
2650 case x of y { Just a -> r1; Nothing -> r2 }
2651 we do not want to add the unfolding x -> y to 'x', which might seem cool,
2652 since 'y' itself has different unfoldings in r1 and r2. Reason: if we
2653 did that, we'd have to zap y's deadness info and that is a very useful
2654 piece of information.
2655
2656 So instead we add the unfolding x -> Just a, and x -> Nothing in the
2657 respective RHSs.
2658
2659
2660 ************************************************************************
2661 * *
2662 \subsection{Known constructor}
2663 * *
2664 ************************************************************************
2665
2666 We are a bit careful with occurrence info. Here's an example
2667
2668 (\x* -> case x of (a*, b) -> f a) (h v, e)
2669
2670 where the * means "occurs once". This effectively becomes
2671 case (h v, e) of (a*, b) -> f a)
2672 and then
2673 let a* = h v; b = e in f a
2674 and then
2675 f (h v)
2676
2677 All this should happen in one sweep.
2678 -}
2679
2680 knownCon :: SimplEnv
2681 -> OutExpr -- The scrutinee
2682 -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces)
2683 -> InId -> [InBndr] -> InExpr -- The alternative
2684 -> SimplCont
2685 -> SimplM (SimplFloats, OutExpr)
2686
2687 knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
2688 = do { (floats1, env1) <- bind_args env bs dc_args
2689 ; (floats2, env2) <- bind_case_bndr env1
2690 ; (floats3, expr') <- simplExprF env2 rhs cont
2691 ; return (floats1 `addFloats` floats2 `addFloats` floats3, expr') }
2692 where
2693 zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId
2694
2695 -- Ugh!
2696 bind_args env' [] _ = return (emptyFloats env', env')
2697
2698 bind_args env' (b:bs') (Type ty : args)
2699 = ASSERT( isTyVar b )
2700 bind_args (extendTvSubst env' b ty) bs' args
2701
2702 bind_args env' (b:bs') (Coercion co : args)
2703 = ASSERT( isCoVar b )
2704 bind_args (extendCvSubst env' b co) bs' args
2705
2706 bind_args env' (b:bs') (arg : args)
2707 = ASSERT( isId b )
2708 do { let b' = zap_occ b
2709 -- Note that the binder might be "dead", because it doesn't
2710 -- occur in the RHS; and simplNonRecX may therefore discard
2711 -- it via postInlineUnconditionally.
2712 -- Nevertheless we must keep it if the case-binder is alive,
2713 -- because it may be used in the con_app. See Note [knownCon occ info]
2714 ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let/app invariant
2715 ; (floats2, env3) <- bind_args env2 bs' args
2716 ; return (floats1 `addFloats` floats2, env3) }
2717
2718 bind_args _ _ _ =
2719 pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
2720 text "scrut:" <+> ppr scrut
2721
2722 -- It's useful to bind bndr to scrut, rather than to a fresh
2723 -- binding x = Con arg1 .. argn
2724 -- because very often the scrut is a variable, so we avoid
2725 -- creating, and then subsequently eliminating, a let-binding
2726 -- BUT, if scrut is a not a variable, we must be careful
2727 -- about duplicating the arg redexes; in that case, make
2728 -- a new con-app from the args
2729 bind_case_bndr env
2730 | isDeadBinder bndr = return (emptyFloats env, env)
2731 | exprIsTrivial scrut = return (emptyFloats env
2732 , extendIdSubst env bndr (DoneEx scrut Nothing))
2733 | otherwise = do { dc_args <- mapM (simplVar env) bs
2734 -- dc_ty_args are aready OutTypes,
2735 -- but bs are InBndrs
2736 ; let con_app = Var (dataConWorkId dc)
2737 `mkTyApps` dc_ty_args
2738 `mkApps` dc_args
2739 ; simplNonRecX env bndr con_app }
2740
2741 -------------------
2742 missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
2743 -> SimplM (SimplFloats, OutExpr)
2744 -- This isn't strictly an error, although it is unusual.
2745 -- It's possible that the simplifier might "see" that
2746 -- an inner case has no accessible alternatives before
2747 -- it "sees" that the entire branch of an outer case is
2748 -- inaccessible. So we simply put an error case here instead.
2749 missingAlt env case_bndr _ cont
2750 = WARN( True, text "missingAlt" <+> ppr case_bndr )
2751 -- See Note [Avoiding space leaks in OutType]
2752 let cont_ty = contResultType cont
2753 in seqType cont_ty `seq`
2754 return (emptyFloats env, mkImpossibleExpr cont_ty)
2755
2756 {-
2757 ************************************************************************
2758 * *
2759 \subsection{Duplicating continuations}
2760 * *
2761 ************************************************************************
2762
2763 Consider
2764 let x* = case e of { True -> e1; False -> e2 }
2765 in b
2766 where x* is a strict binding. Then mkDupableCont will be given
2767 the continuation
2768 case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop
2769 and will split it into
2770 dupable: case [] of { True -> $j1; False -> $j2 } ; stop
2771 join floats: $j1 = e1, $j2 = e2
2772 non_dupable: let x* = [] in b; stop
2773
2774 Putting this back together would give
2775 let x* = let { $j1 = e1; $j2 = e2 } in
2776 case e of { True -> $j1; False -> $j2 }
2777 in b
2778 (Of course we only do this if 'e' wants to duplicate that continuation.)
2779 Note how important it is that the new join points wrap around the
2780 inner expression, and not around the whole thing.
2781
2782 In contrast, any let-bindings introduced by mkDupableCont can wrap
2783 around the entire thing.
2784
2785 Note [Bottom alternatives]
2786 ~~~~~~~~~~~~~~~~~~~~~~~~~~
2787 When we have
2788 case (case x of { A -> error .. ; B -> e; C -> error ..)
2789 of alts
2790 then we can just duplicate those alts because the A and C cases
2791 will disappear immediately. This is more direct than creating
2792 join points and inlining them away. See Trac #4930.
2793 -}
2794
2795 --------------------
2796 mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont
2797 -> SimplM (SimplFloats, SimplCont)
2798 mkDupableCaseCont env alts cont
2799 | altsWouldDup alts = mkDupableCont env cont
2800 | otherwise = return (emptyFloats env, cont)
2801
2802 altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
2803 altsWouldDup [] = False -- See Note [Bottom alternatives]
2804 altsWouldDup [_] = False
2805 altsWouldDup (alt:alts)
2806 | is_bot_alt alt = altsWouldDup alts
2807 | otherwise = not (all is_bot_alt alts)
2808 where
2809 is_bot_alt (_,_,rhs) = exprIsBottom rhs
2810
2811 -------------------------
2812 mkDupableCont :: SimplEnv -> SimplCont
2813 -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with
2814 -- extra let/join-floats and in-scope variables
2815 , SimplCont) -- dup_cont: duplicable continuation
2816
2817 mkDupableCont env cont
2818 | contIsDupable cont
2819 = return (emptyFloats env, cont)
2820
2821 mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
2822
2823 mkDupableCont env (CastIt ty cont)
2824 = do { (floats, cont') <- mkDupableCont env cont
2825 ; return (floats, CastIt ty cont') }
2826
2827 -- Duplicating ticks for now, not sure if this is good or not
2828 mkDupableCont env (TickIt t cont)
2829 = do { (floats, cont') <- mkDupableCont env cont
2830 ; return (floats, TickIt t cont') }
2831
2832 mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
2833 , sc_body = body, sc_env = se, sc_cont = cont})
2834 -- See Note [Duplicating StrictBind]
2835 = do { let sb_env = se `setInScopeFromE` env
2836 ; (sb_env1, bndr') <- simplBinder sb_env bndr
2837 ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont
2838 -- No need to use mkDupableCont before simplLam; we
2839 -- use cont once here, and then share the result if necessary
2840
2841 ; let join_body = wrapFloats floats1 join_inner
2842 res_ty = contResultType cont
2843
2844 ; (floats2, body2)
2845 <- if exprIsDupable (seDynFlags env) join_body
2846 then return (emptyFloats env, join_body)
2847 else do { join_bndr <- newJoinId [bndr'] res_ty
2848 ; let join_call = App (Var join_bndr) (Var bndr')
2849 join_rhs = Lam (setOneShotLambda bndr') join_body
2850 join_bind = NonRec join_bndr join_rhs
2851 floats = emptyFloats env `extendFloats` join_bind
2852 ; return (floats, join_call) }
2853 ; return ( floats2
2854 , StrictBind { sc_bndr = bndr', sc_bndrs = []
2855 , sc_body = body2
2856 , sc_env = zapSubstEnv se
2857 , sc_dup = OkToDup
2858 , sc_cont = mkBoringStop res_ty } ) }
2859
2860 mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })
2861 -- See Note [Duplicating StrictArg]
2862 -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
2863 = do { (floats1, cont') <- mkDupableCont env cont
2864 ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))
2865 (ai_args info)
2866 ; return ( foldl addLetFloats floats1 floats_s
2867 , StrictArg { sc_fun = info { ai_args = args' }
2868 , sc_cci = cci
2869 , sc_cont = cont'
2870 , sc_dup = OkToDup} ) }
2871
2872 mkDupableCont env (ApplyToTy { sc_cont = cont
2873 , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
2874 = do { (floats, cont') <- mkDupableCont env cont
2875 ; return (floats, ApplyToTy { sc_cont = cont'
2876 , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
2877
2878 mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
2879 , sc_env = se, sc_cont = cont })
2880 = -- e.g. [...hole...] (...arg...)
2881 -- ==>
2882 -- let a = ...arg...
2883 -- in [...hole...] a
2884 -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
2885 do { (floats1, cont') <- mkDupableCont env cont
2886 ; let env' = env `setInScopeFromF` floats1
2887 ; (_, se', arg') <- simplArg env' dup se arg
2888 ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'
2889 ; return ( floats1 `addLetFloats` let_floats2
2890 , ApplyToVal { sc_arg = arg'', sc_env = se'
2891 , sc_dup = OkToDup, sc_cont = cont' }) }
2892
2893 mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
2894 , sc_env = se, sc_cont = cont })
2895 = -- e.g. (case [...hole...] of { pi -> ei })
2896 -- ===>
2897 -- let ji = \xij -> ei
2898 -- in case [...hole...] of { pi -> ji xij }
2899 -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
2900 do { tick (CaseOfCase case_bndr)
2901 ; (floats, alt_cont) <- mkDupableCaseCont env alts cont
2902 -- NB: We call mkDupableCaseCont here to make cont duplicable
2903 -- (if necessary, depending on the number of alts)
2904 -- And this is important: see Note [Fusing case continuations]
2905
2906 ; let alt_env = se `setInScopeFromF` floats
2907 ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
2908 ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts
2909 -- Safe to say that there are no handled-cons for the DEFAULT case
2910 -- NB: simplBinder does not zap deadness occ-info, so
2911 -- a dead case_bndr' will still advertise its deadness
2912 -- This is really important because in
2913 -- case e of b { (# p,q #) -> ... }
2914 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
2915 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
2916 -- In the new alts we build, we have the new case binder, so it must retain
2917 -- its deadness.
2918 -- NB: we don't use alt_env further; it has the substEnv for
2919 -- the alternatives, and we don't want that
2920
2921 ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr')
2922 emptyJoinFloats alts'
2923
2924 ; return (floats `addJoinFloats` join_floats, -- Note [Duplicated env]
2925 Select { sc_dup = OkToDup
2926 , sc_bndr = case_bndr'
2927 , sc_alts = alts''
2928 , sc_env = zapSubstEnv env
2929 , sc_cont = mkBoringStop (contResultType cont) } ) }
2930
2931 mkDupableAlt :: DynFlags -> OutId
2932 -> JoinFloats -> OutAlt
2933 -> SimplM (JoinFloats, OutAlt)
2934 mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs')
2935 | exprIsDupable dflags rhs' -- Note [Small alternative rhs]
2936 = return (jfloats, (con, bndrs', rhs'))
2937
2938 | otherwise
2939 = do { let rhs_ty' = exprType rhs'
2940 scrut_ty = idType case_bndr
2941 case_bndr_w_unf
2942 = case con of
2943 DEFAULT -> case_bndr
2944 DataAlt dc -> setIdUnfolding case_bndr unf
2945 where
2946 -- See Note [Case binders and join points]
2947 unf = mkInlineUnfolding rhs
2948 rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
2949
2950 LitAlt {} -> WARN( True, text "mkDupableAlt"
2951 <+> ppr case_bndr <+> ppr con )
2952 case_bndr
2953 -- The case binder is alive but trivial, so why has
2954 -- it not been substituted away?
2955
2956 final_bndrs'
2957 | isDeadBinder case_bndr = filter abstract_over bndrs'
2958 | otherwise = bndrs' ++ [case_bndr_w_unf]
2959
2960 abstract_over bndr
2961 | isTyVar bndr = True -- Abstract over all type variables just in case
2962 | otherwise = not (isDeadBinder bndr)
2963 -- The deadness info on the new Ids is preserved by simplBinders
2964 final_args = varsToCoreExprs final_bndrs'
2965 -- Note [Join point abstraction]
2966
2967 -- We make the lambdas into one-shot-lambdas. The
2968 -- join point is sure to be applied at most once, and doing so
2969 -- prevents the body of the join point being floated out by
2970 -- the full laziness pass
2971 really_final_bndrs = map one_shot final_bndrs'
2972 one_shot v | isId v = setOneShotLambda v
2973 | otherwise = v
2974 join_rhs = mkLams really_final_bndrs rhs'
2975
2976 ; join_bndr <- newJoinId final_bndrs' rhs_ty'
2977
2978 ; let join_call = mkApps (Var join_bndr) final_args
2979 alt' = (con, bndrs', join_call)
2980
2981 ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)
2982 , alt') }
2983 -- See Note [Duplicated env]
2984
2985 {-
2986 Note [Fusing case continuations]
2987 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2988 It's important to fuse two successive case continuations when the
2989 first has one alternative. That's why we call prepareCaseCont here.
2990 Consider this, which arises from thunk splitting (see Note [Thunk
2991 splitting] in WorkWrap):
2992
2993 let
2994 x* = case (case v of {pn -> rn}) of
2995 I# a -> I# a
2996 in body
2997
2998 The simplifier will find
2999 (Var v) with continuation
3000 Select (pn -> rn) (
3001 Select [I# a -> I# a] (
3002 StrictBind body Stop
3003
3004 So we'll call mkDupableCont on
3005 Select [I# a -> I# a] (StrictBind body Stop)
3006 There is just one alternative in the first Select, so we want to
3007 simplify the rhs (I# a) with continuation (StrictBind body Stop)
3008 Supposing that body is big, we end up with
3009 let $j a = <let x = I# a in body>
3010 in case v of { pn -> case rn of
3011 I# a -> $j a }
3012 This is just what we want because the rn produces a box that
3013 the case rn cancels with.
3014
3015 See Trac #4957 a fuller example.
3016
3017 Note [Case binders and join points]
3018 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3019 Consider this
3020 case (case .. ) of c {
3021 I# c# -> ....c....
3022
3023 If we make a join point with c but not c# we get
3024 $j = \c -> ....c....
3025
3026 But if later inlining scrutinises the c, thus
3027
3028 $j = \c -> ... case c of { I# y -> ... } ...
3029
3030 we won't see that 'c' has already been scrutinised. This actually
3031 happens in the 'tabulate' function in wave4main, and makes a significant
3032 difference to allocation.
3033
3034 An alternative plan is this:
3035
3036 $j = \c# -> let c = I# c# in ...c....
3037
3038 but that is bad if 'c' is *not* later scrutinised.
3039
3040 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
3041 (a stable unfolding) that it's really I# c#, thus
3042
3043 $j = \c# -> \c[=I# c#] -> ...c....
3044
3045 Absence analysis may later discard 'c'.
3046
3047 NB: take great care when doing strictness analysis;
3048 see Note [Lambda-bound unfoldings] in DmdAnal.
3049
3050 Also note that we can still end up passing stuff that isn't used. Before
3051 strictness analysis we have
3052 let $j x y c{=(x,y)} = (h c, ...)
3053 in ...
3054 After strictness analysis we see that h is strict, we end up with
3055 let $j x y c{=(x,y)} = ($wh x y, ...)
3056 and c is unused.
3057
3058 Note [Duplicated env]
3059 ~~~~~~~~~~~~~~~~~~~~~
3060 Some of the alternatives are simplified, but have not been turned into a join point
3061 So they *must* have a zapped subst-env. So we can't use completeNonRecX to
3062 bind the join point, because it might to do PostInlineUnconditionally, and
3063 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
3064 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
3065 at worst delays the join-point inlining.
3066
3067 Note [Small alternative rhs]
3068 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3069 It is worth checking for a small RHS because otherwise we
3070 get extra let bindings that may cause an extra iteration of the simplifier to
3071 inline back in place. Quite often the rhs is just a variable or constructor.
3072 The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra
3073 iterations because the version with the let bindings looked big, and so wasn't
3074 inlined, but after the join points had been inlined it looked smaller, and so
3075 was inlined.
3076
3077 NB: we have to check the size of rhs', not rhs.
3078 Duplicating a small InAlt might invalidate occurrence information
3079 However, if it *is* dupable, we return the *un* simplified alternative,
3080 because otherwise we'd need to pair it up with an empty subst-env....
3081 but we only have one env shared between all the alts.
3082 (Remember we must zap the subst-env before re-simplifying something).
3083 Rather than do this we simply agree to re-simplify the original (small) thing later.
3084
3085 Note [Funky mkLamTypes]
3086 ~~~~~~~~~~~~~~~~~~~~~~
3087 Notice the funky mkLamTypes. If the constructor has existentials
3088 it's possible that the join point will be abstracted over
3089 type variables as well as term variables.
3090 Example: Suppose we have
3091 data T = forall t. C [t]
3092 Then faced with
3093 case (case e of ...) of
3094 C t xs::[t] -> rhs
3095 We get the join point
3096 let j :: forall t. [t] -> ...
3097 j = /\t \xs::[t] -> rhs
3098 in
3099 case (case e of ...) of
3100 C t xs::[t] -> j t xs
3101
3102 Note [Duplicating StrictArg]
3103 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3104 We make a StrictArg duplicable simply by making all its
3105 stored-up arguments (in sc_fun) trivial, by let-binding
3106 them. Thus:
3107 f E [..hole..]
3108 ==> let a = E
3109 in f a [..hole..]
3110 Now if the thing in the hole is a case expression (which is when
3111 we'll call mkDupableCont), we'll push the function call into the
3112 branches, which is what we want. Now RULES for f may fire, and
3113 call-pattern specialisation. Here's an example from Trac #3116
3114 go (n+1) (case l of
3115 1 -> bs'
3116 _ -> Chunk p fpc (o+1) (l-1) bs')
3117 If we can push the call for 'go' inside the case, we get
3118 call-pattern specialisation for 'go', which is *crucial* for
3119 this program.
3120
3121 Here is the (&&) example:
3122 && E (case x of { T -> F; F -> T })
3123 ==> let a = E in
3124 case x of { T -> && a F; F -> && a T }
3125 Much better!
3126
3127 Notice that
3128 * Arguments to f *after* the strict one are handled by
3129 the ApplyToVal case of mkDupableCont. Eg
3130 f [..hole..] E
3131
3132 * We can only do the let-binding of E because the function
3133 part of a StrictArg continuation is an explicit syntax
3134 tree. In earlier versions we represented it as a function
3135 (CoreExpr -> CoreEpxr) which we couldn't take apart.
3136
3137 Historical aide: previously we did this (where E is a
3138 big argument:
3139 f E [..hole..]
3140 ==> let $j = \a -> f E a
3141 in $j [..hole..]
3142
3143 But this is terrible! Here's an example:
3144 && E (case x of { T -> F; F -> T })
3145 Now, && is strict so we end up simplifying the case with
3146 an ArgOf continuation. If we let-bind it, we get
3147 let $j = \v -> && E v
3148 in simplExpr (case x of { T -> F; F -> T })
3149 (ArgOf (\r -> $j r)
3150 And after simplifying more we get
3151 let $j = \v -> && E v
3152 in case x of { T -> $j F; F -> $j T }
3153 Which is a Very Bad Thing
3154
3155
3156 Note [Duplicating StrictBind]
3157 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3158 We make a StrictBind duplicable in a very similar way to
3159 that for case expressions. After all,
3160 let x* = e in b is similar to case e of x -> b
3161
3162 So we potentially make a join-point for the body, thus:
3163 let x = [] in b ==> join j x = b
3164 in let x = [] in j x
3165
3166
3167 Note [Join point abstraction] Historical note
3168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3169 NB: This note is now historical, describing how (in the past) we used
3170 to add a void argument to nullary join points. But now that "join
3171 point" is not a fuzzy concept but a formal syntactic construct (as
3172 distinguished by the JoinId constructor of IdDetails), each of these
3173 concerns is handled separately, with no need for a vestigial extra
3174 argument.
3175
3176 Join points always have at least one value argument,
3177 for several reasons
3178
3179 * If we try to lift a primitive-typed something out
3180 for let-binding-purposes, we will *caseify* it (!),
3181 with potentially-disastrous strictness results. So
3182 instead we turn it into a function: \v -> e
3183 where v::Void#. The value passed to this function is void,
3184 which generates (almost) no code.
3185
3186 * CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now
3187 we make the join point into a function whenever used_bndrs'
3188 is empty. This makes the join-point more CPR friendly.
3189 Consider: let j = if .. then I# 3 else I# 4
3190 in case .. of { A -> j; B -> j; C -> ... }
3191
3192 Now CPR doesn't w/w j because it's a thunk, so
3193 that means that the enclosing function can't w/w either,
3194 which is a lose. Here's the example that happened in practice:
3195 kgmod :: Int -> Int -> Int
3196 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
3197 then 78
3198 else 5
3199
3200 * Let-no-escape. We want a join point to turn into a let-no-escape
3201 so that it is implemented as a jump, and one of the conditions
3202 for LNE is that it's not updatable. In CoreToStg, see
3203 Note [What is a non-escaping let]
3204
3205 * Floating. Since a join point will be entered once, no sharing is
3206 gained by floating out, but something might be lost by doing
3207 so because it might be allocated.
3208
3209 I have seen a case alternative like this:
3210 True -> \v -> ...
3211 It's a bit silly to add the realWorld dummy arg in this case, making
3212 $j = \s v -> ...
3213 True -> $j s
3214 (the \v alone is enough to make CPR happy) but I think it's rare
3215
3216 There's a slight infelicity here: we pass the overall
3217 case_bndr to all the join points if it's used in *any* RHS,
3218 because we don't know its usage in each RHS separately
3219
3220
3221
3222 ************************************************************************
3223 * *
3224 Unfoldings
3225 * *
3226 ************************************************************************
3227 -}
3228
3229 simplLetUnfolding :: SimplEnv-> TopLevelFlag
3230 -> Maybe SimplCont
3231 -> InId
3232 -> OutExpr
3233 -> Unfolding -> SimplM Unfolding
3234 simplLetUnfolding env top_lvl cont_mb id new_rhs unf
3235 | isStableUnfolding unf
3236 = simplStableUnfolding env top_lvl cont_mb id unf
3237 | otherwise
3238 = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs
3239
3240 -------------------
3241 mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource
3242 -> InId -> OutExpr -> SimplM Unfolding
3243 mkLetUnfolding dflags top_lvl src id new_rhs
3244 = is_bottoming `seq` -- See Note [Force bottoming field]
3245 return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)
3246 -- We make an unfolding *even for loop-breakers*.
3247 -- Reason: (a) It might be useful to know that they are WHNF
3248 -- (b) In TidyPgm we currently assume that, if we want to
3249 -- expose the unfolding then indeed we *have* an unfolding
3250 -- to expose. (We could instead use the RHS, but currently
3251 -- we don't.) The simple thing is always to have one.
3252 where
3253 is_top_lvl = isTopLevel top_lvl
3254 is_bottoming = isBottomingId id
3255
3256 -------------------
3257 simplStableUnfolding :: SimplEnv -> TopLevelFlag
3258 -> Maybe SimplCont -- Just k => a join point with continuation k
3259 -> InId
3260 -> Unfolding -> SimplM Unfolding
3261 -- Note [Setting the new unfolding]
3262 simplStableUnfolding env top_lvl mb_cont id unf
3263 = case unf of
3264 NoUnfolding -> return unf
3265 BootUnfolding -> return unf
3266 OtherCon {} -> return unf
3267
3268 DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
3269 -> do { (env', bndrs') <- simplBinders rule_env bndrs
3270 ; args' <- mapM (simplExpr env') args
3271 ; return (mkDFunUnfolding bndrs' con args') }
3272
3273 CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
3274 | isStableSource src
3275 -> do { expr' <- case mb_cont of
3276 Just cont -> simplJoinRhs rule_env id expr cont
3277 Nothing -> simplExpr rule_env expr
3278 ; case guide of
3279 UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok } -- Happens for INLINE things
3280 -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok
3281 , ug_boring_ok = inlineBoringOk expr' }
3282 -- Refresh the boring-ok flag, in case expr'
3283 -- has got small. This happens, notably in the inlinings
3284 -- for dfuns for single-method classes; see
3285 -- Note [Single-method classes] in TcInstDcls.
3286 -- A test case is Trac #4138
3287 in return (mkCoreUnfolding src is_top_lvl expr' guide')
3288 -- See Note [Top-level flag on inline rules] in CoreUnfold
3289
3290 _other -- Happens for INLINABLE things
3291 -> mkLetUnfolding dflags top_lvl src id expr' }
3292 -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
3293 -- unfolding, and we need to make sure the guidance is kept up
3294 -- to date with respect to any changes in the unfolding.
3295
3296 | otherwise -> return noUnfolding -- Discard unstable unfoldings
3297 where
3298 dflags = seDynFlags env
3299 is_top_lvl = isTopLevel top_lvl
3300 act = idInlineActivation id
3301 rule_env = updMode (updModeForStableUnfoldings act) env
3302 -- See Note [Simplifying inside stable unfoldings] in SimplUtils
3303
3304 {-
3305 Note [Force bottoming field]
3306 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3307 We need to force bottoming, or the new unfolding holds
3308 on to the old unfolding (which is part of the id).
3309
3310 Note [Setting the new unfolding]
3311 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3312 * If there's an INLINE pragma, we simplify the RHS gently. Maybe we
3313 should do nothing at all, but simplifying gently might get rid of
3314 more crap.
3315
3316 * If not, we make an unfolding from the new RHS. But *only* for
3317 non-loop-breakers. Making loop breakers not have an unfolding at all
3318 means that we can avoid tests in exprIsConApp, for example. This is
3319 important: if exprIsConApp says 'yes' for a recursive thing, then we
3320 can get into an infinite loop
3321
3322 If there's a stable unfolding on a loop breaker (which happens for
3323 INLINABLE), we hang on to the inlining. It's pretty dodgy, but the
3324 user did say 'INLINE'. May need to revisit this choice.
3325
3326 ************************************************************************
3327 * *
3328 Rules
3329 * *
3330 ************************************************************************
3331
3332 Note [Rules in a letrec]
3333 ~~~~~~~~~~~~~~~~~~~~~~~~
3334 After creating fresh binders for the binders of a letrec, we
3335 substitute the RULES and add them back onto the binders; this is done
3336 *before* processing any of the RHSs. This is important. Manuel found
3337 cases where he really, really wanted a RULE for a recursive function
3338 to apply in that function's own right-hand side.
3339
3340 See Note [Forming Rec groups] in OccurAnal
3341 -}
3342
3343 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> SimplM (SimplEnv, OutBndr)
3344 -- Rules are added back into the bin
3345 addBndrRules env in_id out_id
3346 | null old_rules
3347 = return (env, out_id)
3348 | otherwise
3349 = do { new_rules <- simplRules env (Just (idName out_id)) old_rules
3350 ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules
3351 ; return (modifyInScope env final_id, final_id) }
3352 where
3353 old_rules = ruleInfoRules (idSpecialisation in_id)
3354
3355 simplRules :: SimplEnv -> Maybe Name -> [CoreRule] -> SimplM [CoreRule]
3356 simplRules env mb_new_nm rules
3357 = mapM simpl_rule rules
3358 where
3359 simpl_rule rule@(BuiltinRule {})
3360 = return rule
3361
3362 simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args
3363 , ru_fn = fn_name, ru_rhs = rhs })
3364 = do { (env', bndrs') <- simplBinders env bndrs
3365 ; let rhs_ty = substTy env' (exprType rhs)
3366 rule_cont = mkBoringStop rhs_ty
3367 rule_env = updMode updModeForRules env'
3368 ; args' <- mapM (simplExpr rule_env) args
3369 ; rhs' <- simplExprC rule_env rhs rule_cont
3370 ; return (rule { ru_bndrs = bndrs'
3371 , ru_fn = mb_new_nm `orElse` fn_name
3372 , ru_args = args'
3373 , ru_rhs = rhs' }) }