2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[Simplify]{The main module of the simplifier}
7 module Simplify ( simplTopBinds, simplExpr ) where
9 #include "HsVersions.h"
13 import Type hiding ( substTy, extendTvSubst, substTyVar )
16 import FamInstEnv ( FamInstEnv )
18 import MkId ( mkImpossibleExpr, seqId )
21 import Name ( mkSystemVarName, isExternalName )
23 import OptCoercion ( optCoercion )
24 import FamInstEnv ( topNormaliseType )
25 import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
26 import CoreMonad ( SimplifierSwitch(..), Tick(..) )
28 import Demand ( isStrictDmd, splitStrictSig )
29 import PprCore ( pprParendExpr, pprCoreExpr )
30 import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule,
31 exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
33 import qualified CoreSubst
34 import CoreArity ( exprArity )
35 import Rules ( lookupRule, getRules )
36 import BasicTypes ( isMarkedStrict, Arity )
37 import CostCentre ( currentCCS, pushCCisNop )
38 import TysPrim ( realWorldStatePrimTy )
39 import PrelInfo ( realWorldPrimId )
40 import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
41 import MonadUtils ( foldlM, mapAccumLM )
42 import Maybes ( orElse )
43 import Data.List ( mapAccumL )
49 The guts of the simplifier is in this module, but the driver loop for
50 the simplifier is in SimplCore.lhs.
53 -----------------------------------------
54 *** IMPORTANT NOTE ***
55 -----------------------------------------
56 The simplifier used to guarantee that the output had no shadowing, but
57 it does not do so any more. (Actually, it never did!) The reason is
58 documented with simplifyArgs.
61 -----------------------------------------
62 *** IMPORTANT NOTE ***
63 -----------------------------------------
64 Many parts of the simplifier return a bunch of "floats" as well as an
65 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
67 All "floats" are let-binds, not case-binds, but some non-rec lets may
68 be unlifted (with RHS ok-for-speculation).
72 -----------------------------------------
73 ORGANISATION OF FUNCTIONS
74 -----------------------------------------
76 - simplify all top-level binders
77 - for NonRec, call simplRecOrTopPair
78 - for Rec, call simplRecBind
81 ------------------------------
82 simplExpr (applied lambda) ==> simplNonRecBind
83 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
84 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
86 ------------------------------
87 simplRecBind [binders already simplfied]
88 - use simplRecOrTopPair on each pair in turn
90 simplRecOrTopPair [binder already simplified]
91 Used for: recursive bindings (top level and nested)
92 top-level non-recursive bindings
94 - check for PreInlineUnconditionally
98 Used for: non-top-level non-recursive bindings
99 beta reductions (which amount to the same thing)
100 Because it can deal with strict arts, it takes a
101 "thing-inside" and returns an expression
103 - check for PreInlineUnconditionally
104 - simplify binder, including its IdInfo
113 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
114 Used for: binding case-binder and constr args in a known-constructor case
115 - check for PreInLineUnconditionally
119 ------------------------------
120 simplLazyBind: [binder already simplified, RHS not]
121 Used for: recursive bindings (top level and nested)
122 top-level non-recursive bindings
123 non-top-level, but *lazy* non-recursive bindings
124 [must not be strict or unboxed]
125 Returns floats + an augmented environment, not an expression
126 - substituteIdInfo and add result to in-scope
127 [so that rules are available in rec rhs]
130 - float if exposes constructor or PAP
134 completeNonRecX: [binder and rhs both simplified]
135 - if the the thing needs case binding (unlifted and not ok-for-spec)
141 completeBind: [given a simplified RHS]
142 [used for both rec and non-rec bindings, top level and not]
143 - try PostInlineUnconditionally
144 - add unfolding [this is the only place we add an unfolding]
149 Right hand sides and arguments
150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
151 In many ways we want to treat
152 (a) the right hand side of a let(rec), and
153 (b) a function argument
154 in the same way. But not always! In particular, we would
155 like to leave these arguments exactly as they are, so they
156 will match a RULE more easily.
161 It's harder to make the rule match if we ANF-ise the constructor,
162 or eta-expand the PAP:
164 f (let { a = g x; b = h x } in (a,b))
167 On the other hand if we see the let-defns
172 then we *do* want to ANF-ise and eta-expand, so that p and q
173 can be safely inlined.
175 Even floating lets out is a bit dubious. For let RHS's we float lets
176 out if that exposes a value, so that the value can be inlined more vigorously.
179 r = let x = e in (x,x)
181 Here, if we float the let out we'll expose a nice constructor. We did experiments
182 that showed this to be a generally good thing. But it was a bad thing to float
183 lets out unconditionally, because that meant they got allocated more often.
185 For function arguments, there's less reason to expose a constructor (it won't
186 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
187 So for the moment we don't float lets out of function arguments either.
192 For eta expansion, we want to catch things like
194 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
196 If the \x was on the RHS of a let, we'd eta expand to bring the two
197 lambdas together. And in general that's a good thing to do. Perhaps
198 we should eta expand wherever we find a (value) lambda? Then the eta
199 expansion at a let RHS can concentrate solely on the PAP case.
202 %************************************************************************
204 \subsection{Bindings}
206 %************************************************************************
209 simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
211 simplTopBinds env0 binds0
212 = do { -- Put all the top-level binders into scope at the start
213 -- so that if a transformation rule has unexpectedly brought
214 -- anything into scope, then we don't get a complaint about that.
215 -- It's rather as if the top-level binders were imported.
216 ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
217 ; dflags <- getDOptsSmpl
218 ; let dump_flag = dopt Opt_D_verbose_core2core dflags
219 ; env2 <- simpl_binds dump_flag env1 binds0
220 ; freeTick SimplifierDone
223 -- We need to track the zapped top-level binders, because
224 -- they should have their fragile IdInfo zapped (notably occurrence info)
225 -- That's why we run down binds and bndrs' simultaneously.
227 -- The dump-flag emits a trace for each top-level binding, which
228 -- helps to locate the tracing for inlining and rule firing
229 simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
230 simpl_binds _ env [] = return env
231 simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
233 ; simpl_binds dump env' binds }
235 trace_bind True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
236 trace_bind False _ = \x -> x
238 simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
239 simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
241 (env', b') = addBndrRules env b (lookupRecBndr env b)
245 %************************************************************************
247 \subsection{Lazy bindings}
249 %************************************************************************
251 simplRecBind is used for
252 * recursive bindings only
255 simplRecBind :: SimplEnv -> TopLevelFlag
258 simplRecBind env0 top_lvl pairs0
259 = do { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
260 ; env1 <- go (zapFloats env_with_info) triples
261 ; return (env0 `addRecFloats` env1) }
262 -- addFloats adds the floats from env1,
263 -- _and_ updates env0 with the in-scope set from env1
265 add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
266 -- Add the (substituted) rules to the binder
267 add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
269 (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
271 go env [] = return env
273 go env ((old_bndr, new_bndr, rhs) : pairs)
274 = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
278 simplOrTopPair is used for
279 * recursive bindings (whether top level or not)
280 * top-level non-recursive bindings
282 It assumes the binder has already been simplified, but not its IdInfo.
285 simplRecOrTopPair :: SimplEnv
287 -> InId -> OutBndr -> InExpr -- Binder and rhs
288 -> SimplM SimplEnv -- Returns an env that includes the binding
290 simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
291 | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline
292 = do { tick (PreInlineUnconditionally old_bndr)
293 ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
296 = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
297 -- May not actually be recursive, but it doesn't matter
301 simplLazyBind is used for
302 * [simplRecOrTopPair] recursive bindings (whether top level or not)
303 * [simplRecOrTopPair] top-level non-recursive bindings
304 * [simplNonRecE] non-top-level *lazy* non-recursive bindings
307 1. It assumes that the binder is *already* simplified,
308 and is in scope, and its IdInfo too, except unfolding
310 2. It assumes that the binder type is lifted.
312 3. It does not check for pre-inline-unconditionallly;
313 that should have been done already.
316 simplLazyBind :: SimplEnv
317 -> TopLevelFlag -> RecFlag
318 -> InId -> OutId -- Binder, both pre-and post simpl
319 -- The OutId has IdInfo, except arity, unfolding
320 -> InExpr -> SimplEnv -- The RHS and its environment
323 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
324 = do { let rhs_env = rhs_se `setInScope` env
325 (tvs, body) = case collectTyBinders rhs of
326 (tvs, body) | not_lam body -> (tvs,body)
327 | otherwise -> ([], rhs)
328 not_lam (Lam _ _) = False
330 -- Do not do the "abstract tyyvar" thing if there's
331 -- a lambda inside, becuase it defeats eta-reduction
332 -- f = /\a. \x. g a x
335 ; (body_env, tvs') <- simplBinders rhs_env tvs
336 -- See Note [Floating and type abstraction] in SimplUtils
339 ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
340 -- ANF-ise a constructor or PAP rhs
341 ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
344 <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
345 then -- No floating, revert to body1
346 do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1)
347 ; return (env, rhs') }
349 else if null tvs then -- Simple floating
350 do { tick LetFloatFromLet
351 ; return (addFloats env body_env2, body2) }
353 else -- Do type-abstraction first
354 do { tick LetFloatFromLet
355 ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
356 ; rhs' <- mkLam env tvs' body3
357 ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
358 ; return (env', rhs') }
360 ; completeBind env' top_lvl bndr bndr1 rhs' }
363 A specialised variant of simplNonRec used when the RHS is already simplified,
364 notably in knownCon. It uses case-binding where necessary.
367 simplNonRecX :: SimplEnv
368 -> InId -- Old binder
369 -> OutExpr -- Simplified RHS
372 simplNonRecX env bndr new_rhs
373 | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p }
374 = return env -- Here b is dead, and we avoid creating
375 | otherwise -- the binding b = (a,b)
376 = do { (env', bndr') <- simplBinder env bndr
377 ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
378 -- simplNonRecX is only used for NotTopLevel things
380 completeNonRecX :: TopLevelFlag -> SimplEnv
382 -> InId -- Old binder
383 -> OutId -- New binder
384 -> OutExpr -- Simplified RHS
387 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
388 = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
390 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
391 then do { tick LetFloatFromLet
392 ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
393 else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
394 ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
397 {- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
398 Doing so risks exponential behaviour, because new_rhs has been simplified once already
399 In the cases described by the folowing commment, postInlineUnconditionally will
400 catch many of the relevant cases.
401 -- This happens; for example, the case_bndr during case of
402 -- known constructor: case (a,b) of x { (p,q) -> ... }
403 -- Here x isn't mentioned in the RHS, so we don't want to
404 -- create the (dead) let-binding let x = (a,b) in ...
406 -- Similarly, single occurrences can be inlined vigourously
407 -- e.g. case (f x, g y) of (a,b) -> ....
408 -- If a,b occur once we can avoid constructing the let binding for them.
410 Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
411 -- Consider case I# (quotInt# x y) of
412 -- I# v -> let w = J# v in ...
413 -- If we gaily inline (quotInt# x y) for v, we end up building an
415 -- let w = J# (quotInt# x y) in ...
416 -- because quotInt# can fail.
418 | preInlineUnconditionally env NotTopLevel bndr new_rhs
419 = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
422 ----------------------------------
423 prepareRhs takes a putative RHS, checks whether it's a PAP or
424 constructor application and, if so, converts it to ANF, so that the
425 resulting thing can be inlined more easily. Thus
432 We also want to deal well cases like this
433 v = (f e1 `cast` co) e2
434 Here we want to make e1,e2 trivial and get
435 x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
436 That's what the 'go' loop in prepareRhs does
439 prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
440 -- Adds new floats to the env iff that allows us to return a good RHS
441 prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions]
442 | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
443 , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
444 = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
445 ; return (env', Cast rhs' co) }
447 sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
448 `setDemandInfo` demandInfo info
451 prepareRhs top_lvl env0 _ rhs0
452 = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
453 ; return (env1, rhs1) }
455 go n_val_args env (Cast rhs co)
456 = do { (is_exp, env', rhs') <- go n_val_args env rhs
457 ; return (is_exp, env', Cast rhs' co) }
458 go n_val_args env (App fun (Type ty))
459 = do { (is_exp, env', rhs') <- go n_val_args env fun
460 ; return (is_exp, env', App rhs' (Type ty)) }
461 go n_val_args env (App fun arg)
462 = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
464 True -> do { (env'', arg') <- makeTrivial top_lvl env' arg
465 ; return (True, env'', App fun' arg') }
466 False -> return (False, env, App fun arg) }
467 go n_val_args env (Var fun)
468 = return (is_exp, env, Var fun)
470 is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP
471 -- See Note [CONLIKE pragma] in BasicTypes
472 -- The definition of is_exp should match that in
473 -- OccurAnal.occAnalApp
476 = return (False, env, other)
480 Note [Float coercions]
481 ~~~~~~~~~~~~~~~~~~~~~~
482 When we find the binding
484 we'd like to transform it to
486 x = x `cast` co -- A trivial binding
487 There's a chance that e will be a constructor application or function, or something
488 like that, so moving the coerion to the usage site may well cancel the coersions
489 and lead to further optimisation. Example:
492 data instance T Int = T Int
494 foo :: Int -> Int -> Int
499 go n = case x of { T m -> go (n-m) }
500 -- This case should optimise
502 Note [Preserve strictness when floating coercions]
503 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
504 In the Note [Float coercions] transformation, keep the strictness info.
506 f = e `cast` co -- f has strictness SSL
508 f' = e -- f' also has strictness SSL
509 f = f' `cast` co -- f still has strictness SSL
511 Its not wrong to drop it on the floor, but better to keep it.
513 Note [Float coercions (unlifted)]
514 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
515 BUT don't do [Float coercions] if 'e' has an unlifted type.
518 foo :: Int = (error (# Int,Int #) "urk")
519 `cast` CoUnsafe (# Int,Int #) Int
521 If do the makeTrivial thing to the error call, we'll get
522 foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
523 But 'v' isn't in scope!
525 These strange casts can happen as a result of case-of-case
526 bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
531 makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
532 -- Binds the expression to a variable, if it's not trivial, returning the variable
533 makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr
535 makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo
536 -> OutExpr -> SimplM (SimplEnv, OutExpr)
537 -- Propagate strictness and demand info to the new binder
538 -- Note [Preserve strictness when floating coercions]
539 -- Returned SimplEnv has same substitution as incoming one
540 makeTrivialWithInfo top_lvl env info expr
541 | exprIsTrivial expr -- Already trivial
542 || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise
543 -- See Note [Cannot trivialise]
545 | otherwise -- See Note [Take care] below
546 = do { uniq <- getUniqueM
547 ; let name = mkSystemVarName uniq (fsLit "a")
548 var = mkLocalIdWithInfo name expr_ty info
549 ; env' <- completeNonRecX top_lvl env False var var expr
550 ; expr' <- simplVar env' var
551 ; return (env', expr') }
552 -- The simplVar is needed becase we're constructing a new binding
554 -- And if rhs is of form (rhs1 |> co), then we might get
557 -- and now a's RHS is trivial and can be substituted out, and that
558 -- is what completeNonRecX will do
559 -- To put it another way, it's as if we'd simplified
560 -- let var = e in var
562 expr_ty = exprType expr
564 bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
565 -- True iff we can have a binding of this expression at this leve
566 -- Precondition: the type is the type of the expression
567 bindingOk top_lvl _ expr_ty
568 | isTopLevel top_lvl = not (isUnLiftedType expr_ty)
572 Note [Cannot trivialise]
573 ~~~~~~~~~~~~~~~~~~~~~~~~
580 Then we can't ANF-ise foo, even though we'd like to, because
581 we can't make a top-level binding for the Addr# (f 3). And if
582 so we don't want to turn it into
583 foo = let x = f 3 in Bar x
584 because we'll just end up inlining x back, and that makes the
585 simplifier loop. Better not to ANF-ise it at all.
587 A case in point is literal strings (a MachStr is not regarded as
592 We don't want to ANF-ise this.
594 %************************************************************************
596 \subsection{Completing a lazy binding}
598 %************************************************************************
601 * deals only with Ids, not TyVars
602 * takes an already-simplified binder and RHS
603 * is used for both recursive and non-recursive bindings
604 * is used for both top-level and non-top-level bindings
606 It does the following:
607 - tries discarding a dead binding
608 - tries PostInlineUnconditionally
609 - add unfolding [this is the only place we add an unfolding]
612 It does *not* attempt to do let-to-case. Why? Because it is used for
613 - top-level bindings (when let-to-case is impossible)
614 - many situations where the "rhs" is known to be a WHNF
615 (so let-to-case is inappropriate).
617 Nor does it do the atomic-argument thing
620 completeBind :: SimplEnv
621 -> TopLevelFlag -- Flag stuck into unfolding
622 -> InId -- Old binder
623 -> OutId -> OutExpr -- New binder and RHS
625 -- completeBind may choose to do its work
626 -- * by extending the substitution (e.g. let x = y in ...)
627 -- * or by adding to the floats in the envt
629 completeBind env top_lvl old_bndr new_bndr new_rhs
630 = do { let old_info = idInfo old_bndr
631 old_unf = unfoldingInfo old_info
632 occ_info = occInfo old_info
634 ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf
636 ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
637 -- Inline and discard the binding
638 then do { tick (PostInlineUnconditionally old_bndr)
639 ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $
640 return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
641 -- Use the substitution to make quite, quite sure that the
642 -- substitution will happen, since we are going to discard the binding
644 else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
646 ------------------------------
647 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
648 -- Add a new binding to the environment, complete with its unfolding
649 -- but *do not* do postInlineUnconditionally, because we have already
650 -- processed some of the scope of the binding
651 -- We still want the unfolding though. Consider
653 -- x = /\a. let y = ... in Just y
655 -- Then we float the y-binding out (via abstractFloats and addPolyBind)
656 -- but 'x' may well then be inlined in 'body' in which case we'd like the
657 -- opportunity to inline 'y' too.
659 addPolyBind top_lvl env (NonRec poly_id rhs)
660 = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
661 -- Assumes that poly_id did not have an INLINE prag
662 -- which is perhaps wrong. ToDo: think about this
663 ; return (addNonRecWithUnf env poly_id rhs unfolding) }
665 addPolyBind _ env bind@(Rec _) = return (extendFloats env bind)
666 -- Hack: letrecs are more awkward, so we extend "by steam"
667 -- without adding unfoldings etc. At worst this leads to
668 -- more simplifier iterations
670 ------------------------------
671 addNonRecWithUnf :: SimplEnv
672 -> OutId -> OutExpr -- New binder and RHS
673 -> Unfolding -- New unfolding
675 addNonRecWithUnf env new_bndr new_rhs new_unfolding
676 = let new_arity = exprArity new_rhs
677 old_arity = idArity new_bndr
678 info1 = idInfo new_bndr `setArityInfo` new_arity
680 -- Unfolding info: Note [Setting the new unfolding]
681 info2 = info1 `setUnfoldingInfo` new_unfolding
683 -- Demand info: Note [Setting the demand info]
684 info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
687 final_id = new_bndr `setIdInfo` info3
688 dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr
690 ASSERT( isId new_bndr )
691 WARN( new_arity < old_arity || new_arity < dmd_arity,
692 (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity
693 <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) )
694 -- Note [Arity decrease]
696 final_id `seq` -- This seq forces the Id, and hence its IdInfo,
697 -- and hence any inner substitutions
698 -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
699 addNonRec env final_id new_rhs
700 -- The addNonRec adds it to the in-scope set too
702 ------------------------------
703 simplUnfolding :: SimplEnv-> TopLevelFlag
705 -> OccInfo -> OutExpr
706 -> Unfolding -> SimplM Unfolding
707 -- Note [Setting the new unfolding]
708 simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
709 = return (DFunUnfolding con ops')
711 ops' = map (substExpr (text "simplUnfolding") env) ops
713 simplUnfolding env top_lvl id _ _
714 (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
715 , uf_src = src, uf_guidance = guide })
716 | isInlineRuleSource src
717 = do { expr' <- simplExpr rule_env expr
718 ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
719 ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
720 -- See Note [Top-level flag on inline rules] in CoreUnfold
722 act = idInlineActivation id
723 rule_env = updMode (updModeForInlineRules act) env
724 -- See Note [Simplifying gently inside InlineRules] in SimplUtils
726 simplUnfolding _ top_lvl id _occ_info new_rhs _
727 = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
728 -- We make an unfolding *even for loop-breakers*.
729 -- Reason: (a) It might be useful to know that they are WHNF
730 -- (b) In TidyPgm we currently assume that, if we want to
731 -- expose the unfolding then indeed we *have* an unfolding
732 -- to expose. (We could instead use the RHS, but currently
733 -- we don't.) The simple thing is always to have one.
736 Note [Arity decrease]
737 ~~~~~~~~~~~~~~~~~~~~~
738 Generally speaking the arity of a binding should not decrease. But it *can*
739 legitimately happen becuase of RULES. Eg
741 where g has arity 2, will have arity 2. But if there's a rewrite rule
743 where h has arity 1, then f's arity will decrease. Here's a real-life example,
744 which is in the output of Specialise:
747 $dm {Arity 2} = \d.\x. op d
748 {-# RULES forall d. $dm Int d = $s$dm #-}
750 dInt = MkD .... opInt ...
751 opInt {Arity 1} = $dm dInt
753 $s$dm {Arity 0} = \x. op dInt }
755 Here opInt has arity 1; but when we apply the rule its arity drops to 0.
756 That's why Specialise goes to a little trouble to pin the right arity
757 on specialised functions too.
759 Note [Setting the new unfolding]
760 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
761 * If there's an INLINE pragma, we simplify the RHS gently. Maybe we
762 should do nothing at all, but simplifying gently might get rid of
765 * If not, we make an unfolding from the new RHS. But *only* for
766 non-loop-breakers. Making loop breakers not have an unfolding at all
767 means that we can avoid tests in exprIsConApp, for example. This is
768 important: if exprIsConApp says 'yes' for a recursive thing, then we
769 can get into an infinite loop
771 If there's an InlineRule on a loop breaker, we hang on to the inlining.
772 It's pretty dodgy, but the user did say 'INLINE'. May need to revisit
775 Note [Setting the demand info]
776 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
777 If the unfolding is a value, the demand info may
778 go pear-shaped, so we nuke it. Example:
780 case x of (p,q) -> h p q x
781 Here x is certainly demanded. But after we've nuked
782 the case, we'll get just
783 let x = (a,b) in h a b x
784 and now x is not demanded (I'm assuming h is lazy)
785 This really happens. Similarly
786 let f = \x -> e in ...f..f...
787 After inlining f at some of its call sites the original binding may
788 (for example) be no longer strictly demanded.
789 The solution here is a bit ad hoc...
792 %************************************************************************
794 \subsection[Simplify-simplExpr]{The main function: simplExpr}
796 %************************************************************************
798 The reason for this OutExprStuff stuff is that we want to float *after*
799 simplifying a RHS, not before. If we do so naively we get quadratic
800 behaviour as things float out.
802 To see why it's important to do it after, consider this (real) example:
816 a -- Can't inline a this round, cos it appears twice
820 Each of the ==> steps is a round of simplification. We'd save a
821 whole round if we float first. This can cascade. Consider
826 let f = let d1 = ..d.. in \y -> e
830 in \x -> ...(\y ->e)...
832 Only in this second round can the \y be applied, and it
833 might do the same again.
837 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
838 simplExpr env expr = simplExprC env expr mkBoringStop
840 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
841 -- Simplify an expression, given a continuation
842 simplExprC env expr cont
843 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
844 do { (env', expr') <- simplExprF (zapFloats env) expr cont
845 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
846 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
847 -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
848 return (wrapFloats env' expr') }
850 --------------------------------------------------
851 simplExprF :: SimplEnv -> InExpr -> SimplCont
852 -> SimplM (SimplEnv, OutExpr)
854 simplExprF env e cont
855 = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
856 simplExprF' env e cont
858 simplExprF' :: SimplEnv -> InExpr -> SimplCont
859 -> SimplM (SimplEnv, OutExpr)
860 simplExprF' env (Var v) cont = simplVarF env v cont
861 simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
862 simplExprF' env (Note n expr) cont = simplNote env n expr cont
863 simplExprF' env (Cast body co) cont = simplCast env body co cont
864 simplExprF' env (App fun arg) cont = simplExprF env fun $
865 ApplyTo NoDup arg env cont
867 simplExprF' env expr@(Lam _ _) cont
868 = simplLam env (map zap bndrs) body cont
869 -- The main issue here is under-saturated lambdas
870 -- (\x1. \x2. e) arg1
871 -- Here x1 might have "occurs-once" occ-info, because occ-info
872 -- is computed assuming that a group of lambdas is applied
873 -- all at once. If there are too few args, we must zap the
876 n_args = countArgs cont
877 n_params = length bndrs
878 (bndrs, body) = collectBinders expr
879 zap | n_args >= n_params = \b -> b
880 | otherwise = \b -> if isTyVar b then b
882 -- NB: we count all the args incl type args
883 -- so we must count all the binders (incl type lambdas)
885 simplExprF' env (Type ty) cont
886 = ASSERT( contIsRhsOrArg cont )
887 do { ty' <- simplCoercion env ty
888 ; rebuild env (Type ty') cont }
890 simplExprF' env (Case scrut bndr _ alts) cont
891 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
892 = -- Simplify the scrutinee with a Select continuation
893 simplExprF env scrut (Select NoDup bndr alts env cont)
896 = -- If case-of-case is off, simply simplify the case expression
897 -- in a vanilla Stop context, and rebuild the result around it
898 do { case_expr' <- simplExprC env scrut case_cont
899 ; rebuild env case_expr' cont }
901 case_cont = Select NoDup bndr alts env mkBoringStop
903 simplExprF' env (Let (Rec pairs) body) cont
904 = do { env' <- simplRecBndrs env (map fst pairs)
905 -- NB: bndrs' don't have unfoldings or rules
906 -- We add them as we go down
908 ; env'' <- simplRecBind env' NotTopLevel pairs
909 ; simplExprF env'' body cont }
911 simplExprF' env (Let (NonRec bndr rhs) body) cont
912 = simplNonRecE env bndr (rhs, env) ([], body) cont
914 ---------------------------------
915 simplType :: SimplEnv -> InType -> SimplM OutType
916 -- Kept monadic just so we can do the seqType
918 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
919 seqType new_ty `seq` return new_ty
921 new_ty = substTy env ty
923 ---------------------------------
924 simplCoercion :: SimplEnv -> InType -> SimplM OutType
925 -- The InType isn't *necessarily* a coercion, but it might be
926 -- (in a type application, say) and optCoercion is a no-op on types
928 = seqType new_co `seq` return new_co
930 new_co = optCoercion (getTvSubst env) co
934 %************************************************************************
936 \subsection{The main rebuilder}
938 %************************************************************************
941 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
942 -- At this point the substitution in the SimplEnv should be irrelevant
943 -- only the in-scope set and floats should matter
944 rebuild env expr cont0
945 = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
947 Stop {} -> return (env, expr)
948 CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
949 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
950 StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont
951 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
952 ; simplLam env' bs body cont }
953 ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
954 ; rebuild env (App expr arg') cont }
958 %************************************************************************
962 %************************************************************************
965 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
966 -> SimplM (SimplEnv, OutExpr)
967 simplCast env body co0 cont0
968 = do { co1 <- simplCoercion env co0
969 ; simplExprF env body (addCoerce co1 cont0) }
971 addCoerce co cont = add_coerce co (coercionKind co) cont
973 add_coerce _co (s1, k1) cont -- co :: ty~ty
974 | s1 `coreEqType` k1 = cont -- is a no-op
976 add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
977 | (_l1, t1) <- coercionKind co2
978 -- e |> (g1 :: S1~L) |> (g2 :: L~T1)
981 -- e |> (g1 . g2 :: S1~T1) otherwise
983 -- For example, in the initial form of a worker
984 -- we may find (coerce T (coerce S (\x.e))) y
985 -- and we'd like it to simplify to e[y/x] in one round
987 , s1 `coreEqType` t1 = cont -- The coerces cancel out
988 | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
990 add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
991 -- (f |> g) ty ---> (f ty) |> (g @ ty)
992 -- This implements the PushT and PushC rules from the paper
993 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
995 (new_arg_ty, new_cast)
996 | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule
997 | otherwise = (ty', mkInstCoercion co ty') -- PushT rule
999 ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont)
1001 ty' = substTy (arg_se `setInScope` env) arg_ty
1002 new_arg_co = mkCsel1Coercion co `mkTransCoercion`
1003 ty' `mkTransCoercion`
1004 mkSymCoercion (mkCsel2Coercion co)
1006 add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
1007 | not (isTypeArg arg) -- This implements the Push rule from the paper
1008 , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
1009 -- (e |> (g :: s1s2 ~ t1->t2)) f
1011 -- (e (f |> (arg g :: t1~s1))
1012 -- |> (res g :: s2->t2)
1014 -- t1t2 must be a function type, t1->t2, because it's applied
1015 -- to something but s1s2 might conceivably not be
1017 -- When we build the ApplyTo we can't mix the out-types
1018 -- with the InExpr in the argument, so we simply substitute
1019 -- to make it all consistent. It's a bit messy.
1020 -- But it isn't a common case.
1022 -- Example of use: Trac #995
1023 = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont)
1025 -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
1026 -- t2 ~ s2 with left and right on the curried form:
1027 -- (->) t1 t2 ~ (->) s1 s2
1028 [co1, co2] = decomposeCo 2 co
1029 new_arg = mkCoerce (mkSymCoercion co1) arg'
1030 arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg
1032 add_coerce co _ cont = CoerceIt co cont
1036 %************************************************************************
1038 \subsection{Lambdas}
1040 %************************************************************************
1043 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
1044 -> SimplM (SimplEnv, OutExpr)
1046 simplLam env [] body cont = simplExprF env body cont
1049 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
1050 = do { tick (BetaReduction bndr)
1051 ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
1053 -- Not enough args, so there are real lambdas left to put in the result
1054 simplLam env bndrs body cont
1055 = do { (env', bndrs') <- simplLamBndrs env bndrs
1056 ; body' <- simplExpr env' body
1057 ; new_lam <- mkLam env' bndrs' body'
1058 ; rebuild env' new_lam cont }
1061 simplNonRecE :: SimplEnv
1062 -> InBndr -- The binder
1063 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
1064 -> ([InBndr], InExpr) -- Body of the let/lambda
1067 -> SimplM (SimplEnv, OutExpr)
1069 -- simplNonRecE is used for
1070 -- * non-top-level non-recursive lets in expressions
1073 -- It deals with strict bindings, via the StrictBind continuation,
1074 -- which may abort the whole process
1076 -- The "body" of the binding comes as a pair of ([InId],InExpr)
1077 -- representing a lambda; so we recurse back to simplLam
1078 -- Why? Because of the binder-occ-info-zapping done before
1079 -- the call to simplLam in simplExprF (Lam ...)
1081 -- First deal with type applications and type lets
1082 -- (/\a. e) (Type ty) and (let a = Type ty in e)
1083 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
1084 = ASSERT( isTyVar bndr )
1085 do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
1086 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
1088 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
1089 | preInlineUnconditionally env NotTopLevel bndr rhs
1090 = do { tick (PreInlineUnconditionally bndr)
1091 ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
1094 = do { simplExprF (rhs_se `setFloats` env) rhs
1095 (StrictBind bndr bndrs body env cont) }
1098 = ASSERT( not (isTyVar bndr) )
1099 do { (env1, bndr1) <- simplNonRecBndr env bndr
1100 ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
1101 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
1102 ; simplLam env3 bndrs body cont }
1106 %************************************************************************
1110 %************************************************************************
1113 -- Hack alert: we only distinguish subsumed cost centre stacks for the
1114 -- purposes of inlining. All other CCCSs are mapped to currentCCS.
1115 simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
1116 -> SimplM (SimplEnv, OutExpr)
1117 simplNote env (SCC cc) e cont
1118 | pushCCisNop cc (getEnclosingCC env) -- scc "f" (...(scc "f" e)...)
1119 = simplExprF env e cont -- ==> scc "f" (...e...)
1121 = do { e' <- simplExpr (setEnclosingCC env currentCCS) e
1122 ; rebuild env (mkSCC cc e') cont }
1124 simplNote env (CoreNote s) e cont
1125 = do { e' <- simplExpr env e
1126 ; rebuild env (Note (CoreNote s) e') cont }
1130 %************************************************************************
1134 %************************************************************************
1137 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
1138 -- Look up an InVar in the environment
1141 = return (Type (substTyVar env var))
1143 = case substId env var of
1144 DoneId var1 -> return (Var var1)
1145 DoneEx e -> return e
1146 ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e
1148 simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
1149 simplVarF env var cont
1150 = case substId env var of
1151 DoneEx e -> simplExprF (zapSubstEnv env) e cont
1152 ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
1153 DoneId var1 -> completeCall env var1 cont
1154 -- Note [zapSubstEnv]
1155 -- The template is already simplified, so don't re-substitute.
1156 -- This is VITAL. Consider
1158 -- let y = \z -> ...x... in
1160 -- We'll clone the inner \x, adding x->x' in the id_subst
1161 -- Then when we inline y, we must *not* replace x by x' in
1162 -- the inlined copy!!
1164 ---------------------------------------------------------
1165 -- Dealing with a call site
1167 completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1168 completeCall env var cont
1169 = do { ------------- Try inlining ----------------
1170 dflags <- getDOptsSmpl
1171 ; let (lone_variable, arg_infos, call_cont) = contArgs cont
1172 -- The args are OutExprs, obtained by *lazily* substituting
1173 -- in the args found in cont. These args are only examined
1174 -- to limited depth (unless a rule fires). But we must do
1175 -- the substitution; rule matching on un-simplified args would
1178 n_val_args = length arg_infos
1179 interesting_cont = interestingCallContext call_cont
1180 unfolding = activeUnfolding env var
1181 maybe_inline = callSiteInline dflags var unfolding
1182 lone_variable arg_infos interesting_cont
1183 ; case maybe_inline of {
1184 Just expr -- There is an inlining!
1185 -> do { tick (UnfoldingDone var)
1186 ; trace_inline dflags expr cont $
1187 simplExprF (zapSubstEnv env) expr cont }
1189 ; Nothing -> do -- No inlining!
1191 { rule_base <- getSimplRules
1192 ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
1193 ; rebuildCall env info cont
1196 trace_inline dflags unfolding cont stuff
1197 | not (dopt Opt_D_dump_inlinings dflags) = stuff
1198 | not (dopt Opt_D_verbose_core2core dflags)
1199 = if isExternalName (idName var) then
1200 pprTrace "Inlining done:" (ppr var) stuff
1203 = pprTrace ("Inlining done: " ++ showSDoc (ppr var))
1204 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
1205 text "Cont: " <+> ppr cont])
1208 rebuildCall :: SimplEnv
1211 -> SimplM (SimplEnv, OutExpr)
1212 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
1213 -- When we run out of strictness args, it means
1214 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1215 -- Then we want to discard the entire strict continuation. E.g.
1216 -- * case (error "hello") of { ... }
1217 -- * (error "Hello") arg
1218 -- * f (error "Hello") where f is strict
1220 -- Then, especially in the first of these cases, we'd like to discard
1221 -- the continuation, leaving just the bottoming expression. But the
1222 -- type might not be right, so we may have to add a coerce.
1223 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1224 = return (env, mk_coerce res) -- contination to discard, else we do it
1225 where -- again and again!
1226 res = mkApps (Var fun) (reverse rev_args)
1227 res_ty = exprType res
1228 cont_ty = contResultType env res_ty cont
1229 co = mkUnsafeCoercion res_ty cont_ty
1230 mk_coerce expr | cont_ty `coreEqType` res_ty = expr
1231 | otherwise = mkCoerce co expr
1233 rebuildCall env info (ApplyTo _ (Type arg_ty) se cont)
1234 = do { ty' <- simplCoercion (se `setInScope` env) arg_ty
1235 ; rebuildCall env (info `addArgTo` Type ty') cont }
1237 rebuildCall env info@(ArgInfo { ai_encl = encl_rules
1238 , ai_strs = str:strs, ai_discs = disc:discs })
1239 (ApplyTo _ arg arg_se cont)
1240 | str -- Strict argument
1241 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1242 simplExprF (arg_se `setFloats` env) arg
1243 (StrictArg info' cci cont)
1246 | otherwise -- Lazy argument
1247 -- DO NOT float anything outside, hence simplExprC
1248 -- There is no benefit (unlike in a let-binding), and we'd
1249 -- have to be very careful about bogus strictness through
1250 -- floating a demanded let.
1251 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1253 ; rebuildCall env (addArgTo info' arg') cont }
1255 info' = info { ai_strs = strs, ai_discs = discs }
1256 cci | encl_rules || disc > 0 = ArgCtxt encl_rules -- Be keener here
1257 | otherwise = BoringCtxt -- Nothing interesting
1259 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
1260 = do { -- We've accumulated a simplified call in <fun,rev_args>
1261 -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
1262 -- See also Note [Rules for recursive functions]
1263 ; let args = reverse rev_args
1264 env' = zapSubstEnv env
1265 ; mb_rule <- tryRules env rules fun args cont
1267 Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $
1268 pushArgs env' (drop n_args args) cont ;
1269 -- n_args says how many args the rule consumed
1270 ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules
1274 Note [RULES apply to simplified arguments]
1275 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1276 It's very desirable to try RULES once the arguments have been simplified, because
1277 doing so ensures that rule cascades work in one pass. Consider
1278 {-# RULES g (h x) = k x
1281 Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
1282 we match f's rules against the un-simplified RHS, it won't match. This
1283 makes a particularly big difference when superclass selectors are involved:
1284 op ($p1 ($p2 (df d)))
1285 We want all this to unravel in one sweeep.
1289 This part of the simplifier may break the no-shadowing invariant
1291 f (...(\a -> e)...) (case y of (a,b) -> e')
1292 where f is strict in its second arg
1293 If we simplify the innermost one first we get (...(\a -> e)...)
1294 Simplifying the second arg makes us float the case out, so we end up with
1295 case y of (a,b) -> f (...(\a -> e)...) e'
1296 So the output does not have the no-shadowing invariant. However, there is
1297 no danger of getting name-capture, because when the first arg was simplified
1298 we used an in-scope set that at least mentioned all the variables free in its
1299 static environment, and that is enough.
1301 We can't just do innermost first, or we'd end up with a dual problem:
1302 case x of (a,b) -> f e (...(\a -> e')...)
1304 I spent hours trying to recover the no-shadowing invariant, but I just could
1305 not think of an elegant way to do it. The simplifier is already knee-deep in
1306 continuations. We have to keep the right in-scope set around; AND we have
1307 to get the effect that finding (error "foo") in a strict arg position will
1308 discard the entire application and replace it with (error "foo"). Getting
1309 all this at once is TOO HARD!
1312 %************************************************************************
1316 %************************************************************************
1319 tryRules :: SimplEnv -> [CoreRule]
1320 -> Id -> [OutExpr] -> SimplCont
1321 -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of
1322 -- args consumed by the rule
1323 tryRules env rules fn args call_cont
1327 = do { dflags <- getDOptsSmpl
1328 ; case activeRule dflags env of {
1329 Nothing -> return Nothing ; -- No rules apply
1331 case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of {
1332 Nothing -> return Nothing ; -- No rule matches
1333 Just (rule, rule_rhs) ->
1335 do { tick (RuleFired (ru_name rule))
1336 ; trace_dump dflags rule rule_rhs $
1337 return (Just (ruleArity rule, rule_rhs)) }}}}
1339 trace_dump dflags rule rule_rhs stuff
1340 | not (dopt Opt_D_dump_rule_firings dflags) = stuff
1341 | not (dopt Opt_D_verbose_core2core dflags)
1343 = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
1345 = pprTrace "Rule fired"
1346 (vcat [text "Rule:" <+> ftext (ru_name rule),
1347 text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
1348 text "After: " <+> pprCoreExpr rule_rhs,
1349 text "Cont: " <+> ppr call_cont])
1353 Note [Rules for recursive functions]
1354 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1355 You might think that we shouldn't apply rules for a loop breaker:
1356 doing so might give rise to an infinite loop, because a RULE is
1357 rather like an extra equation for the function:
1358 RULE: f (g x) y = x+y
1361 But it's too drastic to disable rules for loop breakers.
1362 Even the foldr/build rule would be disabled, because foldr
1363 is recursive, and hence a loop breaker:
1364 foldr k z (build g) = g k z
1365 So it's up to the programmer: rules can cause divergence
1368 %************************************************************************
1370 Rebuilding a cse expression
1372 %************************************************************************
1374 Note [Case elimination]
1375 ~~~~~~~~~~~~~~~~~~~~~~~
1376 The case-elimination transformation discards redundant case expressions.
1377 Start with a simple situation:
1379 case x# of ===> e[x#/y#]
1382 (when x#, y# are of primitive type, of course). We can't (in general)
1383 do this for algebraic cases, because we might turn bottom into
1386 The code in SimplUtils.prepareAlts has the effect of generalise this
1387 idea to look for a case where we're scrutinising a variable, and we
1388 know that only the default case can match. For example:
1392 DEFAULT -> ...(case x of
1396 Here the inner case is first trimmed to have only one alternative, the
1397 DEFAULT, after which it's an instance of the previous case. This
1398 really only shows up in eliminating error-checking code.
1400 We also make sure that we deal with this very common case:
1405 Here we are using the case as a strict let; if x is used only once
1406 then we want to inline it. We have to be careful that this doesn't
1407 make the program terminate when it would have diverged before, so we
1409 - e is already evaluated (it may so if e is a variable)
1410 - x is used strictly, or
1412 Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
1414 case e of ===> case e of DEFAULT -> r
1418 Now again the case may be elminated by the CaseElim transformation.
1421 Further notes about case elimination
1422 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1423 Consider: test :: Integer -> IO ()
1426 Turns out that this compiles to:
1429 eta1 :: State# RealWorld ->
1430 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1432 (PrelNum.jtos eta ($w[] @ Char))
1434 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1436 Notice the strange '<' which has no effect at all. This is a funny one.
1437 It started like this:
1439 f x y = if x < 0 then jtos x
1440 else if y==0 then "" else jtos x
1442 At a particular call site we have (f v 1). So we inline to get
1444 if v < 0 then jtos x
1445 else if 1==0 then "" else jtos x
1447 Now simplify the 1==0 conditional:
1449 if v<0 then jtos v else jtos v
1451 Now common-up the two branches of the case:
1453 case (v<0) of DEFAULT -> jtos v
1455 Why don't we drop the case? Because it's strict in v. It's technically
1456 wrong to drop even unnecessary evaluations, and in practice they
1457 may be a result of 'seq' so we *definitely* don't want to drop those.
1458 I don't really know how to improve this situation.
1461 ---------------------------------------------------------
1462 -- Eliminate the case if possible
1464 rebuildCase, reallyRebuildCase
1466 -> OutExpr -- Scrutinee
1467 -> InId -- Case binder
1468 -> [InAlt] -- Alternatives (inceasing order)
1470 -> SimplM (SimplEnv, OutExpr)
1472 --------------------------------------------------
1473 -- 1. Eliminate the case if there's a known constructor
1474 --------------------------------------------------
1476 rebuildCase env scrut case_bndr alts cont
1477 | Lit lit <- scrut -- No need for same treatment as constructors
1478 -- because literals are inlined more vigorously
1479 = do { tick (KnownBranch case_bndr)
1480 ; case findAlt (LitAlt lit) alts of
1481 Nothing -> missingAlt env case_bndr alts cont
1482 Just (_, bs, rhs) -> simple_rhs bs rhs }
1484 | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut
1485 -- Works when the scrutinee is a variable with a known unfolding
1486 -- as well as when it's an explicit constructor application
1487 = do { tick (KnownBranch case_bndr)
1488 ; case findAlt (DataAlt con) alts of
1489 Nothing -> missingAlt env case_bndr alts cont
1490 Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
1491 Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args
1492 case_bndr bs rhs cont
1495 simple_rhs bs rhs = ASSERT( null bs )
1496 do { env' <- simplNonRecX env case_bndr scrut
1497 ; simplExprF env' rhs cont }
1500 --------------------------------------------------
1501 -- 2. Eliminate the case if scrutinee is evaluated
1502 --------------------------------------------------
1504 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
1505 -- See if we can get rid of the case altogether
1506 -- See Note [Case eliminiation]
1507 -- mkCase made sure that if all the alternatives are equal,
1508 -- then there is now only one (DEFAULT) rhs
1509 | all isDeadBinder bndrs -- bndrs are [InId]
1511 -- Check that the scrutinee can be let-bound instead of case-bound
1512 , exprOkForSpeculation scrut
1513 -- OK not to evaluate it
1514 -- This includes things like (==# a# b#)::Bool
1515 -- so that we simplify
1516 -- case ==# a# b# of { True -> x; False -> x }
1519 -- This particular example shows up in default methods for
1520 -- comparision operations (e.g. in (>=) for Int.Int32)
1521 || exprIsHNF scrut -- It's already evaluated
1522 || var_demanded_later scrut -- It'll be demanded later
1524 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1525 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1526 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1527 -- its argument: case x of { y -> dataToTag# y }
1528 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1529 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1531 -- Also we don't want to discard 'seq's
1532 = do { tick (CaseElim case_bndr)
1533 ; env' <- simplNonRecX env case_bndr scrut
1534 ; simplExprF env' rhs cont }
1536 -- The case binder is going to be evaluated later,
1537 -- and the scrutinee is a simple variable
1538 var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr)
1539 && not (isTickBoxOp v)
1540 -- ugly hack; covering this case is what
1541 -- exprOkForSpeculation was intended for.
1542 var_demanded_later _ = False
1544 --------------------------------------------------
1545 -- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId
1546 --------------------------------------------------
1548 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
1549 | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq'
1550 = do { let rhs' = substExpr (text "rebuild-case") env rhs
1551 out_args = [Type (substTy env (idType case_bndr)),
1552 Type (exprType rhs'), scrut, rhs']
1553 -- Lazily evaluated, so we don't do most of this
1555 ; rule_base <- getSimplRules
1556 ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont
1558 Just (n_args, res) -> simplExprF (zapSubstEnv env)
1559 (mkApps res (drop n_args out_args))
1561 Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
1563 rebuildCase env scrut case_bndr alts cont
1564 = reallyRebuildCase env scrut case_bndr alts cont
1566 --------------------------------------------------
1567 -- 3. Catch-all case
1568 --------------------------------------------------
1570 reallyRebuildCase env scrut case_bndr alts cont
1571 = do { -- Prepare the continuation;
1572 -- The new subst_env is in place
1573 (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1575 -- Simplify the alternatives
1576 ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1578 -- Check for empty alternatives
1579 ; if null alts' then missingAlt env case_bndr alts cont
1581 { dflags <- getDOptsSmpl
1582 ; case_expr <- mkCase dflags scrut' case_bndr' alts'
1584 -- Notice that rebuild gets the in-scope set from env', not alt_env
1585 -- (which in any case is only build in simplAlts)
1586 -- The case binder *not* scope over the whole returned case-expression
1587 ; rebuild env' case_expr nodup_cont } }
1590 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1591 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1592 way, there's a chance that v will now only be used once, and hence
1595 Historical note: we use to do the "case binder swap" in the Simplifier
1596 so there were additional complications if the scrutinee was a variable.
1597 Now the binder-swap stuff is done in the occurrence analyer; see
1598 OccurAnal Note [Binder swap].
1602 If the case binder is not dead, then neither are the pattern bound
1604 case <any> of x { (a,b) ->
1605 case x of { (p,q) -> p } }
1606 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1607 The point is that we bring into the envt a binding
1609 after the outer case, and that makes (a,b) alive. At least we do unless
1610 the case binder is guaranteed dead.
1612 In practice, the scrutinee is almost always a variable, so we pretty
1613 much always zap the OccInfo of the binders. It doesn't matter much though.
1618 Consider case (v `cast` co) of x { I# y ->
1619 ... (case (v `cast` co) of {...}) ...
1620 We'd like to eliminate the inner case. We can get this neatly by
1621 arranging that inside the outer case we add the unfolding
1622 v |-> x `cast` (sym co)
1623 to v. Then we should inline v at the inner case, cancel the casts, and away we go
1625 Note [Improving seq]
1628 type family F :: * -> *
1629 type instance F Int = Int
1631 ... case e of x { DEFAULT -> rhs } ...
1633 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
1635 case e `cast` co of x'::Int
1636 I# x# -> let x = x' `cast` sym co
1639 so that 'rhs' can take advantage of the form of x'.
1641 Notice that Note [Case of cast] may then apply to the result.
1643 Nota Bene: We only do the [Improving seq] transformation if the
1644 case binder 'x' is actually used in the rhs; that is, if the case
1645 is *not* a *pure* seq.
1646 a) There is no point in adding the cast to a pure seq.
1647 b) There is a good reason not to: doing so would interfere
1648 with seq rules (Note [Built-in RULES for seq] in MkId).
1649 In particular, this [Improving seq] thing *adds* a cast
1650 while [Built-in RULES for seq] *removes* one, so they
1653 You might worry about
1654 case v of x { __DEFAULT ->
1655 ... case (v `cast` co) of y { I# -> ... }}
1656 This is a pure seq (since x is unused), so [Improving seq] won't happen.
1657 But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get
1658 case v of x { __DEFAULT ->
1659 ... case (x `cast` co) of y { I# -> ... }}
1660 Now the outer case is not a pure seq, so [Improving seq] will happen,
1661 and then the inner case will disappear.
1663 The need for [Improving seq] showed up in Roman's experiments. Example:
1664 foo :: F Int -> Int -> Int
1665 foo t n = t `seq` bar n
1668 bar n = bar (n - case t of TI i -> i)
1669 Here we'd like to avoid repeated evaluating t inside the loop, by
1670 taking advantage of the `seq`.
1672 At one point I did transformation in LiberateCase, but it's more
1673 robust here. (Otherwise, there's a danger that we'll simply drop the
1674 'seq' altogether, before LiberateCase gets to see it.)
1677 simplAlts :: SimplEnv
1679 -> InId -- Case binder
1680 -> [InAlt] -- Non-empty
1682 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
1683 -- Like simplExpr, this just returns the simplified alternatives;
1684 -- it does not return an environment
1686 simplAlts env scrut case_bndr alts cont'
1687 = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $
1688 do { let env0 = zapFloats env
1690 ; (env1, case_bndr1) <- simplBinder env0 case_bndr
1692 ; fam_envs <- getFamEnvs
1693 ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut
1694 case_bndr case_bndr1 alts
1696 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
1698 ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
1699 ; return (scrut', case_bndr', alts') }
1702 ------------------------------------
1703 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
1704 -> OutExpr -> InId -> OutId -> [InAlt]
1705 -> SimplM (SimplEnv, OutExpr, OutId)
1706 -- Note [Improving seq]
1707 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1708 | not (isDeadBinder case_bndr) -- Not a pure seq! See the Note!
1709 , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1710 = do { case_bndr2 <- newId (fsLit "nt") ty2
1711 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1712 env2 = extendIdSubst env case_bndr rhs
1713 ; return (env2, scrut `Cast` co, case_bndr2) }
1715 improveSeq _ env scrut _ case_bndr1 _
1716 = return (env, scrut, case_bndr1)
1719 ------------------------------------
1720 simplAlt :: SimplEnv
1721 -> [AltCon] -- These constructors can't be present when
1722 -- matching the DEFAULT alternative
1723 -> OutId -- The case binder
1728 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1729 = ASSERT( null bndrs )
1730 do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1731 -- Record the constructors that the case-binder *can't* be.
1732 ; rhs' <- simplExprC env' rhs cont'
1733 ; return (DEFAULT, [], rhs') }
1735 simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
1736 = ASSERT( null bndrs )
1737 do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1738 ; rhs' <- simplExprC env' rhs cont'
1739 ; return (LitAlt lit, [], rhs') }
1741 simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
1742 = do { -- Deal with the pattern-bound variables
1743 -- Mark the ones that are in ! positions in the
1744 -- data constructor as certainly-evaluated.
1745 -- NB: simplLamBinders preserves this eval info
1746 let vs_with_evals = add_evals (dataConRepStrictness con)
1747 ; (env', vs') <- simplLamBndrs env vs_with_evals
1749 -- Bind the case-binder to (con args)
1750 ; let inst_tys' = tyConAppArgs (idType case_bndr')
1751 con_args = map Type inst_tys' ++ varsToCoreExprs vs'
1752 env'' = addBinderUnfolding env' case_bndr'
1753 (mkConApp con con_args)
1755 ; rhs' <- simplExprC env'' rhs cont'
1756 ; return (DataAlt con, vs', rhs') }
1758 -- add_evals records the evaluated-ness of the bound variables of
1759 -- a case pattern. This is *important*. Consider
1760 -- data T = T !Int !Int
1762 -- case x of { T a b -> T (a+1) b }
1764 -- We really must record that b is already evaluated so that we don't
1765 -- go and re-evaluate it when constructing the result.
1766 -- See Note [Data-con worker strictness] in MkId.lhs
1771 go (v:vs') strs | isTyVar v = v : go vs' strs
1772 go (v:vs') (str:strs)
1773 | isMarkedStrict str = evald_v : go vs' strs
1774 | otherwise = zapped_v : go vs' strs
1776 zapped_v = zap_occ_info v
1777 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
1778 go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
1780 -- See Note [zapOccInfo]
1781 -- zap_occ_info: if the case binder is alive, then we add the unfolding
1783 -- to the envt; so vs are now very much alive
1784 -- Note [Aug06] I can't see why this actually matters, but it's neater
1785 -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
1786 -- ==> case e of t { (a,b) -> ...(a)... }
1787 -- Look, Ma, a is alive now.
1788 zap_occ_info = zapCasePatIdOcc case_bndr'
1790 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1791 addBinderUnfolding env bndr rhs
1792 = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
1794 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1795 addBinderOtherCon env bndr cons
1796 = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
1798 zapCasePatIdOcc :: Id -> Id -> Id
1799 -- Consider case e of b { (a,b) -> ... }
1800 -- Then if we bind b to (a,b) in "...", and b is not dead,
1801 -- then we must zap the deadness info on a,b
1802 zapCasePatIdOcc case_bndr
1803 | isDeadBinder case_bndr = \ pat_id -> pat_id
1804 | otherwise = \ pat_id -> zapIdOccInfo pat_id
1808 %************************************************************************
1810 \subsection{Known constructor}
1812 %************************************************************************
1814 We are a bit careful with occurrence info. Here's an example
1816 (\x* -> case x of (a*, b) -> f a) (h v, e)
1818 where the * means "occurs once". This effectively becomes
1819 case (h v, e) of (a*, b) -> f a)
1821 let a* = h v; b = e in f a
1825 All this should happen in one sweep.
1828 knownCon :: SimplEnv
1829 -> OutExpr -- The scrutinee
1830 -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces)
1831 -> InId -> [InBndr] -> InExpr -- The alternative
1833 -> SimplM (SimplEnv, OutExpr)
1835 knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
1836 = do { env' <- bind_args env bs dc_args
1837 ; env'' <- bind_case_bndr env'
1838 ; simplExprF env'' rhs cont }
1840 zap_occ = zapCasePatIdOcc bndr -- bndr is an InId
1843 bind_args env' [] _ = return env'
1845 bind_args env' (b:bs') (Type ty : args)
1846 = ASSERT( isTyVar b )
1847 bind_args (extendTvSubst env' b ty) bs' args
1849 bind_args env' (b:bs') (arg : args)
1851 do { let b' = zap_occ b
1852 -- Note that the binder might be "dead", because it doesn't
1853 -- occur in the RHS; and simplNonRecX may therefore discard
1854 -- it via postInlineUnconditionally.
1855 -- Nevertheless we must keep it if the case-binder is alive,
1856 -- because it may be used in the con_app. See Note [zapOccInfo]
1857 ; env'' <- simplNonRecX env' b' arg
1858 ; bind_args env'' bs' args }
1861 pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
1862 text "scrut:" <+> ppr scrut
1864 -- It's useful to bind bndr to scrut, rather than to a fresh
1865 -- binding x = Con arg1 .. argn
1866 -- because very often the scrut is a variable, so we avoid
1867 -- creating, and then subsequently eliminating, a let-binding
1868 -- BUT, if scrut is a not a variable, we must be careful
1869 -- about duplicating the arg redexes; in that case, make
1870 -- a new con-app from the args
1872 | isDeadBinder bndr = return env
1873 | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut))
1874 | otherwise = do { dc_args <- mapM (simplVar env) bs
1875 -- dc_ty_args are aready OutTypes,
1876 -- but bs are InBndrs
1877 ; let con_app = Var (dataConWorkId dc)
1878 `mkTyApps` dc_ty_args
1880 ; simplNonRecX env bndr con_app }
1883 missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
1884 -- This isn't strictly an error, although it is unusual.
1885 -- It's possible that the simplifer might "see" that
1886 -- an inner case has no accessible alternatives before
1887 -- it "sees" that the entire branch of an outer case is
1888 -- inaccessible. So we simply put an error case here instead.
1889 missingAlt env case_bndr alts cont
1890 = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
1891 return (env, mkImpossibleExpr res_ty)
1893 res_ty = contResultType env (substTy env (coreAltsType alts)) cont
1897 %************************************************************************
1899 \subsection{Duplicating continuations}
1901 %************************************************************************
1904 prepareCaseCont :: SimplEnv
1905 -> [InAlt] -> SimplCont
1906 -> SimplM (SimplEnv, SimplCont,SimplCont)
1907 -- Return a duplicatable continuation, a non-duplicable part
1908 -- plus some extra bindings (that scope over the entire
1911 -- No need to make it duplicatable if there's only one alternative
1912 prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
1913 prepareCaseCont env _ cont = mkDupableCont env cont
1917 mkDupableCont :: SimplEnv -> SimplCont
1918 -> SimplM (SimplEnv, SimplCont, SimplCont)
1920 mkDupableCont env cont
1921 | contIsDupable cont
1922 = return (env, cont, mkBoringStop)
1924 mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
1926 mkDupableCont env (CoerceIt ty cont)
1927 = do { (env', dup, nodup) <- mkDupableCont env cont
1928 ; return (env', CoerceIt ty dup, nodup) }
1930 mkDupableCont env cont@(StrictBind {})
1931 = return (env, mkBoringStop, cont)
1932 -- See Note [Duplicating StrictBind]
1934 mkDupableCont env (StrictArg info cci cont)
1935 -- See Note [Duplicating StrictArg]
1936 = do { (env', dup, nodup) <- mkDupableCont env cont
1937 ; (env'', args') <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info)
1938 ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
1940 mkDupableCont env (ApplyTo _ arg se cont)
1941 = -- e.g. [...hole...] (...arg...)
1943 -- let a = ...arg...
1944 -- in [...hole...] a
1945 do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1946 ; arg' <- simplExpr (se `setInScope` env') arg
1947 ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
1948 ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
1949 ; return (env'', app_cont, nodup_cont) }
1951 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
1952 -- See Note [Single-alternative case]
1953 -- | not (exprIsDupable rhs && contIsDupable case_cont)
1954 -- | not (isDeadBinder case_bndr)
1955 | all isDeadBinder bs -- InIds
1956 && not (isUnLiftedType (idType case_bndr))
1957 -- Note [Single-alternative-unlifted]
1958 = return (env, mkBoringStop, cont)
1960 mkDupableCont env (Select _ case_bndr alts se cont)
1961 = -- e.g. (case [...hole...] of { pi -> ei })
1963 -- let ji = \xij -> ei
1964 -- in case [...hole...] of { pi -> ji xij }
1965 do { tick (CaseOfCase case_bndr)
1966 ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1967 -- NB: call mkDupableCont here, *not* prepareCaseCont
1968 -- We must make a duplicable continuation, whereas prepareCaseCont
1969 -- doesn't when there is a single case branch
1971 ; let alt_env = se `setInScope` env'
1972 ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
1973 ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
1974 -- Safe to say that there are no handled-cons for the DEFAULT case
1975 -- NB: simplBinder does not zap deadness occ-info, so
1976 -- a dead case_bndr' will still advertise its deadness
1977 -- This is really important because in
1978 -- case e of b { (# p,q #) -> ... }
1979 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1980 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1981 -- In the new alts we build, we have the new case binder, so it must retain
1983 -- NB: we don't use alt_env further; it has the substEnv for
1984 -- the alternatives, and we don't want that
1986 ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
1987 ; return (env'', -- Note [Duplicated env]
1988 Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
1992 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1993 -> SimplM (SimplEnv, [InAlt])
1994 -- Absorbs the continuation into the new alternatives
1996 mkDupableAlts env case_bndr' the_alts
1999 go env0 [] = return (env0, [])
2001 = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
2002 ; (env2, alts') <- go env1 alts
2003 ; return (env2, alt' : alts' ) }
2005 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
2006 -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
2007 mkDupableAlt env case_bndr (con, bndrs', rhs')
2008 | exprIsDupable rhs' -- Note [Small alternative rhs]
2009 = return (env, (con, bndrs', rhs'))
2011 = do { let rhs_ty' = exprType rhs'
2012 scrut_ty = idType case_bndr
2015 DEFAULT -> case_bndr
2016 DataAlt dc -> setIdUnfolding case_bndr unf
2018 -- See Note [Case binders and join points]
2019 unf = mkInlineRule rhs Nothing
2020 rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
2021 ++ varsToCoreExprs bndrs')
2023 LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
2024 <+> ppr case_bndr <+> ppr con )
2026 -- The case binder is alive but trivial, so why has
2027 -- it not been substituted away?
2029 used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs'
2030 | otherwise = bndrs' ++ [case_bndr_w_unf]
2033 | isTyVar bndr = True -- Abstract over all type variables just in case
2034 | otherwise = not (isDeadBinder bndr)
2035 -- The deadness info on the new Ids is preserved by simplBinders
2037 ; (final_bndrs', final_args) -- Note [Join point abstraction]
2038 <- if (any isId used_bndrs')
2039 then return (used_bndrs', varsToCoreExprs used_bndrs')
2040 else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
2041 ; return ([rw_id], [Var realWorldPrimId]) }
2043 ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
2044 -- Note [Funky mkPiTypes]
2046 ; let -- We make the lambdas into one-shot-lambdas. The
2047 -- join point is sure to be applied at most once, and doing so
2048 -- prevents the body of the join point being floated out by
2049 -- the full laziness pass
2050 really_final_bndrs = map one_shot final_bndrs'
2051 one_shot v | isId v = setOneShotLambda v
2053 join_rhs = mkLams really_final_bndrs rhs'
2054 join_call = mkApps (Var join_bndr) final_args
2056 ; env' <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs)
2057 ; return (env', (con, bndrs', join_call)) }
2058 -- See Note [Duplicated env]
2061 Note [Case binders and join points]
2062 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2064 case (case .. ) of c {
2067 If we make a join point with c but not c# we get
2068 $j = \c -> ....c....
2070 But if later inlining scrutines the c, thus
2072 $j = \c -> ... case c of { I# y -> ... } ...
2074 we won't see that 'c' has already been scrutinised. This actually
2075 happens in the 'tabulate' function in wave4main, and makes a significant
2076 difference to allocation.
2078 An alternative plan is this:
2080 $j = \c# -> let c = I# c# in ...c....
2082 but that is bad if 'c' is *not* later scrutinised.
2084 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
2085 that it's really I# c#, thus
2087 $j = \c# -> \c[=I# c#] -> ...c....
2089 Absence analysis may later discard 'c'.
2092 Note [Duplicated env]
2093 ~~~~~~~~~~~~~~~~~~~~~
2094 Some of the alternatives are simplified, but have not been turned into a join point
2095 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
2096 bind the join point, because it might to do PostInlineUnconditionally, and
2097 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
2098 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
2099 at worst delays the join-point inlining.
2101 Note [Small alternative rhs]
2102 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2103 It is worth checking for a small RHS because otherwise we
2104 get extra let bindings that may cause an extra iteration of the simplifier to
2105 inline back in place. Quite often the rhs is just a variable or constructor.
2106 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
2107 iterations because the version with the let bindings looked big, and so wasn't
2108 inlined, but after the join points had been inlined it looked smaller, and so
2111 NB: we have to check the size of rhs', not rhs.
2112 Duplicating a small InAlt might invalidate occurrence information
2113 However, if it *is* dupable, we return the *un* simplified alternative,
2114 because otherwise we'd need to pair it up with an empty subst-env....
2115 but we only have one env shared between all the alts.
2116 (Remember we must zap the subst-env before re-simplifying something).
2117 Rather than do this we simply agree to re-simplify the original (small) thing later.
2119 Note [Funky mkPiTypes]
2120 ~~~~~~~~~~~~~~~~~~~~~~
2121 Notice the funky mkPiTypes. If the contructor has existentials
2122 it's possible that the join point will be abstracted over
2123 type varaibles as well as term variables.
2124 Example: Suppose we have
2125 data T = forall t. C [t]
2127 case (case e of ...) of
2129 We get the join point
2130 let j :: forall t. [t] -> ...
2131 j = /\t \xs::[t] -> rhs
2133 case (case e of ...) of
2134 C t xs::[t] -> j t xs
2136 Note [Join point abstaction]
2137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2138 If we try to lift a primitive-typed something out
2139 for let-binding-purposes, we will *caseify* it (!),
2140 with potentially-disastrous strictness results. So
2141 instead we turn it into a function: \v -> e
2142 where v::State# RealWorld#. The value passed to this function
2143 is realworld#, which generates (almost) no code.
2145 There's a slight infelicity here: we pass the overall
2146 case_bndr to all the join points if it's used in *any* RHS,
2147 because we don't know its usage in each RHS separately
2149 We used to say "&& isUnLiftedType rhs_ty'" here, but now
2150 we make the join point into a function whenever used_bndrs'
2151 is empty. This makes the join-point more CPR friendly.
2152 Consider: let j = if .. then I# 3 else I# 4
2153 in case .. of { A -> j; B -> j; C -> ... }
2155 Now CPR doesn't w/w j because it's a thunk, so
2156 that means that the enclosing function can't w/w either,
2157 which is a lose. Here's the example that happened in practice:
2158 kgmod :: Int -> Int -> Int
2159 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2163 I have seen a case alternative like this:
2165 It's a bit silly to add the realWorld dummy arg in this case, making
2168 (the \v alone is enough to make CPR happy) but I think it's rare
2170 Note [Duplicating StrictArg]
2171 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2172 The original plan had (where E is a big argument)
2174 ==> let $j = \a -> f E a
2177 But this is terrible! Here's an example:
2178 && E (case x of { T -> F; F -> T })
2179 Now, && is strict so we end up simplifying the case with
2180 an ArgOf continuation. If we let-bind it, we get
2181 let $j = \v -> && E v
2182 in simplExpr (case x of { T -> F; F -> T })
2184 And after simplifying more we get
2185 let $j = \v -> && E v
2186 in case x of { T -> $j F; F -> $j T }
2187 Which is a Very Bad Thing
2189 What we do now is this
2193 Now if the thing in the hole is a case expression (which is when
2194 we'll call mkDupableCont), we'll push the function call into the
2195 branches, which is what we want. Now RULES for f may fire, and
2196 call-pattern specialisation. Here's an example from Trac #3116
2199 _ -> Chunk p fpc (o+1) (l-1) bs')
2200 If we can push the call for 'go' inside the case, we get
2201 call-pattern specialisation for 'go', which is *crucial* for
2204 Here is the (&&) example:
2205 && E (case x of { T -> F; F -> T })
2207 case x of { T -> && a F; F -> && a T }
2211 * Arguments to f *after* the strict one are handled by
2212 the ApplyTo case of mkDupableCont. Eg
2215 * We can only do the let-binding of E because the function
2216 part of a StrictArg continuation is an explicit syntax
2217 tree. In earlier versions we represented it as a function
2218 (CoreExpr -> CoreEpxr) which we couldn't take apart.
2220 Do *not* duplicate StrictBind and StritArg continuations. We gain
2221 nothing by propagating them into the expressions, and we do lose a
2224 The desire not to duplicate is the entire reason that
2225 mkDupableCont returns a pair of continuations.
2227 Note [Duplicating StrictBind]
2228 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2229 Unlike StrictArg, there doesn't seem anything to gain from
2230 duplicating a StrictBind continuation, so we don't.
2232 The desire not to duplicate is the entire reason that
2233 mkDupableCont returns a pair of continuations.
2236 Note [Single-alternative cases]
2237 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2238 This case is just like the ArgOf case. Here's an example:
2242 case (case x of I# x' ->
2244 True -> I# (negate# x')
2245 False -> I# x') of y {
2247 Because the (case x) has only one alternative, we'll transform to
2249 case (case x' <# 0# of
2250 True -> I# (negate# x')
2251 False -> I# x') of y {
2253 But now we do *NOT* want to make a join point etc, giving
2255 let $j = \y -> MkT y
2257 True -> $j (I# (negate# x'))
2259 In this case the $j will inline again, but suppose there was a big
2260 strict computation enclosing the orginal call to MkT. Then, it won't
2261 "see" the MkT any more, because it's big and won't get duplicated.
2262 And, what is worse, nothing was gained by the case-of-case transform.
2264 When should use this case of mkDupableCont?
2265 However, matching on *any* single-alternative case is a *disaster*;
2266 e.g. case (case ....) of (a,b) -> (# a,b #)
2267 We must push the outer case into the inner one!
2270 * Match [(DEFAULT,_,_)], but in the common case of Int,
2271 the alternative-filling-in code turned the outer case into
2272 case (...) of y { I# _ -> MkT y }
2274 * Match on single alternative plus (not (isDeadBinder case_bndr))
2275 Rationale: pushing the case inwards won't eliminate the construction.
2276 But there's a risk of
2277 case (...) of y { (a,b) -> let z=(a,b) in ... }
2278 Now y looks dead, but it'll come alive again. Still, this
2279 seems like the best option at the moment.
2281 * Match on single alternative plus (all (isDeadBinder bndrs))
2282 Rationale: this is essentially seq.
2284 * Match when the rhs is *not* duplicable, and hence would lead to a
2285 join point. This catches the disaster-case above. We can test
2286 the *un-simplified* rhs, which is fine. It might get bigger or
2287 smaller after simplification; if it gets smaller, this case might
2288 fire next time round. NB also that we must test contIsDupable
2289 case_cont *btoo, because case_cont might be big!
2291 HOWEVER: I found that this version doesn't work well, because
2292 we can get let x = case (...) of { small } in ...case x...
2293 When x is inlined into its full context, we find that it was a bad
2294 idea to have pushed the outer case inside the (...) case.
2296 Note [Single-alternative-unlifted]
2297 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2298 Here's another single-alternative where we really want to do case-of-case:
2306 case y_s6X of tpl_s7m {
2307 M1.Mk1 ipv_s70 -> ipv_s70;
2308 M1.Mk2 ipv_s72 -> ipv_s72;
2314 case x_s74 of tpl_s7n {
2315 M1.Mk1 ipv_s77 -> ipv_s77;
2316 M1.Mk2 ipv_s79 -> ipv_s79;
2320 { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2324 So the outer case is doing *nothing at all*, other than serving as a
2325 join-point. In this case we really want to do case-of-case and decide
2326 whether to use a real join point or just duplicate the continuation.
2328 Hence: check whether the case binder's type is unlifted, because then
2329 the outer case is *not* a seq.