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