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 )
20 import FamInstEnv ( topNormaliseType )
21 import DataCon ( dataConRepStrictness, dataConUnivTyVars )
23 import NewDemand ( isStrictDmd )
24 import PprCore ( pprParendExpr, pprCoreExpr )
25 import CoreUnfold ( mkUnfolding, callSiteInline )
27 import Rules ( lookupRule )
28 import BasicTypes ( isMarkedStrict )
29 import CostCentre ( currentCCS )
30 import TysPrim ( realWorldStatePrimTy )
31 import PrelInfo ( realWorldPrimId )
32 import BasicTypes ( TopLevelFlag(..), isTopLevel,
33 RecFlag(..), isNonRuleLoopBreaker )
34 import Maybes ( orElse )
40 The guts of the simplifier is in this module, but the driver loop for
41 the simplifier is in SimplCore.lhs.
44 -----------------------------------------
45 *** IMPORTANT NOTE ***
46 -----------------------------------------
47 The simplifier used to guarantee that the output had no shadowing, but
48 it does not do so any more. (Actually, it never did!) The reason is
49 documented with simplifyArgs.
52 -----------------------------------------
53 *** IMPORTANT NOTE ***
54 -----------------------------------------
55 Many parts of the simplifier return a bunch of "floats" as well as an
56 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
58 All "floats" are let-binds, not case-binds, but some non-rec lets may
59 be unlifted (with RHS ok-for-speculation).
63 -----------------------------------------
64 ORGANISATION OF FUNCTIONS
65 -----------------------------------------
67 - simplify all top-level binders
68 - for NonRec, call simplRecOrTopPair
69 - for Rec, call simplRecBind
72 ------------------------------
73 simplExpr (applied lambda) ==> simplNonRecBind
74 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
75 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
77 ------------------------------
78 simplRecBind [binders already simplfied]
79 - use simplRecOrTopPair on each pair in turn
81 simplRecOrTopPair [binder already simplified]
82 Used for: recursive bindings (top level and nested)
83 top-level non-recursive bindings
85 - check for PreInlineUnconditionally
89 Used for: non-top-level non-recursive bindings
90 beta reductions (which amount to the same thing)
91 Because it can deal with strict arts, it takes a
92 "thing-inside" and returns an expression
94 - check for PreInlineUnconditionally
95 - simplify binder, including its IdInfo
104 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
105 Used for: binding case-binder and constr args in a known-constructor case
106 - check for PreInLineUnconditionally
110 ------------------------------
111 simplLazyBind: [binder already simplified, RHS not]
112 Used for: recursive bindings (top level and nested)
113 top-level non-recursive bindings
114 non-top-level, but *lazy* non-recursive bindings
115 [must not be strict or unboxed]
116 Returns floats + an augmented environment, not an expression
117 - substituteIdInfo and add result to in-scope
118 [so that rules are available in rec rhs]
121 - float if exposes constructor or PAP
125 completeNonRecX: [binder and rhs both simplified]
126 - if the the thing needs case binding (unlifted and not ok-for-spec)
132 completeBind: [given a simplified RHS]
133 [used for both rec and non-rec bindings, top level and not]
134 - try PostInlineUnconditionally
135 - add unfolding [this is the only place we add an unfolding]
140 Right hand sides and arguments
141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
142 In many ways we want to treat
143 (a) the right hand side of a let(rec), and
144 (b) a function argument
145 in the same way. But not always! In particular, we would
146 like to leave these arguments exactly as they are, so they
147 will match a RULE more easily.
152 It's harder to make the rule match if we ANF-ise the constructor,
153 or eta-expand the PAP:
155 f (let { a = g x; b = h x } in (a,b))
158 On the other hand if we see the let-defns
163 then we *do* want to ANF-ise and eta-expand, so that p and q
164 can be safely inlined.
166 Even floating lets out is a bit dubious. For let RHS's we float lets
167 out if that exposes a value, so that the value can be inlined more vigorously.
170 r = let x = e in (x,x)
172 Here, if we float the let out we'll expose a nice constructor. We did experiments
173 that showed this to be a generally good thing. But it was a bad thing to float
174 lets out unconditionally, because that meant they got allocated more often.
176 For function arguments, there's less reason to expose a constructor (it won't
177 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
178 So for the moment we don't float lets out of function arguments either.
183 For eta expansion, we want to catch things like
185 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
187 If the \x was on the RHS of a let, we'd eta expand to bring the two
188 lambdas together. And in general that's a good thing to do. Perhaps
189 we should eta expand wherever we find a (value) lambda? Then the eta
190 expansion at a let RHS can concentrate solely on the PAP case.
193 %************************************************************************
195 \subsection{Bindings}
197 %************************************************************************
200 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
202 simplTopBinds env binds
203 = do { -- Put all the top-level binders into scope at the start
204 -- so that if a transformation rule has unexpectedly brought
205 -- anything into scope, then we don't get a complaint about that.
206 -- It's rather as if the top-level binders were imported.
207 ; env <- simplRecBndrs env (bindersOfBinds binds)
208 ; dflags <- getDOptsSmpl
209 ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
210 dopt Opt_D_dump_rule_firings dflags
211 ; env' <- simpl_binds dump_flag env binds
212 ; freeTick SimplifierDone
213 ; return (getFloats env') }
215 -- We need to track the zapped top-level binders, because
216 -- they should have their fragile IdInfo zapped (notably occurrence info)
217 -- That's why we run down binds and bndrs' simultaneously.
219 -- The dump-flag emits a trace for each top-level binding, which
220 -- helps to locate the tracing for inlining and rule firing
221 simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
222 simpl_binds dump env [] = return env
223 simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $
225 ; simpl_binds dump env' binds }
227 trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
228 trace False bind = \x -> x
230 simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r
231 simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
235 %************************************************************************
237 \subsection{Lazy bindings}
239 %************************************************************************
241 simplRecBind is used for
242 * recursive bindings only
245 simplRecBind :: SimplEnv -> TopLevelFlag
248 simplRecBind env top_lvl pairs
249 = do { env' <- go (zapFloats env) pairs
250 ; return (env `addRecFloats` env') }
251 -- addFloats adds the floats from env',
252 -- *and* updates env with the in-scope set from env'
254 go env [] = return env
256 go env ((bndr, rhs) : pairs)
257 = do { env <- simplRecOrTopPair env top_lvl bndr rhs
261 simplOrTopPair is used for
262 * recursive bindings (whether top level or not)
263 * top-level non-recursive bindings
265 It assumes the binder has already been simplified, but not its IdInfo.
268 simplRecOrTopPair :: SimplEnv
270 -> InId -> InExpr -- Binder and rhs
271 -> SimplM SimplEnv -- Returns an env that includes the binding
273 simplRecOrTopPair env top_lvl bndr rhs
274 | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline
275 = do { tick (PreInlineUnconditionally bndr)
276 ; return (extendIdSubst env bndr (mkContEx env rhs)) }
279 = do { let bndr' = lookupRecBndr env bndr
280 (env', bndr'') = addLetIdInfo env bndr bndr'
281 ; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' }
282 -- May not actually be recursive, but it doesn't matter
286 simplLazyBind is used for
287 * [simplRecOrTopPair] recursive bindings (whether top level or not)
288 * [simplRecOrTopPair] top-level non-recursive bindings
289 * [simplNonRecE] non-top-level *lazy* non-recursive bindings
292 1. It assumes that the binder is *already* simplified,
293 and is in scope, and its IdInfo too, except unfolding
295 2. It assumes that the binder type is lifted.
297 3. It does not check for pre-inline-unconditionallly;
298 that should have been done already.
301 simplLazyBind :: SimplEnv
302 -> TopLevelFlag -> RecFlag
303 -> InId -> OutId -- Binder, both pre-and post simpl
304 -- The OutId has IdInfo, except arity, unfolding
305 -> InExpr -> SimplEnv -- The RHS and its environment
308 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
309 = do { let rhs_env = rhs_se `setInScope` env
310 (tvs, body) = collectTyBinders rhs
311 ; (body_env, tvs') <- simplBinders rhs_env tvs
312 -- See Note [Floating and type abstraction]
315 -- Simplify the RHS; note the mkRhsStop, which tells
316 -- the simplifier that this is the RHS of a let.
317 ; let rhs_cont = mkRhsStop (applyTys (idType bndr1) (mkTyVarTys tvs'))
318 ; (body_env1, body1) <- simplExprF body_env body rhs_cont
320 -- ANF-ise a constructor or PAP rhs
321 ; (body_env2, body2) <- prepareRhs body_env1 body1
324 <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
325 then -- No floating, just wrap up!
326 do { rhs' <- mkLam tvs' (wrapFloats body_env2 body2)
327 ; return (env, rhs') }
329 else if null tvs then -- Simple floating
330 do { tick LetFloatFromLet
331 ; return (addFloats env body_env2, body2) }
333 else -- Do type-abstraction first
334 do { tick LetFloatFromLet
335 ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
336 ; rhs' <- mkLam tvs' body3
337 ; return (extendFloats env poly_binds, rhs') }
339 ; completeBind env' top_lvl bndr bndr1 rhs' }
342 A specialised variant of simplNonRec used when the RHS is already simplified,
343 notably in knownCon. It uses case-binding where necessary.
346 simplNonRecX :: SimplEnv
347 -> InId -- Old binder
348 -> OutExpr -- Simplified RHS
351 simplNonRecX env bndr new_rhs
352 = do { (env, bndr') <- simplBinder env bndr
353 ; completeNonRecX env NotTopLevel NonRecursive
354 (isStrictId bndr) bndr bndr' new_rhs }
356 completeNonRecX :: SimplEnv
357 -> TopLevelFlag -> RecFlag -> Bool
358 -> InId -- Old binder
359 -> OutId -- New binder
360 -> OutExpr -- Simplified RHS
363 completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs
364 = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
366 if doFloatFromRhs top_lvl is_rec is_strict rhs1 env1
367 then do { tick LetFloatFromLet
368 ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
369 else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
370 ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
373 {- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
374 Doing so risks exponential behaviour, because new_rhs has been simplified once already
375 In the cases described by the folowing commment, postInlineUnconditionally will
376 catch many of the relevant cases.
377 -- This happens; for example, the case_bndr during case of
378 -- known constructor: case (a,b) of x { (p,q) -> ... }
379 -- Here x isn't mentioned in the RHS, so we don't want to
380 -- create the (dead) let-binding let x = (a,b) in ...
382 -- Similarly, single occurrences can be inlined vigourously
383 -- e.g. case (f x, g y) of (a,b) -> ....
384 -- If a,b occur once we can avoid constructing the let binding for them.
386 Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
387 -- Consider case I# (quotInt# x y) of
388 -- I# v -> let w = J# v in ...
389 -- If we gaily inline (quotInt# x y) for v, we end up building an
391 -- let w = J# (quotInt# x y) in ...
392 -- because quotInt# can fail.
394 | preInlineUnconditionally env NotTopLevel bndr new_rhs
395 = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
398 ----------------------------------
399 prepareRhs takes a putative RHS, checks whether it's a PAP or
400 constructor application and, if so, converts it to ANF, so that the
401 resulting thing can be inlined more easily. Thus
408 We also want to deal well cases like this
409 v = (f e1 `cast` co) e2
410 Here we want to make e1,e2 trivial and get
411 x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
412 That's what the 'go' loop in prepareRhs does
415 prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
416 -- Adds new floats to the env iff that allows us to return a good RHS
417 prepareRhs env (Cast rhs co) -- Note [Float coercions]
418 = do { (env', rhs') <- makeTrivial env rhs
419 ; return (env', Cast rhs' co) }
422 = do { (is_val, env', rhs') <- go 0 env rhs
423 ; return (env', rhs') }
425 go n_val_args env (Cast rhs co)
426 = do { (is_val, env', rhs') <- go n_val_args env rhs
427 ; return (is_val, env', Cast rhs' co) }
428 go n_val_args env (App fun (Type ty))
429 = do { (is_val, env', rhs') <- go n_val_args env fun
430 ; return (is_val, env', App rhs' (Type ty)) }
431 go n_val_args env (App fun arg)
432 = do { (is_val, env', fun') <- go (n_val_args+1) env fun
434 True -> do { (env'', arg') <- makeTrivial env' arg
435 ; return (True, env'', App fun' arg') }
436 False -> return (False, env, App fun arg) }
437 go n_val_args env (Var fun)
438 = return (is_val, env, Var fun)
440 is_val = n_val_args > 0 -- There is at least one arg
441 -- ...and the fun a constructor or PAP
442 && (isDataConWorkId fun || n_val_args < idArity fun)
443 go n_val_args env other
444 = return (False, env, other)
448 Note [Float coercions]
449 ~~~~~~~~~~~~~~~~~~~~~~
450 When we find the binding
452 we'd like to transform it to
454 x = x `cast` co -- A trivial binding
455 There's a chance that e will be a constructor application or function, or something
456 like that, so moving the coerion to the usage site may well cancel the coersions
457 and lead to further optimisation. Example:
460 data instance T Int = T Int
462 foo :: Int -> Int -> Int
467 go n = case x of { T m -> go (n-m) }
468 -- This case should optimise
472 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
473 -- Binds the expression to a variable, if it's not trivial, returning the variable
477 | otherwise -- See Note [Take care] below
478 = do { var <- newId FSLIT("a") (exprType expr)
479 ; env <- completeNonRecX env NotTopLevel NonRecursive
481 ; return (env, substExpr env (Var var)) }
485 %************************************************************************
487 \subsection{Completing a lazy binding}
489 %************************************************************************
492 * deals only with Ids, not TyVars
493 * takes an already-simplified binder and RHS
494 * is used for both recursive and non-recursive bindings
495 * is used for both top-level and non-top-level bindings
497 It does the following:
498 - tries discarding a dead binding
499 - tries PostInlineUnconditionally
500 - add unfolding [this is the only place we add an unfolding]
503 It does *not* attempt to do let-to-case. Why? Because it is used for
504 - top-level bindings (when let-to-case is impossible)
505 - many situations where the "rhs" is known to be a WHNF
506 (so let-to-case is inappropriate).
508 Nor does it do the atomic-argument thing
511 completeBind :: SimplEnv
512 -> TopLevelFlag -- Flag stuck into unfolding
513 -> InId -- Old binder
514 -> OutId -> OutExpr -- New binder and RHS
516 -- completeBind may choose to do its work
517 -- * by extending the substitution (e.g. let x = y in ...)
518 -- * or by adding to the floats in the envt
520 completeBind env top_lvl old_bndr new_bndr new_rhs
521 | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
522 -- Inline and discard the binding
523 = do { tick (PostInlineUnconditionally old_bndr)
524 ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
525 return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
526 -- Use the substitution to make quite, quite sure that the
527 -- substitution will happen, since we are going to discard the binding
532 new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
535 -- Add the unfolding *only* for non-loop-breakers
536 -- Making loop breakers not have an unfolding at all
537 -- means that we can avoid tests in exprIsConApp, for example.
538 -- This is important: if exprIsConApp says 'yes' for a recursive
539 -- thing, then we can get into an infinite loop
542 -- If the unfolding is a value, the demand info may
543 -- go pear-shaped, so we nuke it. Example:
545 -- case x of (p,q) -> h p q x
546 -- Here x is certainly demanded. But after we've nuked
547 -- the case, we'll get just
548 -- let x = (a,b) in h a b x
549 -- and now x is not demanded (I'm assuming h is lazy)
550 -- This really happens. Similarly
551 -- let f = \x -> e in ...f..f...
552 -- After inlining f at some of its call sites the original binding may
553 -- (for example) be no longer strictly demanded.
554 -- The solution here is a bit ad hoc...
555 info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
556 final_info | loop_breaker = new_bndr_info
557 | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
558 | otherwise = info_w_unf
560 final_id = new_bndr `setIdInfo` final_info
562 -- These seqs forces the Id, and hence its IdInfo,
563 -- and hence any inner substitutions
565 -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
566 return (addNonRec env final_id new_rhs)
568 unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
569 loop_breaker = isNonRuleLoopBreaker occ_info
570 old_info = idInfo old_bndr
571 occ_info = occInfo old_info
576 %************************************************************************
578 \subsection[Simplify-simplExpr]{The main function: simplExpr}
580 %************************************************************************
582 The reason for this OutExprStuff stuff is that we want to float *after*
583 simplifying a RHS, not before. If we do so naively we get quadratic
584 behaviour as things float out.
586 To see why it's important to do it after, consider this (real) example:
600 a -- Can't inline a this round, cos it appears twice
604 Each of the ==> steps is a round of simplification. We'd save a
605 whole round if we float first. This can cascade. Consider
610 let f = let d1 = ..d.. in \y -> e
614 in \x -> ...(\y ->e)...
616 Only in this second round can the \y be applied, and it
617 might do the same again.
621 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
622 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
624 expr_ty' = substTy env (exprType expr)
625 -- The type in the Stop continuation, expr_ty', is usually not used
626 -- It's only needed when discarding continuations after finding
627 -- a function that returns bottom.
628 -- Hence the lazy substitution
631 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
632 -- Simplify an expression, given a continuation
633 simplExprC env expr cont
634 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
635 do { (env', expr') <- simplExprF (zapFloats env) expr cont
636 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
637 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
638 -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
639 return (wrapFloats env' expr') }
641 --------------------------------------------------
642 simplExprF :: SimplEnv -> InExpr -> SimplCont
643 -> SimplM (SimplEnv, OutExpr)
645 simplExprF env e cont
646 = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
647 simplExprF' env e cont
649 simplExprF' env (Var v) cont = simplVar env v cont
650 simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
651 simplExprF' env (Note n expr) cont = simplNote env n expr cont
652 simplExprF' env (Cast body co) cont = simplCast env body co cont
653 simplExprF' env (App fun arg) cont = simplExprF env fun $
654 ApplyTo NoDup arg env cont
656 simplExprF' env expr@(Lam _ _) cont
657 = simplLam env (map zap bndrs) body cont
658 -- The main issue here is under-saturated lambdas
659 -- (\x1. \x2. e) arg1
660 -- Here x1 might have "occurs-once" occ-info, because occ-info
661 -- is computed assuming that a group of lambdas is applied
662 -- all at once. If there are too few args, we must zap the
665 n_args = countArgs cont
666 n_params = length bndrs
667 (bndrs, body) = collectBinders expr
668 zap | n_args >= n_params = \b -> b
669 | otherwise = \b -> if isTyVar b then b
671 -- NB: we count all the args incl type args
672 -- so we must count all the binders (incl type lambdas)
674 simplExprF' env (Type ty) cont
675 = ASSERT( contIsRhsOrArg cont )
676 do { ty' <- simplType env ty
677 ; rebuild env (Type ty') cont }
679 simplExprF' env (Case scrut bndr case_ty alts) cont
680 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
681 = -- Simplify the scrutinee with a Select continuation
682 simplExprF env scrut (Select NoDup bndr alts env cont)
685 = -- If case-of-case is off, simply simplify the case expression
686 -- in a vanilla Stop context, and rebuild the result around it
687 do { case_expr' <- simplExprC env scrut case_cont
688 ; rebuild env case_expr' cont }
690 case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
691 case_ty' = substTy env case_ty -- c.f. defn of simplExpr
693 simplExprF' env (Let (Rec pairs) body) cont
694 = do { env <- simplRecBndrs env (map fst pairs)
695 -- NB: bndrs' don't have unfoldings or rules
696 -- We add them as we go down
698 ; env <- simplRecBind env NotTopLevel pairs
699 ; simplExprF env body cont }
701 simplExprF' env (Let (NonRec bndr rhs) body) cont
702 = simplNonRecE env bndr (rhs, env) ([], body) cont
704 ---------------------------------
705 simplType :: SimplEnv -> InType -> SimplM OutType
706 -- Kept monadic just so we can do the seqType
708 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
709 seqType new_ty `seq` returnSmpl new_ty
711 new_ty = substTy env ty
715 %************************************************************************
717 \subsection{The main rebuilder}
719 %************************************************************************
722 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
723 -- At this point the substitution in the SimplEnv should be irrelevant
724 -- only the in-scope set and floats should matter
725 rebuild env expr cont
726 = -- pprTrace "rebuild" (ppr expr $$ ppr cont $$ ppr (seFloats env)) $
728 Stop {} -> return (env, expr)
729 CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
730 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
731 StrictArg fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont
732 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
733 ; simplLam env' bs body cont }
734 ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
735 ; rebuild env (App expr arg') cont }
739 %************************************************************************
743 %************************************************************************
746 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
747 -> SimplM (SimplEnv, OutExpr)
748 simplCast env body co cont
749 = do { co' <- simplType env co
750 ; simplExprF env body (addCoerce co' cont) }
752 addCoerce co cont = add_coerce co (coercionKind co) cont
754 add_coerce co (s1, k1) cont -- co :: ty~ty
755 | s1 `coreEqType` k1 = cont -- is a no-op
757 add_coerce co1 (s1, k2) (CoerceIt co2 cont)
758 | (l1, t1) <- coercionKind co2
759 -- coerce T1 S1 (coerce S1 K1 e)
762 -- coerce T1 K1 e, otherwise
764 -- For example, in the initial form of a worker
765 -- we may find (coerce T (coerce S (\x.e))) y
766 -- and we'd like it to simplify to e[y/x] in one round
768 , s1 `coreEqType` t1 = cont -- The coerces cancel out
769 | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
771 add_coerce co (s1s2, t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
772 -- (f `cast` g) ty ---> (f ty) `cast` (g @ ty)
773 -- This implements the PushT rule from the paper
774 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
775 , not (isCoVar tyvar)
776 = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
778 ty' = substTy arg_se arg_ty
780 -- ToDo: the PushC rule is not implemented at all
782 add_coerce co (s1s2, t1t2) (ApplyTo dup arg arg_se cont)
783 | not (isTypeArg arg) -- This implements the Push rule from the paper
784 , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
785 -- co : s1s2 :=: t1t2
786 -- (coerce (T1->T2) (S1->S2) F) E
788 -- coerce T2 S2 (F (coerce S1 T1 E))
790 -- t1t2 must be a function type, T1->T2, because it's applied
791 -- to something but s1s2 might conceivably not be
793 -- When we build the ApplyTo we can't mix the out-types
794 -- with the InExpr in the argument, so we simply substitute
795 -- to make it all consistent. It's a bit messy.
796 -- But it isn't a common case.
798 -- Example of use: Trac #995
799 = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
801 -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and
802 -- t2 :=: s2 with left and right on the curried form:
803 -- (->) t1 t2 :=: (->) s1 s2
804 [co1, co2] = decomposeCo 2 co
805 new_arg = mkCoerce (mkSymCoercion co1) arg'
806 arg' = substExpr arg_se arg
808 add_coerce co _ cont = CoerceIt co cont
812 %************************************************************************
816 %************************************************************************
819 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
820 -> SimplM (SimplEnv, OutExpr)
822 simplLam env [] body cont = simplExprF env body cont
824 -- Type-beta reduction
825 simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont)
826 = ASSERT( isTyVar bndr )
827 do { tick (BetaReduction bndr)
828 ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg
829 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
831 -- Ordinary beta reduction
832 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
833 = do { tick (BetaReduction bndr)
834 ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
836 -- Not enough args, so there are real lambdas left to put in the result
837 simplLam env bndrs body cont
838 = do { (env, bndrs') <- simplLamBndrs env bndrs
839 ; body' <- simplExpr env body
840 ; new_lam <- mkLam bndrs' body'
841 ; rebuild env new_lam cont }
844 simplNonRecE :: SimplEnv
845 -> InId -- The binder
846 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
847 -> ([InId], InExpr) -- Body of the let/lambda
850 -> SimplM (SimplEnv, OutExpr)
852 -- simplNonRecE is used for
853 -- * non-top-level non-recursive lets in expressions
856 -- It deals with strict bindings, via the StrictBind continuation,
857 -- which may abort the whole process
859 -- The "body" of the binding comes as a pair of ([InId],InExpr)
860 -- representing a lambda; so we recurse back to simplLam
861 -- Why? Because of the binder-occ-info-zapping done before
862 -- the call to simplLam in simplExprF (Lam ...)
864 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
865 | preInlineUnconditionally env NotTopLevel bndr rhs
866 = do { tick (PreInlineUnconditionally bndr)
867 ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
870 = do { simplExprF (rhs_se `setFloats` env) rhs
871 (StrictBind bndr bndrs body env cont) }
874 = do { (env, bndr') <- simplNonRecBndr env bndr
875 ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
876 ; simplLam env bndrs body cont }
880 %************************************************************************
884 %************************************************************************
887 -- Hack alert: we only distinguish subsumed cost centre stacks for the
888 -- purposes of inlining. All other CCCSs are mapped to currentCCS.
889 simplNote env (SCC cc) e cont
890 = do { e' <- simplExpr (setEnclosingCC env currentCCS) e
891 ; rebuild env (mkSCC cc e') cont }
893 -- See notes with SimplMonad.inlineMode
894 simplNote env InlineMe e cont
895 | contIsRhsOrArg cont -- Totally boring continuation; see notes above
896 = do { -- Don't inline inside an INLINE expression
897 e' <- simplExpr (setMode inlineMode env) e
898 ; rebuild env (mkInlineMe e') cont }
900 | otherwise -- Dissolve the InlineMe note if there's
901 -- an interesting context of any kind to combine with
902 -- (even a type application -- anything except Stop)
903 = simplExprF env e cont
905 simplNote env (CoreNote s) e cont
906 = simplExpr env e `thenSmpl` \ e' ->
907 rebuild env (Note (CoreNote s) e') cont
911 %************************************************************************
913 \subsection{Dealing with calls}
915 %************************************************************************
918 simplVar env var cont
919 = case substId env var of
920 DoneEx e -> simplExprF (zapSubstEnv env) e cont
921 ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
922 DoneId var1 -> completeCall (zapSubstEnv env) var1 cont
923 -- Note [zapSubstEnv]
924 -- The template is already simplified, so don't re-substitute.
925 -- This is VITAL. Consider
927 -- let y = \z -> ...x... in
929 -- We'll clone the inner \x, adding x->x' in the id_subst
930 -- Then when we inline y, we must *not* replace x by x' in
931 -- the inlined copy!!
933 ---------------------------------------------------------
934 -- Dealing with a call site
936 completeCall env var cont
937 = do { dflags <- getDOptsSmpl
938 ; let (args,call_cont) = contArgs cont
939 -- The args are OutExprs, obtained by *lazily* substituting
940 -- in the args found in cont. These args are only examined
941 -- to limited depth (unless a rule fires). But we must do
942 -- the substitution; rule matching on un-simplified args would
945 ------------- First try rules ----------------
946 -- Do this before trying inlining. Some functions have
947 -- rules *and* are strict; in this case, we don't want to
948 -- inline the wrapper of the non-specialised thing; better
949 -- to call the specialised thing instead.
951 -- We used to use the black-listing mechanism to ensure that inlining of
952 -- the wrapper didn't occur for things that have specialisations till a
953 -- later phase, so but now we just try RULES first
955 -- Note [Self-recursive rules]
956 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
957 -- You might think that we shouldn't apply rules for a loop breaker:
958 -- doing so might give rise to an infinite loop, because a RULE is
959 -- rather like an extra equation for the function:
960 -- RULE: f (g x) y = x+y
963 -- But it's too drastic to disable rules for loop breakers.
964 -- Even the foldr/build rule would be disabled, because foldr
965 -- is recursive, and hence a loop breaker:
966 -- foldr k z (build g) = g k z
967 -- So it's up to the programmer: rules can cause divergence
969 ; let in_scope = getInScope env
970 maybe_rule = case activeRule dflags env of
971 Nothing -> Nothing -- No rules apply
972 Just act_fn -> lookupRule act_fn in_scope
974 ; case maybe_rule of {
975 Just (rule, rule_rhs) ->
976 tick (RuleFired (ru_name rule)) `thenSmpl_`
977 (if dopt Opt_D_dump_rule_firings dflags then
978 pprTrace "Rule fired" (vcat [
979 text "Rule:" <+> ftext (ru_name rule),
980 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
981 text "After: " <+> pprCoreExpr rule_rhs,
982 text "Cont: " <+> ppr call_cont])
985 simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
986 -- The ruleArity says how many args the rule consumed
988 ; Nothing -> do -- No rules
990 ------------- Next try inlining ----------------
991 { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
992 n_val_args = length arg_infos
993 interesting_cont = interestingCallContext (notNull args)
996 active_inline = activeInline env var
997 maybe_inline = callSiteInline dflags active_inline
998 var arg_infos interesting_cont
999 ; case maybe_inline of {
1000 Just unfolding -- There is an inlining!
1001 -> do { tick (UnfoldingDone var)
1002 ; (if dopt Opt_D_dump_inlinings dflags then
1003 pprTrace "Inlining done" (vcat [
1004 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1005 text "Inlined fn: " <+> nest 2 (ppr unfolding),
1006 text "Cont: " <+> ppr call_cont])
1009 simplExprF env unfolding cont }
1011 ; Nothing -> -- No inlining!
1013 ------------- No inlining! ----------------
1014 -- Next, look for rules or specialisations that match
1016 rebuildCall env (Var var) (idType var)
1017 (mkArgInfo var n_val_args call_cont) cont
1020 rebuildCall :: SimplEnv
1021 -> OutExpr -> OutType -- Function and its type
1022 -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo
1024 -> SimplM (SimplEnv, OutExpr)
1025 rebuildCall env fun fun_ty (has_rules, []) cont
1026 -- When we run out of strictness args, it means
1027 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1028 -- Then we want to discard the entire strict continuation. E.g.
1029 -- * case (error "hello") of { ... }
1030 -- * (error "Hello") arg
1031 -- * f (error "Hello") where f is strict
1033 -- Then, especially in the first of these cases, we'd like to discard
1034 -- the continuation, leaving just the bottoming expression. But the
1035 -- type might not be right, so we may have to add a coerce.
1036 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1037 = return (env, mk_coerce fun) -- contination to discard, else we do it
1038 where -- again and again!
1039 cont_ty = contResultType cont
1040 co = mkUnsafeCoercion fun_ty cont_ty
1041 mk_coerce expr | cont_ty `coreEqType` fun_ty = fun
1042 | otherwise = mkCoerce co fun
1044 rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont)
1045 = do { ty' <- simplType (se `setInScope` env) arg_ty
1046 ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont }
1048 rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont)
1049 | str || isStrictType arg_ty -- Strict argument
1050 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1051 simplExprF (arg_se `setFloats` env) arg
1052 (StrictArg fun fun_ty (has_rules, strs) cont)
1055 | otherwise -- Lazy argument
1056 -- DO NOT float anything outside, hence simplExprC
1057 -- There is no benefit (unlike in a let-binding), and we'd
1058 -- have to be very careful about bogus strictness through
1059 -- floating a demanded let.
1060 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1061 (mkLazyArgStop arg_ty has_rules)
1062 ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont }
1064 (arg_ty, res_ty) = splitFunTy fun_ty
1066 rebuildCall env fun fun_ty info cont
1067 = rebuild env fun cont
1072 This part of the simplifier may break the no-shadowing invariant
1074 f (...(\a -> e)...) (case y of (a,b) -> e')
1075 where f is strict in its second arg
1076 If we simplify the innermost one first we get (...(\a -> e)...)
1077 Simplifying the second arg makes us float the case out, so we end up with
1078 case y of (a,b) -> f (...(\a -> e)...) e'
1079 So the output does not have the no-shadowing invariant. However, there is
1080 no danger of getting name-capture, because when the first arg was simplified
1081 we used an in-scope set that at least mentioned all the variables free in its
1082 static environment, and that is enough.
1084 We can't just do innermost first, or we'd end up with a dual problem:
1085 case x of (a,b) -> f e (...(\a -> e')...)
1087 I spent hours trying to recover the no-shadowing invariant, but I just could
1088 not think of an elegant way to do it. The simplifier is already knee-deep in
1089 continuations. We have to keep the right in-scope set around; AND we have
1090 to get the effect that finding (error "foo") in a strict arg position will
1091 discard the entire application and replace it with (error "foo"). Getting
1092 all this at once is TOO HARD!
1094 %************************************************************************
1096 Rebuilding a cse expression
1098 %************************************************************************
1100 Blob of helper functions for the "case-of-something-else" situation.
1103 ---------------------------------------------------------
1104 -- Eliminate the case if possible
1106 rebuildCase :: SimplEnv
1107 -> OutExpr -- Scrutinee
1108 -> InId -- Case binder
1109 -> [InAlt] -- Alternatives (inceasing order)
1111 -> SimplM (SimplEnv, OutExpr)
1113 --------------------------------------------------
1114 -- 1. Eliminate the case if there's a known constructor
1115 --------------------------------------------------
1117 rebuildCase env scrut case_bndr alts cont
1118 | Just (con,args) <- exprIsConApp_maybe scrut
1119 -- Works when the scrutinee is a variable with a known unfolding
1120 -- as well as when it's an explicit constructor application
1121 = knownCon env scrut (DataAlt con) args case_bndr alts cont
1123 | Lit lit <- scrut -- No need for same treatment as constructors
1124 -- because literals are inlined more vigorously
1125 = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1128 --------------------------------------------------
1129 -- 2. Eliminate the case if scrutinee is evaluated
1130 --------------------------------------------------
1132 rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont
1133 -- See if we can get rid of the case altogether
1134 -- See the extensive notes on case-elimination above
1135 -- mkCase made sure that if all the alternatives are equal,
1136 -- then there is now only one (DEFAULT) rhs
1137 | all isDeadBinder bndrs -- bndrs are [InId]
1139 -- Check that the scrutinee can be let-bound instead of case-bound
1140 , exprOkForSpeculation scrut
1141 -- OK not to evaluate it
1142 -- This includes things like (==# a# b#)::Bool
1143 -- so that we simplify
1144 -- case ==# a# b# of { True -> x; False -> x }
1147 -- This particular example shows up in default methods for
1148 -- comparision operations (e.g. in (>=) for Int.Int32)
1149 || exprIsHNF scrut -- It's already evaluated
1150 || var_demanded_later scrut -- It'll be demanded later
1152 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1153 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1154 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1155 -- its argument: case x of { y -> dataToTag# y }
1156 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1157 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1159 -- Also we don't want to discard 'seq's
1160 = do { tick (CaseElim case_bndr)
1161 ; env <- simplNonRecX env case_bndr scrut
1162 ; simplExprF env rhs cont }
1164 -- The case binder is going to be evaluated later,
1165 -- and the scrutinee is a simple variable
1166 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1167 && not (isTickBoxOp v)
1168 -- ugly hack; covering this case is what
1169 -- exprOkForSpeculation was intended for.
1170 var_demanded_later other = False
1173 --------------------------------------------------
1174 -- 3. Catch-all case
1175 --------------------------------------------------
1177 rebuildCase env scrut case_bndr alts cont
1178 = do { -- Prepare the continuation;
1179 -- The new subst_env is in place
1180 (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1182 -- Simplify the alternatives
1183 ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
1184 ; let res_ty' = contResultType dup_cont
1185 ; case_expr <- mkCase scrut' case_bndr' res_ty' alts'
1187 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1188 -- The case binder *not* scope over the whole returned case-expression
1189 ; rebuild env case_expr nodup_cont }
1192 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1193 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1194 way, there's a chance that v will now only be used once, and hence
1197 Note [no-case-of-case]
1198 ~~~~~~~~~~~~~~~~~~~~~~
1199 There is a time we *don't* want to do that, namely when
1200 -fno-case-of-case is on. This happens in the first simplifier pass,
1201 and enhances full laziness. Here's the bad case:
1202 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1203 If we eliminate the inner case, we trap it inside the I# v -> arm,
1204 which might prevent some full laziness happening. I've seen this
1205 in action in spectral/cichelli/Prog.hs:
1206 [(m,n) | m <- [1..max], n <- [1..max]]
1207 Hence the check for NoCaseOfCase.
1209 Note [Suppressing the case binder-swap]
1210 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1211 There is another situation when it might make sense to suppress the
1212 case-expression binde-swap. If we have
1214 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1215 ...other cases .... }
1217 We'll perform the binder-swap for the outer case, giving
1219 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1220 ...other cases .... }
1222 But there is no point in doing it for the inner case, because w1 can't
1223 be inlined anyway. Furthermore, doing the case-swapping involves
1224 zapping w2's occurrence info (see paragraphs that follow), and that
1225 forces us to bind w2 when doing case merging. So we get
1227 case x of w1 { A -> let w2 = w1 in e1
1228 B -> let w2 = w1 in e2
1229 ...other cases .... }
1231 This is plain silly in the common case where w2 is dead.
1233 Even so, I can't see a good way to implement this idea. I tried
1234 not doing the binder-swap if the scrutinee was already evaluated
1235 but that failed big-time:
1239 case v of w { MkT x ->
1240 case x of x1 { I# y1 ->
1241 case x of x2 { I# y2 -> ...
1243 Notice that because MkT is strict, x is marked "evaluated". But to
1244 eliminate the last case, we must either make sure that x (as well as
1245 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1246 the binder-swap. So this whole note is a no-op.
1250 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1251 any occurrence info (eg IAmDead) in the case binder, because the
1252 case-binder now effectively occurs whenever v does. AND we have to do
1253 the same for the pattern-bound variables! Example:
1255 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1257 Here, b and p are dead. But when we move the argment inside the first
1258 case RHS, and eliminate the second case, we get
1260 case x of { (a,b) -> a b }
1262 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1265 Indeed, this can happen anytime the case binder isn't dead:
1266 case <any> of x { (a,b) ->
1267 case x of { (p,q) -> p } }
1268 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1269 The point is that we bring into the envt a binding
1271 after the outer case, and that makes (a,b) alive. At least we do unless
1272 the case binder is guaranteed dead.
1276 Consider case (v `cast` co) of x { I# ->
1277 ... (case (v `cast` co) of {...}) ...
1278 We'd like to eliminate the inner case. We can get this neatly by
1279 arranging that inside the outer case we add the unfolding
1280 v |-> x `cast` (sym co)
1281 to v. Then we should inline v at the inner case, cancel the casts, and away we go
1283 Note [Improving seq]
1286 type family F :: * -> *
1287 type instance F Int = Int
1289 ... case e of x { DEFAULT -> rhs } ...
1291 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
1293 case e `cast` co of x'::Int
1294 I# x# -> let x = x' `cast` sym co
1297 so that 'rhs' can take advantage of hte form of x'. Notice that Note
1298 [Case of cast] may then apply to the result.
1300 This showed up in Roman's experiments. Example:
1301 foo :: F Int -> Int -> Int
1302 foo t n = t `seq` bar n
1305 bar n = bar (n - case t of TI i -> i)
1306 Here we'd like to avoid repeated evaluating t inside the loop, by
1307 taking advantage of the `seq`.
1309 At one point I did transformation in LiberateCase, but it's more robust here.
1310 (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
1311 LiberateCase gets to see it.)
1313 Note [Case elimination]
1314 ~~~~~~~~~~~~~~~~~~~~~~~
1315 The case-elimination transformation discards redundant case expressions.
1316 Start with a simple situation:
1318 case x# of ===> e[x#/y#]
1321 (when x#, y# are of primitive type, of course). We can't (in general)
1322 do this for algebraic cases, because we might turn bottom into
1325 The code in SimplUtils.prepareAlts has the effect of generalise this
1326 idea to look for a case where we're scrutinising a variable, and we
1327 know that only the default case can match. For example:
1331 DEFAULT -> ...(case x of
1335 Here the inner case is first trimmed to have only one alternative, the
1336 DEFAULT, after which it's an instance of the previous case. This
1337 really only shows up in eliminating error-checking code.
1339 We also make sure that we deal with this very common case:
1344 Here we are using the case as a strict let; if x is used only once
1345 then we want to inline it. We have to be careful that this doesn't
1346 make the program terminate when it would have diverged before, so we
1348 - e is already evaluated (it may so if e is a variable)
1349 - x is used strictly, or
1351 Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
1353 case e of ===> case e of DEFAULT -> r
1357 Now again the case may be elminated by the CaseElim transformation.
1360 Further notes about case elimination
1361 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1362 Consider: test :: Integer -> IO ()
1365 Turns out that this compiles to:
1368 eta1 :: State# RealWorld ->
1369 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1371 (PrelNum.jtos eta ($w[] @ Char))
1373 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1375 Notice the strange '<' which has no effect at all. This is a funny one.
1376 It started like this:
1378 f x y = if x < 0 then jtos x
1379 else if y==0 then "" else jtos x
1381 At a particular call site we have (f v 1). So we inline to get
1383 if v < 0 then jtos x
1384 else if 1==0 then "" else jtos x
1386 Now simplify the 1==0 conditional:
1388 if v<0 then jtos v else jtos v
1390 Now common-up the two branches of the case:
1392 case (v<0) of DEFAULT -> jtos v
1394 Why don't we drop the case? Because it's strict in v. It's technically
1395 wrong to drop even unnecessary evaluations, and in practice they
1396 may be a result of 'seq' so we *definitely* don't want to drop those.
1397 I don't really know how to improve this situation.
1401 simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
1402 -> SimplM (SimplEnv, OutExpr, OutId)
1403 simplCaseBinder env scrut case_bndr alts
1404 = do { (env1, case_bndr1) <- simplBinder env case_bndr
1406 ; fam_envs <- getFamEnvs
1407 ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut
1408 case_bndr case_bndr1 alts
1409 -- Note [Improving seq]
1411 ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
1412 -- Note [Case of cast]
1414 ; return (env3, scrut2, case_bndr3) }
1417 improve_seq fam_envs env1 scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1418 | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1419 = do { case_bndr2 <- newId FSLIT("nt") ty2
1420 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1421 env2 = extendIdSubst env1 case_bndr rhs
1422 ; return (env2, scrut `Cast` co, case_bndr2) }
1424 improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts
1425 = return (env1, scrut, case_bndr1)
1428 improve_case_bndr env scrut case_bndr
1429 | switchIsOn (getSwitchChecker env) NoCaseOfCase
1430 -- See Note [no-case-of-case]
1433 | otherwise -- Failed try [see Note 2 above]
1434 -- not (isEvaldUnfolding (idUnfolding v))
1436 Var v -> (modifyInScope env1 v case_bndr', case_bndr')
1437 -- Note about using modifyInScope for v here
1438 -- We could extend the substitution instead, but it would be
1439 -- a hack because then the substitution wouldn't be idempotent
1440 -- any more (v is an OutId). And this does just as well.
1442 Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
1444 rhs = Cast (Var case_bndr') (mkSymCoercion co)
1446 other -> (env, case_bndr)
1448 case_bndr' = zapOccInfo case_bndr
1449 env1 = modifyInScope env case_bndr case_bndr'
1452 zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
1453 zapOccInfo b = b `setIdOccInfo` NoOccInfo
1457 simplAlts does two things:
1459 1. Eliminate alternatives that cannot match, including the
1460 DEFAULT alternative.
1462 2. If the DEFAULT alternative can match only one possible constructor,
1463 then make that constructor explicit.
1465 case e of x { DEFAULT -> rhs }
1467 case e of x { (a,b) -> rhs }
1468 where the type is a single constructor type. This gives better code
1469 when rhs also scrutinises x or e.
1471 Here "cannot match" includes knowledge from GADTs
1473 It's a good idea do do this stuff before simplifying the alternatives, to
1474 avoid simplifying alternatives we know can't happen, and to come up with
1475 the list of constructors that are handled, to put into the IdInfo of the
1476 case binder, for use when simplifying the alternatives.
1478 Eliminating the default alternative in (1) isn't so obvious, but it can
1481 data Colour = Red | Green | Blue
1490 DEFAULT -> [ case y of ... ]
1492 If we inline h into f, the default case of the inlined h can't happen.
1493 If we don't notice this, we may end up filtering out *all* the cases
1494 of the inner case y, which give us nowhere to go!
1498 simplAlts :: SimplEnv
1500 -> InId -- Case binder
1501 -> [InAlt] -> SimplCont
1502 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
1503 -- Like simplExpr, this just returns the simplified alternatives;
1504 -- it not return an environment
1506 simplAlts env scrut case_bndr alts cont'
1507 = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1508 do { let alt_env = zapFloats env
1509 ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
1511 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts
1513 ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
1514 ; return (scrut', case_bndr', alts') }
1516 ------------------------------------
1517 simplAlt :: SimplEnv
1518 -> [AltCon] -- These constructors can't be present when
1519 -- matching the DEFAULT alternative
1520 -> OutId -- The case binder
1525 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1526 = ASSERT( null bndrs )
1527 do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1528 -- Record the constructors that the case-binder *can't* be.
1529 ; rhs' <- simplExprC env' rhs cont'
1530 ; return (DEFAULT, [], rhs') }
1532 simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
1533 = ASSERT( null bndrs )
1534 do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1535 ; rhs' <- simplExprC env' rhs cont'
1536 ; return (LitAlt lit, [], rhs') }
1538 simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
1539 = do { -- Deal with the pattern-bound variables
1540 (env, vs') <- simplBinders env (add_evals con vs)
1542 -- Mark the ones that are in ! positions in the
1543 -- data constructor as certainly-evaluated.
1544 ; let vs'' = add_evals con vs'
1546 -- Bind the case-binder to (con args)
1547 ; let inst_tys' = tyConAppArgs (idType case_bndr')
1548 con_args = map Type inst_tys' ++ varsToCoreExprs vs''
1549 env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
1551 ; rhs' <- simplExprC env' rhs cont'
1552 ; return (DataAlt con, vs'', rhs') }
1554 -- add_evals records the evaluated-ness of the bound variables of
1555 -- a case pattern. This is *important*. Consider
1556 -- data T = T !Int !Int
1558 -- case x of { T a b -> T (a+1) b }
1560 -- We really must record that b is already evaluated so that we don't
1561 -- go and re-evaluate it when constructing the result.
1562 -- See Note [Data-con worker strictness] in MkId.lhs
1563 add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
1565 cat_evals dc vs strs
1569 go (v:vs) strs | isTyVar v = v : go vs strs
1570 go (v:vs) (str:strs)
1571 | isMarkedStrict str = evald_v : go vs strs
1572 | otherwise = zapped_v : go vs strs
1574 zapped_v = zap_occ_info v
1575 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
1576 go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
1578 -- If the case binder is alive, then we add the unfolding
1580 -- to the envt; so vs are now very much alive
1581 -- Note [Aug06] I can't see why this actually matters
1582 zap_occ_info | isDeadBinder case_bndr' = \id -> id
1583 | otherwise = zapOccInfo
1585 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1586 addBinderUnfolding env bndr rhs
1587 = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
1589 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1590 addBinderOtherCon env bndr cons
1591 = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
1595 %************************************************************************
1597 \subsection{Known constructor}
1599 %************************************************************************
1601 We are a bit careful with occurrence info. Here's an example
1603 (\x* -> case x of (a*, b) -> f a) (h v, e)
1605 where the * means "occurs once". This effectively becomes
1606 case (h v, e) of (a*, b) -> f a)
1608 let a* = h v; b = e in f a
1612 All this should happen in one sweep.
1615 knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
1616 -> InId -> [InAlt] -> SimplCont
1617 -> SimplM (SimplEnv, OutExpr)
1619 knownCon env scrut con args bndr alts cont
1620 = do { tick (KnownBranch bndr)
1621 ; knownAlt env scrut args bndr (findAlt con alts) cont }
1623 knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont
1625 do { env <- simplNonRecX env bndr scrut
1626 -- This might give rise to a binding with non-atomic args
1627 -- like x = Node (f x) (g x)
1628 -- but simplNonRecX will atomic-ify it
1629 ; simplExprF env rhs cont }
1631 knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont
1633 do { env <- simplNonRecX env bndr scrut
1634 ; simplExprF env rhs cont }
1636 knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont
1637 = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId
1638 n_drop_tys = length (dataConUnivTyVars dc)
1639 ; env <- bind_args env dead_bndr bs (drop n_drop_tys args)
1641 -- It's useful to bind bndr to scrut, rather than to a fresh
1642 -- binding x = Con arg1 .. argn
1643 -- because very often the scrut is a variable, so we avoid
1644 -- creating, and then subsequently eliminating, a let-binding
1645 -- BUT, if scrut is a not a variable, we must be careful
1646 -- about duplicating the arg redexes; in that case, make
1647 -- a new con-app from the args
1648 bndr_rhs = case scrut of
1651 con_app = mkConApp dc (take n_drop_tys args ++ con_args)
1652 con_args = [substExpr env (varToCoreExpr b) | b <- bs]
1653 -- args are aready OutExprs, but bs are InIds
1655 ; env <- simplNonRecX env bndr bndr_rhs
1656 ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $
1657 simplExprF env rhs cont }
1660 bind_args env dead_bndr [] _ = return env
1662 bind_args env dead_bndr (b:bs) (Type ty : args)
1663 = ASSERT( isTyVar b )
1664 bind_args (extendTvSubst env b ty) dead_bndr bs args
1666 bind_args env dead_bndr (b:bs) (arg : args)
1668 do { let b' = if dead_bndr then b else zapOccInfo b
1669 -- Note that the binder might be "dead", because it doesn't occur
1670 -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
1671 -- Nevertheless we must keep it if the case-binder is alive, because it may
1672 -- be used in the con_app. See Note [zapOccInfo]
1673 ; env <- simplNonRecX env b' arg
1674 ; bind_args env dead_bndr bs args }
1676 bind_args _ _ _ _ = panic "bind_args"
1680 %************************************************************************
1682 \subsection{Duplicating continuations}
1684 %************************************************************************
1687 prepareCaseCont :: SimplEnv
1688 -> [InAlt] -> SimplCont
1689 -> SimplM (SimplEnv, SimplCont,SimplCont)
1690 -- Return a duplicatable continuation, a non-duplicable part
1691 -- plus some extra bindings (that scope over the entire
1694 -- No need to make it duplicatable if there's only one alternative
1695 prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont))
1696 prepareCaseCont env alts cont = mkDupableCont env cont
1700 mkDupableCont :: SimplEnv -> SimplCont
1701 -> SimplM (SimplEnv, SimplCont, SimplCont)
1703 mkDupableCont env cont
1704 | contIsDupable cont
1705 = returnSmpl (env, cont, mkBoringStop (contResultType cont))
1707 mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
1709 mkDupableCont env (CoerceIt ty cont)
1710 = do { (env, dup, nodup) <- mkDupableCont env cont
1711 ; return (env, CoerceIt ty dup, nodup) }
1713 mkDupableCont env cont@(StrictBind bndr _ _ se _)
1714 = return (env, mkBoringStop (substTy se (idType bndr)), cont)
1715 -- See Note [Duplicating strict continuations]
1717 mkDupableCont env cont@(StrictArg _ fun_ty _ _)
1718 = return (env, mkBoringStop (funArgTy fun_ty), cont)
1719 -- See Note [Duplicating strict continuations]
1721 mkDupableCont env (ApplyTo _ arg se cont)
1722 = -- e.g. [...hole...] (...arg...)
1724 -- let a = ...arg...
1725 -- in [...hole...] a
1726 do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1727 ; arg <- simplExpr (se `setInScope` env) arg
1728 ; (env, arg) <- makeTrivial env arg
1729 ; let app_cont = ApplyTo OkToDup arg (zapSubstEnv env) dup_cont
1730 ; return (env, app_cont, nodup_cont) }
1732 mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont)
1733 -- See Note [Single-alternative case]
1734 -- | not (exprIsDupable rhs && contIsDupable case_cont)
1735 -- | not (isDeadBinder case_bndr)
1736 | all isDeadBinder bs -- InIds
1737 = return (env, mkBoringStop scrut_ty, cont)
1739 scrut_ty = substTy se (idType case_bndr)
1741 mkDupableCont env (Select _ case_bndr alts se cont)
1742 = -- e.g. (case [...hole...] of { pi -> ei })
1744 -- let ji = \xij -> ei
1745 -- in case [...hole...] of { pi -> ji xij }
1746 do { tick (CaseOfCase case_bndr)
1747 ; (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1748 -- NB: call mkDupableCont here, *not* prepareCaseCont
1749 -- We must make a duplicable continuation, whereas prepareCaseCont
1750 -- doesn't when there is a single case branch
1752 ; let alt_env = se `setInScope` env
1753 ; (alt_env, case_bndr') <- simplBinder alt_env case_bndr
1754 ; alts' <- mapM (simplAlt alt_env [] case_bndr' dup_cont) alts
1755 -- Safe to say that there are no handled-cons for the DEFAULT case
1756 -- NB: simplBinder does not zap deadness occ-info, so
1757 -- a dead case_bndr' will still advertise its deadness
1758 -- This is really important because in
1759 -- case e of b { (# p,q #) -> ... }
1760 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1761 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1762 -- In the new alts we build, we have the new case binder, so it must retain
1764 -- NB: we don't use alt_env further; it has the substEnv for
1765 -- the alternatives, and we don't want that
1767 ; (env, alts') <- mkDupableAlts env case_bndr' alts'
1768 ; return (env, -- Note [Duplicated env]
1769 Select OkToDup case_bndr' alts' (zapSubstEnv env)
1770 (mkBoringStop (contResultType dup_cont)),
1774 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1775 -> SimplM (SimplEnv, [InAlt])
1776 -- Absorbs the continuation into the new alternatives
1778 mkDupableAlts env case_bndr' alts
1781 go env [] = return (env, [])
1783 = do { (env, alt') <- mkDupableAlt env case_bndr' alt
1784 ; (env, alts') <- go env alts
1785 ; return (env, alt' : alts' ) }
1787 mkDupableAlt env case_bndr' (con, bndrs', rhs')
1788 | exprIsDupable rhs' -- Note [Small alternative rhs]
1789 = return (env, (con, bndrs', rhs'))
1791 = do { let rhs_ty' = exprType rhs'
1792 used_bndrs' = filter abstract_over (case_bndr' : bndrs')
1794 | isTyVar bndr = True -- Abstract over all type variables just in case
1795 | otherwise = not (isDeadBinder bndr)
1796 -- The deadness info on the new Ids is preserved by simplBinders
1798 ; (final_bndrs', final_args) -- Note [Join point abstraction]
1799 <- if (any isId used_bndrs')
1800 then return (used_bndrs', varsToCoreExprs used_bndrs')
1801 else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy
1802 ; return ([rw_id], [Var realWorldPrimId]) }
1804 ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty')
1805 -- Note [Funky mkPiTypes]
1807 ; let -- We make the lambdas into one-shot-lambdas. The
1808 -- join point is sure to be applied at most once, and doing so
1809 -- prevents the body of the join point being floated out by
1810 -- the full laziness pass
1811 really_final_bndrs = map one_shot final_bndrs'
1812 one_shot v | isId v = setOneShotLambda v
1814 join_rhs = mkLams really_final_bndrs rhs'
1815 join_call = mkApps (Var join_bndr) final_args
1817 ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
1818 -- See Note [Duplicated env]
1821 Note [Duplicated env]
1822 ~~~~~~~~~~~~~~~~~~~~~
1823 Some of the alternatives are simplified, but have not been turned into a join point
1824 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
1825 bind the join point, because it might to do PostInlineUnconditionally, and
1826 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
1827 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1828 at worst delays the join-point inlining.
1830 Note [Small alterantive rhs]
1831 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1832 It is worth checking for a small RHS because otherwise we
1833 get extra let bindings that may cause an extra iteration of the simplifier to
1834 inline back in place. Quite often the rhs is just a variable or constructor.
1835 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1836 iterations because the version with the let bindings looked big, and so wasn't
1837 inlined, but after the join points had been inlined it looked smaller, and so
1840 NB: we have to check the size of rhs', not rhs.
1841 Duplicating a small InAlt might invalidate occurrence information
1842 However, if it *is* dupable, we return the *un* simplified alternative,
1843 because otherwise we'd need to pair it up with an empty subst-env....
1844 but we only have one env shared between all the alts.
1845 (Remember we must zap the subst-env before re-simplifying something).
1846 Rather than do this we simply agree to re-simplify the original (small) thing later.
1848 Note [Funky mkPiTypes]
1849 ~~~~~~~~~~~~~~~~~~~~~~
1850 Notice the funky mkPiTypes. If the contructor has existentials
1851 it's possible that the join point will be abstracted over
1852 type varaibles as well as term variables.
1853 Example: Suppose we have
1854 data T = forall t. C [t]
1856 case (case e of ...) of
1858 We get the join point
1859 let j :: forall t. [t] -> ...
1860 j = /\t \xs::[t] -> rhs
1862 case (case e of ...) of
1863 C t xs::[t] -> j t xs
1865 Note [Join point abstaction]
1866 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1867 If we try to lift a primitive-typed something out
1868 for let-binding-purposes, we will *caseify* it (!),
1869 with potentially-disastrous strictness results. So
1870 instead we turn it into a function: \v -> e
1871 where v::State# RealWorld#. The value passed to this function
1872 is realworld#, which generates (almost) no code.
1874 There's a slight infelicity here: we pass the overall
1875 case_bndr to all the join points if it's used in *any* RHS,
1876 because we don't know its usage in each RHS separately
1878 We used to say "&& isUnLiftedType rhs_ty'" here, but now
1879 we make the join point into a function whenever used_bndrs'
1880 is empty. This makes the join-point more CPR friendly.
1881 Consider: let j = if .. then I# 3 else I# 4
1882 in case .. of { A -> j; B -> j; C -> ... }
1884 Now CPR doesn't w/w j because it's a thunk, so
1885 that means that the enclosing function can't w/w either,
1886 which is a lose. Here's the example that happened in practice:
1887 kgmod :: Int -> Int -> Int
1888 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1892 I have seen a case alternative like this:
1894 It's a bit silly to add the realWorld dummy arg in this case, making
1897 (the \v alone is enough to make CPR happy) but I think it's rare
1899 Note [Duplicating strict continuations]
1900 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1901 Do *not* duplicate StrictBind and StritArg continuations. We gain
1902 nothing by propagating them into the expressions, and we do lose a
1903 lot. Here's an example:
1904 && (case x of { T -> F; F -> T }) E
1905 Now, && is strict so we end up simplifying the case with
1906 an ArgOf continuation. If we let-bind it, we get
1908 let $j = \v -> && v E
1909 in simplExpr (case x of { T -> F; F -> T })
1911 And after simplifying more we get
1913 let $j = \v -> && v E
1914 in case x of { T -> $j F; F -> $j T }
1915 Which is a Very Bad Thing
1917 The desire not to duplicate is the entire reason that
1918 mkDupableCont returns a pair of continuations.
1920 The original plan had:
1921 e.g. (...strict-fn...) [...hole...]
1923 let $j = \a -> ...strict-fn...
1926 Note [Single-alternative cases]
1927 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1928 This case is just like the ArgOf case. Here's an example:
1932 case (case x of I# x' ->
1934 True -> I# (negate# x')
1935 False -> I# x') of y {
1937 Because the (case x) has only one alternative, we'll transform to
1939 case (case x' <# 0# of
1940 True -> I# (negate# x')
1941 False -> I# x') of y {
1943 But now we do *NOT* want to make a join point etc, giving
1945 let $j = \y -> MkT y
1947 True -> $j (I# (negate# x'))
1949 In this case the $j will inline again, but suppose there was a big
1950 strict computation enclosing the orginal call to MkT. Then, it won't
1951 "see" the MkT any more, because it's big and won't get duplicated.
1952 And, what is worse, nothing was gained by the case-of-case transform.
1954 When should use this case of mkDupableCont?
1955 However, matching on *any* single-alternative case is a *disaster*;
1956 e.g. case (case ....) of (a,b) -> (# a,b #)
1957 We must push the outer case into the inner one!
1960 * Match [(DEFAULT,_,_)], but in the common case of Int,
1961 the alternative-filling-in code turned the outer case into
1962 case (...) of y { I# _ -> MkT y }
1964 * Match on single alternative plus (not (isDeadBinder case_bndr))
1965 Rationale: pushing the case inwards won't eliminate the construction.
1966 But there's a risk of
1967 case (...) of y { (a,b) -> let z=(a,b) in ... }
1968 Now y looks dead, but it'll come alive again. Still, this
1969 seems like the best option at the moment.
1971 * Match on single alternative plus (all (isDeadBinder bndrs))
1972 Rationale: this is essentially seq.
1974 * Match when the rhs is *not* duplicable, and hence would lead to a
1975 join point. This catches the disaster-case above. We can test
1976 the *un-simplified* rhs, which is fine. It might get bigger or
1977 smaller after simplification; if it gets smaller, this case might
1978 fire next time round. NB also that we must test contIsDupable
1979 case_cont *btoo, because case_cont might be big!
1981 HOWEVER: I found that this version doesn't work well, because
1982 we can get let x = case (...) of { small } in ...case x...
1983 When x is inlined into its full context, we find that it was a bad
1984 idea to have pushed the outer case inside the (...) case.