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