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 -- You might think that we shouldn't apply rules for a loop breaker:
956 -- doing so might give rise to an infinite loop, because a RULE is
957 -- rather like an extra equation for the function:
958 -- RULE: f (g x) y = x+y
961 -- But it's too drastic to disable rules for loop breakers.
962 -- Even the foldr/build rule would be disabled, because foldr
963 -- is recursive, and hence a loop breaker:
964 -- foldr k z (build g) = g k z
965 -- So it's up to the programmer: rules can cause divergence
967 ; let in_scope = getInScope env
968 maybe_rule = case activeRule dflags env of
969 Nothing -> Nothing -- No rules apply
970 Just act_fn -> lookupRule act_fn in_scope
972 ; case maybe_rule of {
973 Just (rule, rule_rhs) ->
974 tick (RuleFired (ru_name rule)) `thenSmpl_`
975 (if dopt Opt_D_dump_rule_firings dflags then
976 pprTrace "Rule fired" (vcat [
977 text "Rule:" <+> ftext (ru_name rule),
978 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
979 text "After: " <+> pprCoreExpr rule_rhs,
980 text "Cont: " <+> ppr call_cont])
983 simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
984 -- The ruleArity says how many args the rule consumed
986 ; Nothing -> do -- No rules
988 ------------- Next try inlining ----------------
989 { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
990 n_val_args = length arg_infos
991 interesting_cont = interestingCallContext (notNull args)
994 active_inline = activeInline env var
995 maybe_inline = callSiteInline dflags active_inline
996 var arg_infos interesting_cont
997 ; case maybe_inline of {
998 Just unfolding -- There is an inlining!
999 -> do { tick (UnfoldingDone var)
1000 ; (if dopt Opt_D_dump_inlinings dflags then
1001 pprTrace "Inlining done" (vcat [
1002 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1003 text "Inlined fn: " <+> nest 2 (ppr unfolding),
1004 text "Cont: " <+> ppr call_cont])
1007 simplExprF env unfolding cont }
1009 ; Nothing -> -- No inlining!
1011 ------------- No inlining! ----------------
1012 -- Next, look for rules or specialisations that match
1014 rebuildCall env (Var var) (idType var)
1015 (mkArgInfo var n_val_args call_cont) cont
1018 rebuildCall :: SimplEnv
1019 -> OutExpr -> OutType -- Function and its type
1020 -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo
1022 -> SimplM (SimplEnv, OutExpr)
1023 rebuildCall env fun fun_ty (has_rules, []) cont
1024 -- When we run out of strictness args, it means
1025 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1026 -- Then we want to discard the entire strict continuation. E.g.
1027 -- * case (error "hello") of { ... }
1028 -- * (error "Hello") arg
1029 -- * f (error "Hello") where f is strict
1031 -- Then, especially in the first of these cases, we'd like to discard
1032 -- the continuation, leaving just the bottoming expression. But the
1033 -- type might not be right, so we may have to add a coerce.
1034 | not (contIsTrivial cont) -- Only do this if there is a non-trivial
1035 = return (env, mk_coerce fun) -- contination to discard, else we do it
1036 where -- again and again!
1037 cont_ty = contResultType cont
1038 co = mkUnsafeCoercion fun_ty cont_ty
1039 mk_coerce expr | cont_ty `coreEqType` fun_ty = fun
1040 | otherwise = mkCoerce co fun
1042 rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont)
1043 = do { ty' <- simplType (se `setInScope` env) arg_ty
1044 ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont }
1046 rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont)
1047 | str || isStrictType arg_ty -- Strict argument
1048 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1049 simplExprF (arg_se `setFloats` env) arg
1050 (StrictArg fun fun_ty (has_rules, strs) cont)
1053 | otherwise -- Lazy argument
1054 -- DO NOT float anything outside, hence simplExprC
1055 -- There is no benefit (unlike in a let-binding), and we'd
1056 -- have to be very careful about bogus strictness through
1057 -- floating a demanded let.
1058 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1059 (mkLazyArgStop arg_ty has_rules)
1060 ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont }
1062 (arg_ty, res_ty) = splitFunTy fun_ty
1064 rebuildCall env fun fun_ty info cont
1065 = rebuild env fun cont
1070 This part of the simplifier may break the no-shadowing invariant
1072 f (...(\a -> e)...) (case y of (a,b) -> e')
1073 where f is strict in its second arg
1074 If we simplify the innermost one first we get (...(\a -> e)...)
1075 Simplifying the second arg makes us float the case out, so we end up with
1076 case y of (a,b) -> f (...(\a -> e)...) e'
1077 So the output does not have the no-shadowing invariant. However, there is
1078 no danger of getting name-capture, because when the first arg was simplified
1079 we used an in-scope set that at least mentioned all the variables free in its
1080 static environment, and that is enough.
1082 We can't just do innermost first, or we'd end up with a dual problem:
1083 case x of (a,b) -> f e (...(\a -> e')...)
1085 I spent hours trying to recover the no-shadowing invariant, but I just could
1086 not think of an elegant way to do it. The simplifier is already knee-deep in
1087 continuations. We have to keep the right in-scope set around; AND we have
1088 to get the effect that finding (error "foo") in a strict arg position will
1089 discard the entire application and replace it with (error "foo"). Getting
1090 all this at once is TOO HARD!
1092 %************************************************************************
1094 Rebuilding a cse expression
1096 %************************************************************************
1098 Blob of helper functions for the "case-of-something-else" situation.
1101 ---------------------------------------------------------
1102 -- Eliminate the case if possible
1104 rebuildCase :: SimplEnv
1105 -> OutExpr -- Scrutinee
1106 -> InId -- Case binder
1107 -> [InAlt] -- Alternatives (inceasing order)
1109 -> SimplM (SimplEnv, OutExpr)
1111 --------------------------------------------------
1112 -- 1. Eliminate the case if there's a known constructor
1113 --------------------------------------------------
1115 rebuildCase env scrut case_bndr alts cont
1116 | Just (con,args) <- exprIsConApp_maybe scrut
1117 -- Works when the scrutinee is a variable with a known unfolding
1118 -- as well as when it's an explicit constructor application
1119 = knownCon env scrut (DataAlt con) args case_bndr alts cont
1121 | Lit lit <- scrut -- No need for same treatment as constructors
1122 -- because literals are inlined more vigorously
1123 = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1126 --------------------------------------------------
1127 -- 2. Eliminate the case if scrutinee is evaluated
1128 --------------------------------------------------
1130 rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont
1131 -- See if we can get rid of the case altogether
1132 -- See the extensive notes on case-elimination above
1133 -- mkCase made sure that if all the alternatives are equal,
1134 -- then there is now only one (DEFAULT) rhs
1135 | all isDeadBinder bndrs -- bndrs are [InId]
1137 -- Check that the scrutinee can be let-bound instead of case-bound
1138 , exprOkForSpeculation scrut
1139 -- OK not to evaluate it
1140 -- This includes things like (==# a# b#)::Bool
1141 -- so that we simplify
1142 -- case ==# a# b# of { True -> x; False -> x }
1145 -- This particular example shows up in default methods for
1146 -- comparision operations (e.g. in (>=) for Int.Int32)
1147 || exprIsHNF scrut -- It's already evaluated
1148 || var_demanded_later scrut -- It'll be demanded later
1150 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1151 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1152 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1153 -- its argument: case x of { y -> dataToTag# y }
1154 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1155 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1157 -- Also we don't want to discard 'seq's
1158 = do { tick (CaseElim case_bndr)
1159 ; env <- simplNonRecX env case_bndr scrut
1160 ; simplExprF env rhs cont }
1162 -- The case binder is going to be evaluated later,
1163 -- and the scrutinee is a simple variable
1164 var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1165 && not (isTickBoxOp v)
1166 -- ugly hack; covering this case is what
1167 -- exprOkForSpeculation was intended for.
1168 var_demanded_later other = False
1171 --------------------------------------------------
1172 -- 3. Catch-all case
1173 --------------------------------------------------
1175 rebuildCase env scrut case_bndr alts cont
1176 = do { -- Prepare the continuation;
1177 -- The new subst_env is in place
1178 (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1180 -- Simplify the alternatives
1181 ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
1182 ; let res_ty' = contResultType dup_cont
1183 ; case_expr <- mkCase scrut' case_bndr' res_ty' alts'
1185 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1186 -- The case binder *not* scope over the whole returned case-expression
1187 ; rebuild env case_expr nodup_cont }
1190 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1191 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1192 way, there's a chance that v will now only be used once, and hence
1195 Note [no-case-of-case]
1196 ~~~~~~~~~~~~~~~~~~~~~~
1197 There is a time we *don't* want to do that, namely when
1198 -fno-case-of-case is on. This happens in the first simplifier pass,
1199 and enhances full laziness. Here's the bad case:
1200 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1201 If we eliminate the inner case, we trap it inside the I# v -> arm,
1202 which might prevent some full laziness happening. I've seen this
1203 in action in spectral/cichelli/Prog.hs:
1204 [(m,n) | m <- [1..max], n <- [1..max]]
1205 Hence the check for NoCaseOfCase.
1207 Note [Suppressing the case binder-swap]
1208 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1209 There is another situation when it might make sense to suppress the
1210 case-expression binde-swap. If we have
1212 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1213 ...other cases .... }
1215 We'll perform the binder-swap for the outer case, giving
1217 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1218 ...other cases .... }
1220 But there is no point in doing it for the inner case, because w1 can't
1221 be inlined anyway. Furthermore, doing the case-swapping involves
1222 zapping w2's occurrence info (see paragraphs that follow), and that
1223 forces us to bind w2 when doing case merging. So we get
1225 case x of w1 { A -> let w2 = w1 in e1
1226 B -> let w2 = w1 in e2
1227 ...other cases .... }
1229 This is plain silly in the common case where w2 is dead.
1231 Even so, I can't see a good way to implement this idea. I tried
1232 not doing the binder-swap if the scrutinee was already evaluated
1233 but that failed big-time:
1237 case v of w { MkT x ->
1238 case x of x1 { I# y1 ->
1239 case x of x2 { I# y2 -> ...
1241 Notice that because MkT is strict, x is marked "evaluated". But to
1242 eliminate the last case, we must either make sure that x (as well as
1243 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1244 the binder-swap. So this whole note is a no-op.
1248 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1249 any occurrence info (eg IAmDead) in the case binder, because the
1250 case-binder now effectively occurs whenever v does. AND we have to do
1251 the same for the pattern-bound variables! Example:
1253 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1255 Here, b and p are dead. But when we move the argment inside the first
1256 case RHS, and eliminate the second case, we get
1258 case x of { (a,b) -> a b }
1260 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1263 Indeed, this can happen anytime the case binder isn't dead:
1264 case <any> of x { (a,b) ->
1265 case x of { (p,q) -> p } }
1266 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1267 The point is that we bring into the envt a binding
1269 after the outer case, and that makes (a,b) alive. At least we do unless
1270 the case binder is guaranteed dead.
1274 Consider case (v `cast` co) of x { I# ->
1275 ... (case (v `cast` co) of {...}) ...
1276 We'd like to eliminate the inner case. We can get this neatly by
1277 arranging that inside the outer case we add the unfolding
1278 v |-> x `cast` (sym co)
1279 to v. Then we should inline v at the inner case, cancel the casts, and away we go
1281 Note [Improving seq]
1284 type family F :: * -> *
1285 type instance F Int = Int
1287 ... case e of x { DEFAULT -> rhs } ...
1289 where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
1291 case e `cast` co of x'::Int
1292 I# x# -> let x = x' `cast` sym co
1295 so that 'rhs' can take advantage of hte form of x'. Notice that Note
1296 [Case of cast] may then apply to the result.
1298 This showed up in Roman's experiments. Example:
1299 foo :: F Int -> Int -> Int
1300 foo t n = t `seq` bar n
1303 bar n = bar (n - case t of TI i -> i)
1304 Here we'd like to avoid repeated evaluating t inside the loop, by
1305 taking advantage of the `seq`.
1307 At one point I did transformation in LiberateCase, but it's more robust here.
1308 (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
1309 LiberateCase gets to see it.)
1311 Note [Case elimination]
1312 ~~~~~~~~~~~~~~~~~~~~~~~
1313 The case-elimination transformation discards redundant case expressions.
1314 Start with a simple situation:
1316 case x# of ===> e[x#/y#]
1319 (when x#, y# are of primitive type, of course). We can't (in general)
1320 do this for algebraic cases, because we might turn bottom into
1323 The code in SimplUtils.prepareAlts has the effect of generalise this
1324 idea to look for a case where we're scrutinising a variable, and we
1325 know that only the default case can match. For example:
1329 DEFAULT -> ...(case x of
1333 Here the inner case is first trimmed to have only one alternative, the
1334 DEFAULT, after which it's an instance of the previous case. This
1335 really only shows up in eliminating error-checking code.
1337 We also make sure that we deal with this very common case:
1342 Here we are using the case as a strict let; if x is used only once
1343 then we want to inline it. We have to be careful that this doesn't
1344 make the program terminate when it would have diverged before, so we
1346 - e is already evaluated (it may so if e is a variable)
1347 - x is used strictly, or
1349 Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
1351 case e of ===> case e of DEFAULT -> r
1355 Now again the case may be elminated by the CaseElim transformation.
1358 Further notes about case elimination
1359 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1360 Consider: test :: Integer -> IO ()
1363 Turns out that this compiles to:
1366 eta1 :: State# RealWorld ->
1367 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1369 (PrelNum.jtos eta ($w[] @ Char))
1371 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
1373 Notice the strange '<' which has no effect at all. This is a funny one.
1374 It started like this:
1376 f x y = if x < 0 then jtos x
1377 else if y==0 then "" else jtos x
1379 At a particular call site we have (f v 1). So we inline to get
1381 if v < 0 then jtos x
1382 else if 1==0 then "" else jtos x
1384 Now simplify the 1==0 conditional:
1386 if v<0 then jtos v else jtos v
1388 Now common-up the two branches of the case:
1390 case (v<0) of DEFAULT -> jtos v
1392 Why don't we drop the case? Because it's strict in v. It's technically
1393 wrong to drop even unnecessary evaluations, and in practice they
1394 may be a result of 'seq' so we *definitely* don't want to drop those.
1395 I don't really know how to improve this situation.
1399 simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
1400 -> SimplM (SimplEnv, OutExpr, OutId)
1401 simplCaseBinder env scrut case_bndr alts
1402 = do { (env1, case_bndr1) <- simplBinder env case_bndr
1404 ; fam_envs <- getFamEnvs
1405 ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut
1406 case_bndr case_bndr1 alts
1407 -- Note [Improving seq]
1409 ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
1410 -- Note [Case of cast]
1412 ; return (env3, scrut2, case_bndr3) }
1415 improve_seq fam_envs env1 scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1416 | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1417 = do { case_bndr2 <- newId FSLIT("nt") ty2
1418 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1419 env2 = extendIdSubst env1 case_bndr rhs
1420 ; return (env2, scrut `Cast` co, case_bndr2) }
1422 improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts
1423 = return (env1, scrut, case_bndr1)
1426 improve_case_bndr env scrut case_bndr
1427 | switchIsOn (getSwitchChecker env) NoCaseOfCase
1428 -- See Note [no-case-of-case]
1431 | otherwise -- Failed try [see Note 2 above]
1432 -- not (isEvaldUnfolding (idUnfolding v))
1434 Var v -> (modifyInScope env1 v case_bndr', case_bndr')
1435 -- Note about using modifyInScope for v here
1436 -- We could extend the substitution instead, but it would be
1437 -- a hack because then the substitution wouldn't be idempotent
1438 -- any more (v is an OutId). And this does just as well.
1440 Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
1442 rhs = Cast (Var case_bndr') (mkSymCoercion co)
1444 other -> (env, case_bndr)
1446 case_bndr' = zapOccInfo case_bndr
1447 env1 = modifyInScope env case_bndr case_bndr'
1450 zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
1451 zapOccInfo b = b `setIdOccInfo` NoOccInfo
1455 simplAlts does two things:
1457 1. Eliminate alternatives that cannot match, including the
1458 DEFAULT alternative.
1460 2. If the DEFAULT alternative can match only one possible constructor,
1461 then make that constructor explicit.
1463 case e of x { DEFAULT -> rhs }
1465 case e of x { (a,b) -> rhs }
1466 where the type is a single constructor type. This gives better code
1467 when rhs also scrutinises x or e.
1469 Here "cannot match" includes knowledge from GADTs
1471 It's a good idea do do this stuff before simplifying the alternatives, to
1472 avoid simplifying alternatives we know can't happen, and to come up with
1473 the list of constructors that are handled, to put into the IdInfo of the
1474 case binder, for use when simplifying the alternatives.
1476 Eliminating the default alternative in (1) isn't so obvious, but it can
1479 data Colour = Red | Green | Blue
1488 DEFAULT -> [ case y of ... ]
1490 If we inline h into f, the default case of the inlined h can't happen.
1491 If we don't notice this, we may end up filtering out *all* the cases
1492 of the inner case y, which give us nowhere to go!
1496 simplAlts :: SimplEnv
1498 -> InId -- Case binder
1499 -> [InAlt] -> SimplCont
1500 -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
1501 -- Like simplExpr, this just returns the simplified alternatives;
1502 -- it not return an environment
1504 simplAlts env scrut case_bndr alts cont'
1505 = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1506 do { let alt_env = zapFloats env
1507 ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
1509 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts
1511 ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
1512 ; return (scrut', case_bndr', alts') }
1514 ------------------------------------
1515 simplAlt :: SimplEnv
1516 -> [AltCon] -- These constructors can't be present when
1517 -- matching the DEFAULT alternative
1518 -> OutId -- The case binder
1523 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1524 = ASSERT( null bndrs )
1525 do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1526 -- Record the constructors that the case-binder *can't* be.
1527 ; rhs' <- simplExprC env' rhs cont'
1528 ; return (DEFAULT, [], rhs') }
1530 simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
1531 = ASSERT( null bndrs )
1532 do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1533 ; rhs' <- simplExprC env' rhs cont'
1534 ; return (LitAlt lit, [], rhs') }
1536 simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
1537 = do { -- Deal with the pattern-bound variables
1538 (env, vs') <- simplBinders env (add_evals con vs)
1540 -- Mark the ones that are in ! positions in the
1541 -- data constructor as certainly-evaluated.
1542 ; let vs'' = add_evals con vs'
1544 -- Bind the case-binder to (con args)
1545 ; let inst_tys' = tyConAppArgs (idType case_bndr')
1546 con_args = map Type inst_tys' ++ varsToCoreExprs vs''
1547 env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
1549 ; rhs' <- simplExprC env' rhs cont'
1550 ; return (DataAlt con, vs'', rhs') }
1552 -- add_evals records the evaluated-ness of the bound variables of
1553 -- a case pattern. This is *important*. Consider
1554 -- data T = T !Int !Int
1556 -- case x of { T a b -> T (a+1) b }
1558 -- We really must record that b is already evaluated so that we don't
1559 -- go and re-evaluate it when constructing the result.
1560 -- See Note [Data-con worker strictness] in MkId.lhs
1561 add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
1563 cat_evals dc vs strs
1567 go (v:vs) strs | isTyVar v = v : go vs strs
1568 go (v:vs) (str:strs)
1569 | isMarkedStrict str = evald_v : go vs strs
1570 | otherwise = zapped_v : go vs strs
1572 zapped_v = zap_occ_info v
1573 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
1574 go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
1576 -- If the case binder is alive, then we add the unfolding
1578 -- to the envt; so vs are now very much alive
1579 -- Note [Aug06] I can't see why this actually matters
1580 zap_occ_info | isDeadBinder case_bndr' = \id -> id
1581 | otherwise = zapOccInfo
1583 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1584 addBinderUnfolding env bndr rhs
1585 = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
1587 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1588 addBinderOtherCon env bndr cons
1589 = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
1593 %************************************************************************
1595 \subsection{Known constructor}
1597 %************************************************************************
1599 We are a bit careful with occurrence info. Here's an example
1601 (\x* -> case x of (a*, b) -> f a) (h v, e)
1603 where the * means "occurs once". This effectively becomes
1604 case (h v, e) of (a*, b) -> f a)
1606 let a* = h v; b = e in f a
1610 All this should happen in one sweep.
1613 knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
1614 -> InId -> [InAlt] -> SimplCont
1615 -> SimplM (SimplEnv, OutExpr)
1617 knownCon env scrut con args bndr alts cont
1618 = do { tick (KnownBranch bndr)
1619 ; knownAlt env scrut args bndr (findAlt con alts) cont }
1621 knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont
1623 do { env <- simplNonRecX env bndr scrut
1624 -- This might give rise to a binding with non-atomic args
1625 -- like x = Node (f x) (g x)
1626 -- but simplNonRecX will atomic-ify it
1627 ; simplExprF env rhs cont }
1629 knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont
1631 do { env <- simplNonRecX env bndr scrut
1632 ; simplExprF env rhs cont }
1634 knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont
1635 = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId
1636 n_drop_tys = length (dataConUnivTyVars dc)
1637 ; env <- bind_args env dead_bndr bs (drop n_drop_tys args)
1639 -- It's useful to bind bndr to scrut, rather than to a fresh
1640 -- binding x = Con arg1 .. argn
1641 -- because very often the scrut is a variable, so we avoid
1642 -- creating, and then subsequently eliminating, a let-binding
1643 -- BUT, if scrut is a not a variable, we must be careful
1644 -- about duplicating the arg redexes; in that case, make
1645 -- a new con-app from the args
1646 bndr_rhs = case scrut of
1649 con_app = mkConApp dc (take n_drop_tys args ++ con_args)
1650 con_args = [substExpr env (varToCoreExpr b) | b <- bs]
1651 -- args are aready OutExprs, but bs are InIds
1653 ; env <- simplNonRecX env bndr bndr_rhs
1654 ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $
1655 simplExprF env rhs cont }
1658 bind_args env dead_bndr [] _ = return env
1660 bind_args env dead_bndr (b:bs) (Type ty : args)
1661 = ASSERT( isTyVar b )
1662 bind_args (extendTvSubst env b ty) dead_bndr bs args
1664 bind_args env dead_bndr (b:bs) (arg : args)
1666 do { let b' = if dead_bndr then b else zapOccInfo b
1667 -- Note that the binder might be "dead", because it doesn't occur
1668 -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
1669 -- Nevertheless we must keep it if the case-binder is alive, because it may
1670 -- be used in the con_app. See Note [zapOccInfo]
1671 ; env <- simplNonRecX env b' arg
1672 ; bind_args env dead_bndr bs args }
1674 bind_args _ _ _ _ = panic "bind_args"
1678 %************************************************************************
1680 \subsection{Duplicating continuations}
1682 %************************************************************************
1685 prepareCaseCont :: SimplEnv
1686 -> [InAlt] -> SimplCont
1687 -> SimplM (SimplEnv, SimplCont,SimplCont)
1688 -- Return a duplicatable continuation, a non-duplicable part
1689 -- plus some extra bindings (that scope over the entire
1692 -- No need to make it duplicatable if there's only one alternative
1693 prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont))
1694 prepareCaseCont env alts cont = mkDupableCont env cont
1698 mkDupableCont :: SimplEnv -> SimplCont
1699 -> SimplM (SimplEnv, SimplCont, SimplCont)
1701 mkDupableCont env cont
1702 | contIsDupable cont
1703 = returnSmpl (env, cont, mkBoringStop (contResultType cont))
1705 mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
1707 mkDupableCont env (CoerceIt ty cont)
1708 = do { (env, dup, nodup) <- mkDupableCont env cont
1709 ; return (env, CoerceIt ty dup, nodup) }
1711 mkDupableCont env cont@(StrictBind bndr _ _ se _)
1712 = return (env, mkBoringStop (substTy se (idType bndr)), cont)
1713 -- See Note [Duplicating strict continuations]
1715 mkDupableCont env cont@(StrictArg _ fun_ty _ _)
1716 = return (env, mkBoringStop (funArgTy fun_ty), cont)
1717 -- See Note [Duplicating strict continuations]
1719 mkDupableCont env (ApplyTo _ arg se cont)
1720 = -- e.g. [...hole...] (...arg...)
1722 -- let a = ...arg...
1723 -- in [...hole...] a
1724 do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1725 ; arg <- simplExpr (se `setInScope` env) arg
1726 ; (env, arg) <- makeTrivial env arg
1727 ; let app_cont = ApplyTo OkToDup arg (zapSubstEnv env) dup_cont
1728 ; return (env, app_cont, nodup_cont) }
1730 mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont)
1731 -- See Note [Single-alternative case]
1732 -- | not (exprIsDupable rhs && contIsDupable case_cont)
1733 -- | not (isDeadBinder case_bndr)
1734 | all isDeadBinder bs -- InIds
1735 = return (env, mkBoringStop scrut_ty, cont)
1737 scrut_ty = substTy se (idType case_bndr)
1739 mkDupableCont env (Select _ case_bndr alts se cont)
1740 = -- e.g. (case [...hole...] of { pi -> ei })
1742 -- let ji = \xij -> ei
1743 -- in case [...hole...] of { pi -> ji xij }
1744 do { tick (CaseOfCase case_bndr)
1745 ; (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1746 -- NB: call mkDupableCont here, *not* prepareCaseCont
1747 -- We must make a duplicable continuation, whereas prepareCaseCont
1748 -- doesn't when there is a single case branch
1750 ; let alt_env = se `setInScope` env
1751 ; (alt_env, case_bndr') <- simplBinder alt_env case_bndr
1752 ; alts' <- mapM (simplAlt alt_env [] case_bndr' dup_cont) alts
1753 -- Safe to say that there are no handled-cons for the DEFAULT case
1754 -- NB: simplBinder does not zap deadness occ-info, so
1755 -- a dead case_bndr' will still advertise its deadness
1756 -- This is really important because in
1757 -- case e of b { (# p,q #) -> ... }
1758 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1759 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1760 -- In the new alts we build, we have the new case binder, so it must retain
1762 -- NB: we don't use alt_env further; it has the substEnv for
1763 -- the alternatives, and we don't want that
1765 ; (env, alts') <- mkDupableAlts env case_bndr' alts'
1766 ; return (env, -- Note [Duplicated env]
1767 Select OkToDup case_bndr' alts' (zapSubstEnv env)
1768 (mkBoringStop (contResultType dup_cont)),
1772 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1773 -> SimplM (SimplEnv, [InAlt])
1774 -- Absorbs the continuation into the new alternatives
1776 mkDupableAlts env case_bndr' alts
1779 go env [] = return (env, [])
1781 = do { (env, alt') <- mkDupableAlt env case_bndr' alt
1782 ; (env, alts') <- go env alts
1783 ; return (env, alt' : alts' ) }
1785 mkDupableAlt env case_bndr' (con, bndrs', rhs')
1786 | exprIsDupable rhs' -- Note [Small alternative rhs]
1787 = return (env, (con, bndrs', rhs'))
1789 = do { let rhs_ty' = exprType rhs'
1790 used_bndrs' = filter abstract_over (case_bndr' : bndrs')
1792 | isTyVar bndr = True -- Abstract over all type variables just in case
1793 | otherwise = not (isDeadBinder bndr)
1794 -- The deadness info on the new Ids is preserved by simplBinders
1796 ; (final_bndrs', final_args) -- Note [Join point abstraction]
1797 <- if (any isId used_bndrs')
1798 then return (used_bndrs', varsToCoreExprs used_bndrs')
1799 else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy
1800 ; return ([rw_id], [Var realWorldPrimId]) }
1802 ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty')
1803 -- Note [Funky mkPiTypes]
1805 ; let -- We make the lambdas into one-shot-lambdas. The
1806 -- join point is sure to be applied at most once, and doing so
1807 -- prevents the body of the join point being floated out by
1808 -- the full laziness pass
1809 really_final_bndrs = map one_shot final_bndrs'
1810 one_shot v | isId v = setOneShotLambda v
1812 join_rhs = mkLams really_final_bndrs rhs'
1813 join_call = mkApps (Var join_bndr) final_args
1815 ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
1816 -- See Note [Duplicated env]
1819 Note [Duplicated env]
1820 ~~~~~~~~~~~~~~~~~~~~~
1821 Some of the alternatives are simplified, but have not been turned into a join point
1822 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
1823 bind the join point, because it might to do PostInlineUnconditionally, and
1824 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
1825 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1826 at worst delays the join-point inlining.
1828 Note [Small alterantive rhs]
1829 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1830 It is worth checking for a small RHS because otherwise we
1831 get extra let bindings that may cause an extra iteration of the simplifier to
1832 inline back in place. Quite often the rhs is just a variable or constructor.
1833 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1834 iterations because the version with the let bindings looked big, and so wasn't
1835 inlined, but after the join points had been inlined it looked smaller, and so
1838 NB: we have to check the size of rhs', not rhs.
1839 Duplicating a small InAlt might invalidate occurrence information
1840 However, if it *is* dupable, we return the *un* simplified alternative,
1841 because otherwise we'd need to pair it up with an empty subst-env....
1842 but we only have one env shared between all the alts.
1843 (Remember we must zap the subst-env before re-simplifying something).
1844 Rather than do this we simply agree to re-simplify the original (small) thing later.
1846 Note [Funky mkPiTypes]
1847 ~~~~~~~~~~~~~~~~~~~~~~
1848 Notice the funky mkPiTypes. If the contructor has existentials
1849 it's possible that the join point will be abstracted over
1850 type varaibles as well as term variables.
1851 Example: Suppose we have
1852 data T = forall t. C [t]
1854 case (case e of ...) of
1856 We get the join point
1857 let j :: forall t. [t] -> ...
1858 j = /\t \xs::[t] -> rhs
1860 case (case e of ...) of
1861 C t xs::[t] -> j t xs
1863 Note [Join point abstaction]
1864 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1865 If we try to lift a primitive-typed something out
1866 for let-binding-purposes, we will *caseify* it (!),
1867 with potentially-disastrous strictness results. So
1868 instead we turn it into a function: \v -> e
1869 where v::State# RealWorld#. The value passed to this function
1870 is realworld#, which generates (almost) no code.
1872 There's a slight infelicity here: we pass the overall
1873 case_bndr to all the join points if it's used in *any* RHS,
1874 because we don't know its usage in each RHS separately
1876 We used to say "&& isUnLiftedType rhs_ty'" here, but now
1877 we make the join point into a function whenever used_bndrs'
1878 is empty. This makes the join-point more CPR friendly.
1879 Consider: let j = if .. then I# 3 else I# 4
1880 in case .. of { A -> j; B -> j; C -> ... }
1882 Now CPR doesn't w/w j because it's a thunk, so
1883 that means that the enclosing function can't w/w either,
1884 which is a lose. Here's the example that happened in practice:
1885 kgmod :: Int -> Int -> Int
1886 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1890 I have seen a case alternative like this:
1892 It's a bit silly to add the realWorld dummy arg in this case, making
1895 (the \v alone is enough to make CPR happy) but I think it's rare
1897 Note [Duplicating strict continuations]
1898 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1899 Do *not* duplicate StrictBind and StritArg continuations. We gain
1900 nothing by propagating them into the expressions, and we do lose a
1901 lot. Here's an example:
1902 && (case x of { T -> F; F -> T }) E
1903 Now, && is strict so we end up simplifying the case with
1904 an ArgOf continuation. If we let-bind it, we get
1906 let $j = \v -> && v E
1907 in simplExpr (case x of { T -> F; F -> T })
1909 And after simplifying more we get
1911 let $j = \v -> && v E
1912 in case x of { T -> $j F; F -> $j T }
1913 Which is a Very Bad Thing
1915 The desire not to duplicate is the entire reason that
1916 mkDupableCont returns a pair of continuations.
1918 The original plan had:
1919 e.g. (...strict-fn...) [...hole...]
1921 let $j = \a -> ...strict-fn...
1924 Note [Single-alternative cases]
1925 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1926 This case is just like the ArgOf case. Here's an example:
1930 case (case x of I# x' ->
1932 True -> I# (negate# x')
1933 False -> I# x') of y {
1935 Because the (case x) has only one alternative, we'll transform to
1937 case (case x' <# 0# of
1938 True -> I# (negate# x')
1939 False -> I# x') of y {
1941 But now we do *NOT* want to make a join point etc, giving
1943 let $j = \y -> MkT y
1945 True -> $j (I# (negate# x'))
1947 In this case the $j will inline again, but suppose there was a big
1948 strict computation enclosing the orginal call to MkT. Then, it won't
1949 "see" the MkT any more, because it's big and won't get duplicated.
1950 And, what is worse, nothing was gained by the case-of-case transform.
1952 When should use this case of mkDupableCont?
1953 However, matching on *any* single-alternative case is a *disaster*;
1954 e.g. case (case ....) of (a,b) -> (# a,b #)
1955 We must push the outer case into the inner one!
1958 * Match [(DEFAULT,_,_)], but in the common case of Int,
1959 the alternative-filling-in code turned the outer case into
1960 case (...) of y { I# _ -> MkT y }
1962 * Match on single alternative plus (not (isDeadBinder case_bndr))
1963 Rationale: pushing the case inwards won't eliminate the construction.
1964 But there's a risk of
1965 case (...) of y { (a,b) -> let z=(a,b) in ... }
1966 Now y looks dead, but it'll come alive again. Still, this
1967 seems like the best option at the moment.
1969 * Match on single alternative plus (all (isDeadBinder bndrs))
1970 Rationale: this is essentially seq.
1972 * Match when the rhs is *not* duplicable, and hence would lead to a
1973 join point. This catches the disaster-case above. We can test
1974 the *un-simplified* rhs, which is fine. It might get bigger or
1975 smaller after simplification; if it gets smaller, this case might
1976 fire next time round. NB also that we must test contIsDupable
1977 case_cont *btoo, because case_cont might be big!
1979 HOWEVER: I found that this version doesn't work well, because
1980 we can get let x = case (...) of { small } in ...case x...
1981 When x is inlined into its full context, we find that it was a bad
1982 idea to have pushed the outer case inside the (...) case.