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