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