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"
11 import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings),
15 import Type hiding ( substTy, extendTvSubst )
21 import TcGadt ( dataConCanMatch )
22 import DataCon ( dataConTyCon, dataConRepStrictness )
23 import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
25 import PprCore ( pprParendExpr, pprCoreExpr )
26 import CoreUnfold ( mkUnfolding, callSiteInline )
28 import Rules ( lookupRule )
29 import BasicTypes ( isMarkedStrict )
30 import CostCentre ( currentCCS )
31 import TysPrim ( realWorldStatePrimTy )
32 import PrelInfo ( realWorldPrimId )
33 import BasicTypes ( TopLevelFlag(..), isTopLevel,
34 RecFlag(..), isNonRuleLoopBreaker )
36 import Maybes ( orElse )
42 The guts of the simplifier is in this module, but the driver loop for
43 the simplifier is in SimplCore.lhs.
46 -----------------------------------------
47 *** IMPORTANT NOTE ***
48 -----------------------------------------
49 The simplifier used to guarantee that the output had no shadowing, but
50 it does not do so any more. (Actually, it never did!) The reason is
51 documented with simplifyArgs.
54 -----------------------------------------
55 *** IMPORTANT NOTE ***
56 -----------------------------------------
57 Many parts of the simplifier return a bunch of "floats" as well as an
58 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
60 All "floats" are let-binds, not case-binds, but some non-rec lets may
61 be unlifted (with RHS ok-for-speculation).
65 -----------------------------------------
66 ORGANISATION OF FUNCTIONS
67 -----------------------------------------
69 - simplify all top-level binders
70 - for NonRec, call simplRecOrTopPair
71 - for Rec, call simplRecBind
74 ------------------------------
75 simplExpr (applied lambda) ==> simplNonRecBind
76 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
77 simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
79 ------------------------------
80 simplRecBind [binders already simplfied]
81 - use simplRecOrTopPair on each pair in turn
83 simplRecOrTopPair [binder already simplified]
84 Used for: recursive bindings (top level and nested)
85 top-level non-recursive bindings
87 - check for PreInlineUnconditionally
91 Used for: non-top-level non-recursive bindings
92 beta reductions (which amount to the same thing)
93 Because it can deal with strict arts, it takes a
94 "thing-inside" and returns an expression
96 - check for PreInlineUnconditionally
97 - simplify binder, including its IdInfo
106 simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
107 Used for: binding case-binder and constr args in a known-constructor case
108 - check for PreInLineUnconditionally
112 ------------------------------
113 simplLazyBind: [binder already simplified, RHS not]
114 Used for: recursive bindings (top level and nested)
115 top-level non-recursive bindings
116 non-top-level, but *lazy* non-recursive bindings
117 [must not be strict or unboxed]
118 Returns floats + an augmented environment, not an expression
119 - substituteIdInfo and add result to in-scope
120 [so that rules are available in rec rhs]
123 - float if exposes constructor or PAP
127 completeNonRecX: [binder and rhs both simplified]
128 - if the the thing needs case binding (unlifted and not ok-for-spec)
134 completeBind: [given a simplified RHS]
135 [used for both rec and non-rec bindings, top level and not]
136 - try PostInlineUnconditionally
137 - add unfolding [this is the only place we add an unfolding]
142 Right hand sides and arguments
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
144 In many ways we want to treat
145 (a) the right hand side of a let(rec), and
146 (b) a function argument
147 in the same way. But not always! In particular, we would
148 like to leave these arguments exactly as they are, so they
149 will match a RULE more easily.
154 It's harder to make the rule match if we ANF-ise the constructor,
155 or eta-expand the PAP:
157 f (let { a = g x; b = h x } in (a,b))
160 On the other hand if we see the let-defns
165 then we *do* want to ANF-ise and eta-expand, so that p and q
166 can be safely inlined.
168 Even floating lets out is a bit dubious. For let RHS's we float lets
169 out if that exposes a value, so that the value can be inlined more vigorously.
172 r = let x = e in (x,x)
174 Here, if we float the let out we'll expose a nice constructor. We did experiments
175 that showed this to be a generally good thing. But it was a bad thing to float
176 lets out unconditionally, because that meant they got allocated more often.
178 For function arguments, there's less reason to expose a constructor (it won't
179 get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
180 So for the moment we don't float lets out of function arguments either.
185 For eta expansion, we want to catch things like
187 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
189 If the \x was on the RHS of a let, we'd eta expand to bring the two
190 lambdas together. And in general that's a good thing to do. Perhaps
191 we should eta expand wherever we find a (value) lambda? Then the eta
192 expansion at a let RHS can concentrate solely on the PAP case.
195 %************************************************************************
197 \subsection{Bindings}
199 %************************************************************************
202 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
204 simplTopBinds env binds
205 = do { -- Put all the top-level binders into scope at the start
206 -- so that if a transformation rule has unexpectedly brought
207 -- anything into scope, then we don't get a complaint about that.
208 -- It's rather as if the top-level binders were imported.
209 ; env <- simplRecBndrs env (bindersOfBinds binds)
210 ; dflags <- getDOptsSmpl
211 ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
212 dopt Opt_D_dump_rule_firings dflags
213 ; env' <- simpl_binds dump_flag env binds
214 ; freeTick SimplifierDone
215 ; return (getFloats env') }
217 -- We need to track the zapped top-level binders, because
218 -- they should have their fragile IdInfo zapped (notably occurrence info)
219 -- That's why we run down binds and bndrs' simultaneously.
221 -- The dump-flag emits a trace for each top-level binding, which
222 -- helps to locate the tracing for inlining and rule firing
223 simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
224 simpl_binds dump env [] = return env
225 simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $
227 ; simpl_binds dump env' binds }
229 trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
230 trace False bind = \x -> x
232 simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r
233 simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
237 %************************************************************************
239 \subsection{Lazy bindings}
241 %************************************************************************
243 simplRecBind is used for
244 * recursive bindings only
247 simplRecBind :: SimplEnv -> TopLevelFlag
250 simplRecBind env top_lvl pairs
251 = do { env' <- go (zapFloats env) pairs
252 ; return (env `addRecFloats` env') }
253 -- addFloats adds the floats from env',
254 -- *and* updates env with the in-scope set from env'
256 go env [] = return env
258 go env ((bndr, rhs) : pairs)
259 = do { env <- simplRecOrTopPair env top_lvl bndr rhs
263 simplOrTopPair is used for
264 * recursive bindings (whether top level or not)
265 * top-level non-recursive bindings
267 It assumes the binder has already been simplified, but not its IdInfo.
270 simplRecOrTopPair :: SimplEnv
272 -> InId -> InExpr -- Binder and rhs
273 -> SimplM SimplEnv -- Returns an env that includes the binding
275 simplRecOrTopPair env top_lvl bndr rhs
276 | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline
277 = do { tick (PreInlineUnconditionally bndr)
278 ; return (extendIdSubst env bndr (mkContEx env rhs)) }
281 = do { let bndr' = lookupRecBndr env bndr
282 (env', bndr'') = addLetIdInfo env bndr bndr'
283 ; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' }
284 -- May not actually be recursive, but it doesn't matter
288 simplLazyBind is used for
289 * [simplRecOrTopPair] recursive bindings (whether top level or not)
290 * [simplRecOrTopPair] top-level non-recursive bindings
291 * [simplNonRecE] non-top-level *lazy* non-recursive bindings
294 1. It assumes that the binder is *already* simplified,
295 and is in scope, and its IdInfo too, except unfolding
297 2. It assumes that the binder type is lifted.
299 3. It does not check for pre-inline-unconditionallly;
300 that should have been done already.
303 simplLazyBind :: SimplEnv
304 -> TopLevelFlag -> RecFlag
305 -> InId -> OutId -- Binder, both pre-and post simpl
306 -- The OutId has IdInfo, except arity, unfolding
307 -> InExpr -> SimplEnv -- The RHS and its environment
310 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
311 = do { let rhs_env = rhs_se `setInScope` env
312 rhs_cont = mkRhsStop (idType bndr1)
314 -- Simplify the RHS; note the mkRhsStop, which tells
315 -- the simplifier that this is the RHS of a let.
316 ; (rhs_env1, rhs1) <- simplExprF rhs_env rhs rhs_cont
318 -- If any of the floats can't be floated, give up now
319 -- (The canFloat predicate says True for empty floats.)
320 ; if (not (canFloat top_lvl is_rec False rhs_env1))
321 then completeBind env top_lvl bndr bndr1
322 (wrapFloats rhs_env1 rhs1)
324 -- ANF-ise a constructor or PAP rhs
325 { (rhs_env2, rhs2) <- prepareRhs rhs_env1 rhs1
326 ; (env', rhs3) <- chooseRhsFloats top_lvl is_rec False env rhs_env2 rhs2
327 ; completeBind env' top_lvl bndr bndr1 rhs3 } }
329 chooseRhsFloats :: TopLevelFlag -> RecFlag -> Bool
330 -> SimplEnv -- Env for the let
331 -> SimplEnv -- Env for the RHS, with RHS floats in it
332 -> OutExpr -- ..and the RHS itself
333 -> SimplM (SimplEnv, OutExpr) -- New env for let, and RHS
335 chooseRhsFloats top_lvl is_rec is_strict env rhs_env rhs
336 | not (isEmptyFloats rhs_env) -- Something to float
337 , canFloat top_lvl is_rec is_strict rhs_env -- ...that can float
338 , (isTopLevel top_lvl || exprIsCheap rhs) -- ...and we want to float
339 = do { tick LetFloatFromLet -- Float
340 ; return (addFloats env rhs_env, rhs) } -- Add the floats to the main env
341 | otherwise -- Don't float
342 = return (env, wrapFloats rhs_env rhs) -- Wrap the floats around the RHS
346 %************************************************************************
348 \subsection{simplNonRec}
350 %************************************************************************
352 A specialised variant of simplNonRec used when the RHS is already simplified,
353 notably in knownCon. It uses case-binding where necessary.
356 simplNonRecX :: SimplEnv
357 -> InId -- Old binder
358 -> OutExpr -- Simplified RHS
361 simplNonRecX env bndr new_rhs
362 = do { (env, bndr') <- simplBinder env bndr
363 ; completeNonRecX env NotTopLevel NonRecursive
364 (isStrictBndr bndr) bndr bndr' new_rhs }
366 completeNonRecX :: SimplEnv
367 -> TopLevelFlag -> RecFlag -> Bool
368 -> InId -- Old binder
369 -> OutId -- New binder
370 -> OutExpr -- Simplified RHS
373 completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs
374 = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
375 ; (env2, rhs2) <- chooseRhsFloats top_lvl is_rec is_strict env env1 rhs1
376 ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
379 {- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
380 Doing so risks exponential behaviour, because new_rhs has been simplified once already
381 In the cases described by the folowing commment, postInlineUnconditionally will
382 catch many of the relevant cases.
383 -- This happens; for example, the case_bndr during case of
384 -- known constructor: case (a,b) of x { (p,q) -> ... }
385 -- Here x isn't mentioned in the RHS, so we don't want to
386 -- create the (dead) let-binding let x = (a,b) in ...
388 -- Similarly, single occurrences can be inlined vigourously
389 -- e.g. case (f x, g y) of (a,b) -> ....
390 -- If a,b occur once we can avoid constructing the let binding for them.
392 Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
393 -- Consider case I# (quotInt# x y) of
394 -- I# v -> let w = J# v in ...
395 -- If we gaily inline (quotInt# x y) for v, we end up building an
397 -- let w = J# (quotInt# x y) in ...
398 -- because quotInt# can fail.
400 | preInlineUnconditionally env NotTopLevel bndr new_rhs
401 = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
404 prepareRhs takes a putative RHS, checks whether it's a PAP or
405 constructor application and, if so, converts it to ANF, so that the
406 resulting thing can be inlined more easily. Thus
414 prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
415 -- 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 | (Var fun, args) <- collectArgs rhs -- It's an application
423 , let n_args = valArgCount args
424 , n_args > 0 -- ...but not a trivial one
425 , isDataConWorkId fun || n_args < idArity fun -- ...and it's a constructor or PAP
426 = go env (Var fun) args
428 go env fun [] = return (env, fun)
429 go env fun (arg : args) = do { (env', arg') <- makeTrivial env arg
430 ; go env' (App fun arg') args }
432 prepareRhs env rhs -- The default case
436 Note [Float coercions]
437 ~~~~~~~~~~~~~~~~~~~~~~
438 When we find the binding
440 we'd like to transform it to
442 x = x `cast` co -- A trivial binding
443 There's a chance that e will be a constructor application or function, or something
444 like that, so moving the coerion to the usage site may well cancel the coersions
445 and lead to further optimisation. Example:
448 data instance T Int = T Int
450 foo :: Int -> Int -> Int
455 go n = case x of { T m -> go (n-m) }
456 -- This case should optimise
460 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
461 -- Binds the expression to a variable, if it's not trivial, returning the variable
465 | otherwise -- See Note [Take care] below
466 = do { var <- newId FSLIT("a") (exprType expr)
467 ; env <- completeNonRecX env NotTopLevel NonRecursive
469 ; return (env, substExpr env (Var var)) }
473 %************************************************************************
475 \subsection{Completing a lazy binding}
477 %************************************************************************
480 * deals only with Ids, not TyVars
481 * takes an already-simplified binder and RHS
482 * is used for both recursive and non-recursive bindings
483 * is used for both top-level and non-top-level bindings
485 It does the following:
486 - tries discarding a dead binding
487 - tries PostInlineUnconditionally
488 - add unfolding [this is the only place we add an unfolding]
491 It does *not* attempt to do let-to-case. Why? Because it is used for
492 - top-level bindings (when let-to-case is impossible)
493 - many situations where the "rhs" is known to be a WHNF
494 (so let-to-case is inappropriate).
496 Nor does it do the atomic-argument thing
499 completeBind :: SimplEnv
500 -> TopLevelFlag -- Flag stuck into unfolding
501 -> InId -- Old binder
502 -> OutId -> OutExpr -- New binder and RHS
504 -- completeBind may choose to do its work
505 -- * by extending the substitution (e.g. let x = y in ...)
506 -- * or by adding to the floats in the envt
508 completeBind env top_lvl old_bndr new_bndr new_rhs
509 | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
510 -- Inline and discard the binding
511 = do { tick (PostInlineUnconditionally old_bndr)
512 ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
513 return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
514 -- Use the substitution to make quite, quite sure that the
515 -- substitution will happen, since we are going to discard the binding
520 new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
523 -- Add the unfolding *only* for non-loop-breakers
524 -- Making loop breakers not have an unfolding at all
525 -- means that we can avoid tests in exprIsConApp, for example.
526 -- This is important: if exprIsConApp says 'yes' for a recursive
527 -- thing, then we can get into an infinite loop
530 -- If the unfolding is a value, the demand info may
531 -- go pear-shaped, so we nuke it. Example:
533 -- case x of (p,q) -> h p q x
534 -- Here x is certainly demanded. But after we've nuked
535 -- the case, we'll get just
536 -- let x = (a,b) in h a b x
537 -- and now x is not demanded (I'm assuming h is lazy)
538 -- This really happens. Similarly
539 -- let f = \x -> e in ...f..f...
540 -- After inlining f at some of its call sites the original binding may
541 -- (for example) be no longer strictly demanded.
542 -- The solution here is a bit ad hoc...
543 info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
544 final_info | loop_breaker = new_bndr_info
545 | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
546 | otherwise = info_w_unf
548 final_id = new_bndr `setIdInfo` final_info
550 -- These seqs forces the Id, and hence its IdInfo,
551 -- and hence any inner substitutions
553 -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
554 return (addNonRec env final_id new_rhs)
556 unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
557 loop_breaker = isNonRuleLoopBreaker occ_info
558 old_info = idInfo old_bndr
559 occ_info = occInfo old_info
564 %************************************************************************
566 \subsection[Simplify-simplExpr]{The main function: simplExpr}
568 %************************************************************************
570 The reason for this OutExprStuff stuff is that we want to float *after*
571 simplifying a RHS, not before. If we do so naively we get quadratic
572 behaviour as things float out.
574 To see why it's important to do it after, consider this (real) example:
588 a -- Can't inline a this round, cos it appears twice
592 Each of the ==> steps is a round of simplification. We'd save a
593 whole round if we float first. This can cascade. Consider
598 let f = let d1 = ..d.. in \y -> e
602 in \x -> ...(\y ->e)...
604 Only in this second round can the \y be applied, and it
605 might do the same again.
609 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
610 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
612 expr_ty' = substTy env (exprType expr)
613 -- The type in the Stop continuation, expr_ty', is usually not used
614 -- It's only needed when discarding continuations after finding
615 -- a function that returns bottom.
616 -- Hence the lazy substitution
619 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
620 -- Simplify an expression, given a continuation
621 simplExprC env expr cont
622 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
623 do { (env', expr') <- simplExprF (zapFloats env) expr cont
624 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
625 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
626 -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
627 return (wrapFloats env' expr') }
629 --------------------------------------------------
630 simplExprF :: SimplEnv -> InExpr -> SimplCont
631 -> SimplM (SimplEnv, OutExpr)
633 simplExprF env e cont
634 = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
635 simplExprF' env e cont
637 simplExprF' env (Var v) cont = simplVar env v cont
638 simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
639 simplExprF' env (Note n expr) cont = simplNote env n expr cont
640 simplExprF' env (Cast body co) cont = simplCast env body co cont
641 simplExprF' env (App fun arg) cont = simplExprF env fun $
642 ApplyTo NoDup arg env cont
644 simplExprF' env expr@(Lam _ _) cont
645 = simplLam env (map zap bndrs) body cont
646 -- The main issue here is under-saturated lambdas
647 -- (\x1. \x2. e) arg1
648 -- Here x1 might have "occurs-once" occ-info, because occ-info
649 -- is computed assuming that a group of lambdas is applied
650 -- all at once. If there are too few args, we must zap the
653 n_args = countArgs cont
654 n_params = length bndrs
655 (bndrs, body) = collectBinders expr
656 zap | n_args >= n_params = \b -> b
657 | otherwise = \b -> if isTyVar b then b
659 -- NB: we count all the args incl type args
660 -- so we must count all the binders (incl type lambdas)
662 simplExprF' env (Type ty) cont
663 = ASSERT( contIsRhsOrArg cont )
664 do { ty' <- simplType env ty
665 ; rebuild env (Type ty') cont }
667 simplExprF' env (Case scrut bndr case_ty alts) cont
668 | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
669 = -- Simplify the scrutinee with a Select continuation
670 simplExprF env scrut (Select NoDup bndr alts env cont)
673 = -- If case-of-case is off, simply simplify the case expression
674 -- in a vanilla Stop context, and rebuild the result around it
675 do { case_expr' <- simplExprC env scrut case_cont
676 ; rebuild env case_expr' cont }
678 case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
679 case_ty' = substTy env case_ty -- c.f. defn of simplExpr
681 simplExprF' env (Let (Rec pairs) body) cont
682 = do { env <- simplRecBndrs env (map fst pairs)
683 -- NB: bndrs' don't have unfoldings or rules
684 -- We add them as we go down
686 ; env <- simplRecBind env NotTopLevel pairs
687 ; simplExprF env body cont }
689 simplExprF' env (Let (NonRec bndr rhs) body) cont
690 = simplNonRecE env bndr (rhs, env) ([], body) cont
692 ---------------------------------
693 simplType :: SimplEnv -> InType -> SimplM OutType
694 -- Kept monadic just so we can do the seqType
696 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
697 seqType new_ty `seq` returnSmpl new_ty
699 new_ty = substTy env ty
703 %************************************************************************
705 \subsection{The main rebuilder}
707 %************************************************************************
710 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
711 -- At this point the substitution in the SimplEnv should be irrelevant
712 -- only the in-scope set and floats should matter
713 rebuild env expr cont
714 = -- pprTrace "rebuild" (ppr expr $$ ppr cont $$ ppr (seFloats env)) $
716 Stop {} -> return (env, expr)
717 CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
718 Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
719 StrictArg fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont
720 StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
721 ; simplLam env' bs body cont }
722 ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
723 ; rebuild env (App expr arg') cont }
727 %************************************************************************
731 %************************************************************************
734 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
735 -> SimplM (SimplEnv, OutExpr)
736 simplCast env body co cont
737 = do { co' <- simplType env co
738 ; simplExprF env body (addCoerce co' cont) }
740 addCoerce co cont = add_coerce co (coercionKind co) cont
742 add_coerce co (s1, k1) cont -- co :: ty~ty
743 | s1 `coreEqType` k1 = cont -- is a no-op
745 add_coerce co1 (s1, k2) (CoerceIt co2 cont)
746 | (l1, t1) <- coercionKind co2
747 -- coerce T1 S1 (coerce S1 K1 e)
750 -- coerce T1 K1 e, otherwise
752 -- For example, in the initial form of a worker
753 -- we may find (coerce T (coerce S (\x.e))) y
754 -- and we'd like it to simplify to e[y/x] in one round
756 , s1 `coreEqType` t1 = cont -- The coerces cancel out
757 | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
759 add_coerce co (s1s2, t1t2) (ApplyTo dup arg arg_se cont)
760 | not (isTypeArg arg) -- This whole case only works for value args
761 -- Could upgrade to have equiv thing for type apps too
762 , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
763 -- co : s1s2 :=: t1t2
764 -- (coerce (T1->T2) (S1->S2) F) E
766 -- coerce T2 S2 (F (coerce S1 T1 E))
768 -- t1t2 must be a function type, T1->T2, because it's applied
769 -- to something but s1s2 might conceivably not be
771 -- When we build the ApplyTo we can't mix the out-types
772 -- with the InExpr in the argument, so we simply substitute
773 -- to make it all consistent. It's a bit messy.
774 -- But it isn't a common case.
776 -- Example of use: Trac #995
777 = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
779 -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and
780 -- t2 :=: s2 with left and right on the curried form:
781 -- (->) t1 t2 :=: (->) s1 s2
782 [co1, co2] = decomposeCo 2 co
783 new_arg = mkCoerce (mkSymCoercion co1) arg'
784 arg' = substExpr arg_se arg
786 add_coerce co _ cont = CoerceIt co cont
790 %************************************************************************
794 %************************************************************************
797 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
798 -> SimplM (SimplEnv, OutExpr)
800 simplLam env [] body cont = simplExprF env body cont
802 -- Type-beta reduction
803 simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont)
804 = ASSERT( isTyVar bndr )
805 do { tick (BetaReduction bndr)
806 ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg
807 ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
809 -- Ordinary beta reduction
810 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
811 = do { tick (BetaReduction bndr)
812 ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
814 -- Not enough args, so there are real lambdas left to put in the result
815 simplLam env bndrs body cont
816 = do { (env, bndrs') <- simplLamBndrs env bndrs
817 ; body' <- simplExpr env body
818 ; new_lam <- mkLam bndrs' body'
819 ; rebuild env new_lam cont }
822 simplNonRecE :: SimplEnv
823 -> InId -- The binder
824 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
825 -> ([InId], InExpr) -- Body of the let/lambda
828 -> SimplM (SimplEnv, OutExpr)
830 -- simplNonRecE is used for
831 -- * non-top-level non-recursive lets in expressions
834 -- It deals with strict bindings, via the StrictBind continuation,
835 -- which may abort the whole process
837 -- The "body" of the binding comes as a pair of ([InId],InExpr)
838 -- representing a lambda; so we recurse back to simplLam
839 -- Why? Because of the binder-occ-info-zapping done before
840 -- the call to simplLam in simplExprF (Lam ...)
842 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
843 | preInlineUnconditionally env NotTopLevel bndr rhs
844 = do { tick (PreInlineUnconditionally bndr)
845 ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
848 = do { simplExprF (rhs_se `setFloats` env) rhs
849 (StrictBind bndr bndrs body env cont) }
852 = do { (env, bndr') <- simplBinder env bndr
853 ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
854 ; simplLam env bndrs body cont }
858 %************************************************************************
862 %************************************************************************
865 -- Hack alert: we only distinguish subsumed cost centre stacks for the
866 -- purposes of inlining. All other CCCSs are mapped to currentCCS.
867 simplNote env (SCC cc) e cont
868 = do { e' <- simplExpr (setEnclosingCC env currentCCS) e
869 ; rebuild env (mkSCC cc e') cont }
871 -- See notes with SimplMonad.inlineMode
872 simplNote env InlineMe e cont
873 | contIsRhsOrArg cont -- Totally boring continuation; see notes above
874 = do { -- Don't inline inside an INLINE expression
875 e' <- simplExpr (setMode inlineMode env) e
876 ; rebuild env (mkInlineMe e') cont }
878 | otherwise -- Dissolve the InlineMe note if there's
879 -- an interesting context of any kind to combine with
880 -- (even a type application -- anything except Stop)
881 = simplExprF env e cont
883 simplNote env (CoreNote s) e cont
884 = simplExpr env e `thenSmpl` \ e' ->
885 rebuild env (Note (CoreNote s) e') cont
889 %************************************************************************
891 \subsection{Dealing with calls}
893 %************************************************************************
896 simplVar env var cont
897 = case substId env var of
898 DoneEx e -> simplExprF (zapSubstEnv env) e cont
899 ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
900 DoneId var1 -> completeCall (zapSubstEnv env) var1 cont
901 -- Note [zapSubstEnv]
902 -- The template is already simplified, so don't re-substitute.
903 -- This is VITAL. Consider
905 -- let y = \z -> ...x... in
907 -- We'll clone the inner \x, adding x->x' in the id_subst
908 -- Then when we inline y, we must *not* replace x by x' in
909 -- the inlined copy!!
911 ---------------------------------------------------------
912 -- Dealing with a call site
914 completeCall env var cont
915 = do { dflags <- getDOptsSmpl
916 ; let (args,call_cont) = contArgs cont
917 -- The args are OutExprs, obtained by *lazily* substituting
918 -- in the args found in cont. These args are only examined
919 -- to limited depth (unless a rule fires). But we must do
920 -- the substitution; rule matching on un-simplified args would
923 ------------- First try rules ----------------
924 -- Do this before trying inlining. Some functions have
925 -- rules *and* are strict; in this case, we don't want to
926 -- inline the wrapper of the non-specialised thing; better
927 -- to call the specialised thing instead.
929 -- We used to use the black-listing mechanism to ensure that inlining of
930 -- the wrapper didn't occur for things that have specialisations till a
931 -- later phase, so but now we just try RULES first
933 -- You might think that we shouldn't apply rules for a loop breaker:
934 -- doing so might give rise to an infinite loop, because a RULE is
935 -- rather like an extra equation for the function:
936 -- RULE: f (g x) y = x+y
939 -- But it's too drastic to disable rules for loop breakers.
940 -- Even the foldr/build rule would be disabled, because foldr
941 -- is recursive, and hence a loop breaker:
942 -- foldr k z (build g) = g k z
943 -- So it's up to the programmer: rules can cause divergence
944 ; let in_scope = getInScope env
946 maybe_rule = case activeRule env of
947 Nothing -> Nothing -- No rules apply
948 Just act_fn -> lookupRule act_fn in_scope
950 ; case maybe_rule of {
951 Just (rule, rule_rhs) ->
952 tick (RuleFired (ru_name rule)) `thenSmpl_`
953 (if dopt Opt_D_dump_rule_firings dflags then
954 pprTrace "Rule fired" (vcat [
955 text "Rule:" <+> ftext (ru_name rule),
956 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
957 text "After: " <+> pprCoreExpr rule_rhs,
958 text "Cont: " <+> ppr call_cont])
961 simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
962 -- The ruleArity says how many args the rule consumed
964 ; Nothing -> do -- No rules
966 ------------- Next try inlining ----------------
967 { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
968 n_val_args = length arg_infos
969 interesting_cont = interestingCallContext (notNull args)
972 active_inline = activeInline env var
973 maybe_inline = callSiteInline dflags active_inline
974 var arg_infos interesting_cont
975 ; case maybe_inline of {
976 Just unfolding -- There is an inlining!
977 -> do { tick (UnfoldingDone var)
978 ; (if dopt Opt_D_dump_inlinings dflags then
979 pprTrace "Inlining done" (vcat [
980 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
981 text "Inlined fn: " <+> nest 2 (ppr unfolding),
982 text "Cont: " <+> ppr call_cont])
985 simplExprF env unfolding cont }
987 ; Nothing -> -- No inlining!
989 ------------- No inlining! ----------------
990 -- Next, look for rules or specialisations that match
992 rebuildCall env (Var var) (idType var)
993 (mkArgInfo var n_val_args call_cont) cont
996 rebuildCall :: SimplEnv
997 -> OutExpr -> OutType -- Function and its type
998 -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo
1000 -> SimplM (SimplEnv, OutExpr)
1001 rebuildCall env fun fun_ty (has_rules, []) cont
1002 -- When we run out of strictness args, it means
1003 -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1004 -- Then we want to discard the entire strict continuation. E.g.
1005 -- * case (error "hello") of { ... }
1006 -- * (error "Hello") arg
1007 -- * f (error "Hello") where f is strict
1009 -- Then, especially in the first of these cases, we'd like to discard
1010 -- the continuation, leaving just the bottoming expression. But the
1011 -- type might not be right, so we may have to add a coerce.
1012 | not (contIsTrivial cont) -- Only do thia if there is a non-trivial
1013 = return (env, mk_coerce fun) -- contination to discard, else we do it
1014 where -- again and again!
1015 cont_ty = contResultType cont
1016 co = mkUnsafeCoercion fun_ty cont_ty
1017 mk_coerce expr | cont_ty `coreEqType` fun_ty = fun
1018 | otherwise = mkCoerce co fun
1020 rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont)
1021 = do { ty' <- simplType (se `setInScope` env) arg_ty
1022 ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont }
1024 rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont)
1025 | str || isStrictType arg_ty -- Strict argument
1026 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1027 simplExprF (arg_se `setFloats` env) arg
1028 (StrictArg fun fun_ty (has_rules, strs) cont)
1031 | otherwise -- Lazy argument
1032 -- DO NOT float anything outside, hence simplExprC
1033 -- There is no benefit (unlike in a let-binding), and we'd
1034 -- have to be very careful about bogus strictness through
1035 -- floating a demanded let.
1036 = do { arg' <- simplExprC (arg_se `setInScope` env) arg
1037 (mkLazyArgStop arg_ty has_rules)
1038 ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont }
1040 (arg_ty, res_ty) = splitFunTy fun_ty
1042 rebuildCall env fun fun_ty info cont
1043 = rebuild env fun cont
1048 This part of the simplifier may break the no-shadowing invariant
1050 f (...(\a -> e)...) (case y of (a,b) -> e')
1051 where f is strict in its second arg
1052 If we simplify the innermost one first we get (...(\a -> e)...)
1053 Simplifying the second arg makes us float the case out, so we end up with
1054 case y of (a,b) -> f (...(\a -> e)...) e'
1055 So the output does not have the no-shadowing invariant. However, there is
1056 no danger of getting name-capture, because when the first arg was simplified
1057 we used an in-scope set that at least mentioned all the variables free in its
1058 static environment, and that is enough.
1060 We can't just do innermost first, or we'd end up with a dual problem:
1061 case x of (a,b) -> f e (...(\a -> e')...)
1063 I spent hours trying to recover the no-shadowing invariant, but I just could
1064 not think of an elegant way to do it. The simplifier is already knee-deep in
1065 continuations. We have to keep the right in-scope set around; AND we have
1066 to get the effect that finding (error "foo") in a strict arg position will
1067 discard the entire application and replace it with (error "foo"). Getting
1068 all this at once is TOO HARD!
1070 %************************************************************************
1072 Rebuilding a cse expression
1074 %************************************************************************
1076 Blob of helper functions for the "case-of-something-else" situation.
1079 ---------------------------------------------------------
1080 -- Eliminate the case if possible
1082 rebuildCase :: SimplEnv
1083 -> OutExpr -- Scrutinee
1084 -> InId -- Case binder
1085 -> [InAlt] -- Alternatives (inceasing order)
1087 -> SimplM (SimplEnv, OutExpr)
1089 rebuildCase env scrut case_bndr alts cont
1090 | Just (con,args) <- exprIsConApp_maybe scrut
1091 -- Works when the scrutinee is a variable with a known unfolding
1092 -- as well as when it's an explicit constructor application
1093 = knownCon env scrut (DataAlt con) args case_bndr alts cont
1095 | Lit lit <- scrut -- No need for same treatment as constructors
1096 -- because literals are inlined more vigorously
1097 = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1100 = do { -- Prepare the continuation;
1101 -- The new subst_env is in place
1102 (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1104 -- Simplify the alternatives
1105 ; (case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
1106 ; let res_ty' = contResultType dup_cont
1107 ; case_expr <- mkCase scrut case_bndr' res_ty' alts'
1109 -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1110 -- The case binder *not* scope over the whole returned case-expression
1111 ; rebuild env case_expr nodup_cont }
1114 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1115 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1116 way, there's a chance that v will now only be used once, and hence
1119 Note [no-case-of-case]
1120 ~~~~~~~~~~~~~~~~~~~~~~
1121 There is a time we *don't* want to do that, namely when
1122 -fno-case-of-case is on. This happens in the first simplifier pass,
1123 and enhances full laziness. Here's the bad case:
1124 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1125 If we eliminate the inner case, we trap it inside the I# v -> arm,
1126 which might prevent some full laziness happening. I've seen this
1127 in action in spectral/cichelli/Prog.hs:
1128 [(m,n) | m <- [1..max], n <- [1..max]]
1129 Hence the check for NoCaseOfCase.
1131 Note [Suppressing the case binder-swap]
1132 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1133 There is another situation when it might make sense to suppress the
1134 case-expression binde-swap. If we have
1136 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1137 ...other cases .... }
1139 We'll perform the binder-swap for the outer case, giving
1141 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1142 ...other cases .... }
1144 But there is no point in doing it for the inner case, because w1 can't
1145 be inlined anyway. Furthermore, doing the case-swapping involves
1146 zapping w2's occurrence info (see paragraphs that follow), and that
1147 forces us to bind w2 when doing case merging. So we get
1149 case x of w1 { A -> let w2 = w1 in e1
1150 B -> let w2 = w1 in e2
1151 ...other cases .... }
1153 This is plain silly in the common case where w2 is dead.
1155 Even so, I can't see a good way to implement this idea. I tried
1156 not doing the binder-swap if the scrutinee was already evaluated
1157 but that failed big-time:
1161 case v of w { MkT x ->
1162 case x of x1 { I# y1 ->
1163 case x of x2 { I# y2 -> ...
1165 Notice that because MkT is strict, x is marked "evaluated". But to
1166 eliminate the last case, we must either make sure that x (as well as
1167 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1168 the binder-swap. So this whole note is a no-op.
1172 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1173 any occurrence info (eg IAmDead) in the case binder, because the
1174 case-binder now effectively occurs whenever v does. AND we have to do
1175 the same for the pattern-bound variables! Example:
1177 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1179 Here, b and p are dead. But when we move the argment inside the first
1180 case RHS, and eliminate the second case, we get
1182 case x of { (a,b) -> a b }
1184 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1187 Indeed, this can happen anytime the case binder isn't dead:
1188 case <any> of x { (a,b) ->
1189 case x of { (p,q) -> p } }
1190 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1191 The point is that we bring into the envt a binding
1193 after the outer case, and that makes (a,b) alive. At least we do unless
1194 the case binder is guaranteed dead.
1198 Consider case (v `cast` co) of x { I# ->
1199 ... (case (v `cast` co) of {...}) ...
1200 We'd like to eliminate the inner case. We can get this neatly by
1201 arranging that inside the outer case we add the unfolding
1202 v |-> x `cast` (sym co)
1203 to v. Then we should inline v at the inner case, cancel the casts, and away we go
1206 simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId)
1207 simplCaseBinder env scrut case_bndr
1208 | switchIsOn (getSwitchChecker env) NoCaseOfCase
1209 -- See Note [no-case-of-case]
1210 = do { (env, case_bndr') <- simplBinder env case_bndr
1211 ; return (env, case_bndr') }
1213 simplCaseBinder env (Var v) case_bndr
1214 -- Failed try [see Note 2 above]
1215 -- not (isEvaldUnfolding (idUnfolding v))
1216 = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
1217 ; return (modifyInScope env v case_bndr', case_bndr') }
1218 -- We could extend the substitution instead, but it would be
1219 -- a hack because then the substitution wouldn't be idempotent
1220 -- any more (v is an OutId). And this does just as well.
1222 simplCaseBinder env (Cast (Var v) co) case_bndr -- Note [Case of cast]
1223 = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
1224 ; let rhs = Cast (Var case_bndr') (mkSymCoercion co)
1225 ; return (addBinderUnfolding env v rhs, case_bndr') }
1227 simplCaseBinder env other_scrut case_bndr
1228 = do { (env, case_bndr') <- simplBinder env case_bndr
1229 ; return (env, case_bndr') }
1231 zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
1232 zapOccInfo b = b `setIdOccInfo` NoOccInfo
1236 simplAlts does two things:
1238 1. Eliminate alternatives that cannot match, including the
1239 DEFAULT alternative.
1241 2. If the DEFAULT alternative can match only one possible constructor,
1242 then make that constructor explicit.
1244 case e of x { DEFAULT -> rhs }
1246 case e of x { (a,b) -> rhs }
1247 where the type is a single constructor type. This gives better code
1248 when rhs also scrutinises x or e.
1250 Here "cannot match" includes knowledge from GADTs
1252 It's a good idea do do this stuff before simplifying the alternatives, to
1253 avoid simplifying alternatives we know can't happen, and to come up with
1254 the list of constructors that are handled, to put into the IdInfo of the
1255 case binder, for use when simplifying the alternatives.
1257 Eliminating the default alternative in (1) isn't so obvious, but it can
1260 data Colour = Red | Green | Blue
1269 DEFAULT -> [ case y of ... ]
1271 If we inline h into f, the default case of the inlined h can't happen.
1272 If we don't notice this, we may end up filtering out *all* the cases
1273 of the inner case y, which give us nowhere to go!
1277 simplAlts :: SimplEnv
1279 -> InId -- Case binder
1280 -> [InAlt] -> SimplCont
1281 -> SimplM (OutId, [OutAlt]) -- Includes the continuation
1282 -- Like simplExpr, this just returns the simplified alternatives;
1283 -- it not return an environment
1285 simplAlts env scrut case_bndr alts cont'
1286 = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1287 do { let alt_env = zapFloats env
1288 ; (alt_env, case_bndr') <- simplCaseBinder alt_env scrut case_bndr
1290 ; default_alts <- prepareDefault alt_env case_bndr' imposs_deflt_cons cont' maybe_deflt
1292 ; let inst_tys = tyConAppArgs (idType case_bndr')
1293 trimmed_alts = filter (is_possible inst_tys) alts_wo_default
1294 in_alts = mergeAlts default_alts trimmed_alts
1295 -- We need the mergeAlts in case the new default_alt
1296 -- has turned into a constructor alternative.
1298 ; alts' <- mapM (simplAlt alt_env imposs_cons case_bndr' cont') in_alts
1299 ; return (case_bndr', alts') }
1301 (alts_wo_default, maybe_deflt) = findDefault alts
1302 imposs_cons = case scrut of
1303 Var v -> otherCons (idUnfolding v)
1306 -- "imposs_deflt_cons" are handled either by the context,
1307 -- OR by a branch in this case expression. (Don't include DEFAULT!!)
1308 imposs_deflt_cons = nub (imposs_cons ++ [con | (con,_,_) <- alts_wo_default])
1310 is_possible :: [Type] -> CoreAlt -> Bool
1311 is_possible tys (con, _, _) | con `elem` imposs_cons = False
1312 is_possible tys (DataAlt con, _, _) = dataConCanMatch tys con
1313 is_possible tys alt = True
1315 ------------------------------------
1316 prepareDefault :: SimplEnv
1317 -> OutId -- Case binder; need just for its type. Note that as an
1318 -- OutId, it has maximum information; this is important.
1319 -- Test simpl013 is an example
1320 -> [AltCon] -- These cons can't happen when matching the default
1323 -> SimplM [InAlt] -- One branch or none; still unsimplified
1324 -- We use a list because it's what mergeAlts expects
1326 prepareDefault env case_bndr' imposs_cons cont Nothing
1327 = return [] -- No default branch
1329 prepareDefault env case_bndr' imposs_cons cont (Just rhs)
1330 | -- This branch handles the case where we are
1331 -- scrutinisng an algebraic data type
1332 Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr'),
1333 isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
1334 not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
1335 -- case x of { DEFAULT -> e }
1336 -- and we don't want to fill in a default for them!
1337 Just all_cons <- tyConDataCons_maybe tycon,
1338 not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
1339 -- which GHC allows, then the case expression will have at most a default
1340 -- alternative. We don't want to eliminate that alternative, because the
1341 -- invariant is that there's always one alternative. It's more convenient
1343 -- case x of { DEFAULT -> e }
1344 -- as it is, rather than transform it to
1345 -- error "case cant match"
1346 -- which would be quite legitmate. But it's a really obscure corner, and
1347 -- not worth wasting code on.
1349 let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type
1350 is_possible con = not (con `elem` imposs_data_cons)
1351 && dataConCanMatch inst_tys con
1352 = case filter is_possible all_cons of
1353 [] -> return [] -- Eliminate the default alternative
1354 -- altogether if it can't match
1356 [con] -> -- It matches exactly one constructor, so fill it in
1357 do { tick (FillInCaseDefault case_bndr')
1358 ; us <- getUniquesSmpl
1359 ; let (ex_tvs, co_tvs, arg_ids) =
1360 dataConRepInstPat us con inst_tys
1361 ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs)] }
1363 two_or_more -> return [(DEFAULT, [], rhs)]
1366 = return [(DEFAULT, [], rhs)]
1368 ------------------------------------
1369 simplAlt :: SimplEnv
1370 -> [AltCon] -- These constructors can't be present when
1371 -- matching this alternative
1372 -> OutId -- The case binder
1377 -- Simplify an alternative, returning the type refinement for the
1378 -- alternative, if the alternative does any refinement at all
1380 simplAlt env handled_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1381 = ASSERT( null bndrs )
1382 do { let env' = addBinderOtherCon env case_bndr' handled_cons
1383 -- Record the constructors that the case-binder *can't* be.
1384 ; rhs' <- simplExprC env' rhs cont'
1385 ; return (DEFAULT, [], rhs') }
1387 simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
1388 = ASSERT( null bndrs )
1389 do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1390 ; rhs' <- simplExprC env' rhs cont'
1391 ; return (LitAlt lit, [], rhs') }
1393 simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
1394 = do { -- Deal with the pattern-bound variables
1395 -- Mark the ones that are in ! positions in the data constructor
1396 -- as certainly-evaluated.
1397 -- NB: it happens that simplBinders does *not* erase the OtherCon
1398 -- form of unfolding, so it's ok to add this info before
1399 -- doing simplBinders
1400 (env, vs') <- simplBinders env (add_evals con vs)
1402 -- Bind the case-binder to (con args)
1403 ; let inst_tys' = tyConAppArgs (idType case_bndr')
1404 con_args = map Type inst_tys' ++ varsToCoreExprs vs'
1405 env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
1407 ; rhs' <- simplExprC env' rhs cont'
1408 ; return (DataAlt con, vs', rhs') }
1410 -- add_evals records the evaluated-ness of the bound variables of
1411 -- a case pattern. This is *important*. Consider
1412 -- data T = T !Int !Int
1414 -- case x of { T a b -> T (a+1) b }
1416 -- We really must record that b is already evaluated so that we don't
1417 -- go and re-evaluate it when constructing the result.
1418 -- See Note [Data-con worker strictness] in MkId.lhs
1419 add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
1421 cat_evals dc vs strs
1425 go (v:vs) strs | isTyVar v = v : go vs strs
1426 go (v:vs) (str:strs)
1427 | isMarkedStrict str = evald_v : go vs strs
1428 | otherwise = zapped_v : go vs strs
1430 zapped_v = zap_occ_info v
1431 evald_v = zapped_v `setIdUnfolding` evaldUnfolding
1432 go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
1434 -- If the case binder is alive, then we add the unfolding
1436 -- to the envt; so vs are now very much alive
1437 -- Note [Aug06] I can't see why this actually matters
1438 zap_occ_info | isDeadBinder case_bndr' = \id -> id
1439 | otherwise = zapOccInfo
1441 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1442 addBinderUnfolding env bndr rhs
1443 = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
1445 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1446 addBinderOtherCon env bndr cons
1447 = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
1451 %************************************************************************
1453 \subsection{Known constructor}
1455 %************************************************************************
1457 We are a bit careful with occurrence info. Here's an example
1459 (\x* -> case x of (a*, b) -> f a) (h v, e)
1461 where the * means "occurs once". This effectively becomes
1462 case (h v, e) of (a*, b) -> f a)
1464 let a* = h v; b = e in f a
1468 All this should happen in one sweep.
1471 knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
1472 -> InId -> [InAlt] -> SimplCont
1473 -> SimplM (SimplEnv, OutExpr)
1475 knownCon env scrut con args bndr alts cont
1476 = do { tick (KnownBranch bndr)
1477 ; knownAlt env scrut args bndr (findAlt con alts) cont }
1479 knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont
1481 do { env <- simplNonRecX env bndr scrut
1482 -- This might give rise to a binding with non-atomic args
1483 -- like x = Node (f x) (g x)
1484 -- but simplNonRecX will atomic-ify it
1485 ; simplExprF env rhs cont }
1487 knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont
1489 do { env <- simplNonRecX env bndr scrut
1490 ; simplExprF env rhs cont }
1492 knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont
1493 = do { let dead_bndr = isDeadBinder bndr
1494 n_drop_tys = tyConArity (dataConTyCon dc)
1495 ; env <- bind_args env dead_bndr bs (drop n_drop_tys args)
1497 -- It's useful to bind bndr to scrut, rather than to a fresh
1498 -- binding x = Con arg1 .. argn
1499 -- because very often the scrut is a variable, so we avoid
1500 -- creating, and then subsequently eliminating, a let-binding
1501 -- BUT, if scrut is a not a variable, we must be careful
1502 -- about duplicating the arg redexes; in that case, make
1503 -- a new con-app from the args
1504 bndr_rhs = case scrut of
1507 con_app = mkConApp dc (take n_drop_tys args ++ con_args)
1508 con_args = [substExpr env (varToCoreExpr b) | b <- bs]
1509 -- args are aready OutExprs, but bs are InIds
1511 ; env <- simplNonRecX env bndr bndr_rhs
1512 ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $
1513 simplExprF env rhs cont }
1516 bind_args env dead_bndr [] _ = return env
1518 bind_args env dead_bndr (b:bs) (Type ty : args)
1519 = ASSERT( isTyVar b )
1520 bind_args (extendTvSubst env b ty) dead_bndr bs args
1522 bind_args env dead_bndr (b:bs) (arg : args)
1524 do { let b' = if dead_bndr then b else zapOccInfo b
1525 -- Note that the binder might be "dead", because it doesn't occur
1526 -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
1527 -- Nevertheless we must keep it if the case-binder is alive, because it may
1528 -- be used in the con_app. See Note [zapOccInfo]
1529 ; env <- simplNonRecX env b' arg
1530 ; bind_args env dead_bndr bs args }
1532 bind_args _ _ _ _ = panic "bind_args"
1536 %************************************************************************
1538 \subsection{Duplicating continuations}
1540 %************************************************************************
1543 prepareCaseCont :: SimplEnv
1544 -> [InAlt] -> SimplCont
1545 -> SimplM (SimplEnv, SimplCont,SimplCont)
1546 -- Return a duplicatable continuation, a non-duplicable part
1547 -- plus some extra bindings (that scope over the entire
1550 -- No need to make it duplicatable if there's only one alternative
1551 prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont))
1552 prepareCaseCont env alts cont = mkDupableCont env cont
1556 mkDupableCont :: SimplEnv -> SimplCont
1557 -> SimplM (SimplEnv, SimplCont, SimplCont)
1559 mkDupableCont env cont
1560 | contIsDupable cont
1561 = returnSmpl (env, cont, mkBoringStop (contResultType cont))
1563 mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
1565 mkDupableCont env (CoerceIt ty cont)
1566 = do { (env, dup, nodup) <- mkDupableCont env cont
1567 ; return (env, CoerceIt ty dup, nodup) }
1569 mkDupableCont env cont@(StrictBind bndr _ _ se _)
1570 = return (env, mkBoringStop (substTy se (idType bndr)), cont)
1571 -- See Note [Duplicating strict continuations]
1573 mkDupableCont env cont@(StrictArg _ fun_ty _ _)
1574 = return (env, mkBoringStop (funArgTy fun_ty), cont)
1575 -- See Note [Duplicating strict continuations]
1577 mkDupableCont env (ApplyTo _ arg se cont)
1578 = -- e.g. [...hole...] (...arg...)
1580 -- let a = ...arg...
1581 -- in [...hole...] a
1582 do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1583 ; arg <- simplExpr (se `setInScope` env) arg
1584 ; (env, arg) <- makeTrivial env arg
1585 ; let app_cont = ApplyTo OkToDup arg (zapSubstEnv env) dup_cont
1586 ; return (env, app_cont, nodup_cont) }
1588 mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont)
1589 -- See Note [Single-alternative case]
1590 -- | not (exprIsDupable rhs && contIsDupable case_cont)
1591 -- | not (isDeadBinder case_bndr)
1592 | all isDeadBinder bs
1593 = return (env, mkBoringStop scrut_ty, cont)
1595 scrut_ty = substTy se (idType case_bndr)
1597 mkDupableCont env (Select _ case_bndr alts se cont)
1598 = -- e.g. (case [...hole...] of { pi -> ei })
1600 -- let ji = \xij -> ei
1601 -- in case [...hole...] of { pi -> ji xij }
1602 do { tick (CaseOfCase case_bndr)
1603 ; (env, dup_cont, nodup_cont) <- mkDupableCont env cont
1604 -- NB: call mkDupableCont here, *not* prepareCaseCont
1605 -- We must make a duplicable continuation, whereas prepareCaseCont
1606 -- doesn't when there is a single case branch
1608 ; let alt_env = se `setInScope` env
1609 ; (alt_env, case_bndr') <- simplBinder alt_env case_bndr
1610 ; alts' <- mapM (simplAlt alt_env [] case_bndr' dup_cont) alts
1611 -- Safe to say that there are no handled-cons for the DEFAULT case
1612 -- NB: simplBinder does not zap deadness occ-info, so
1613 -- a dead case_bndr' will still advertise its deadness
1614 -- This is really important because in
1615 -- case e of b { (# a,b #) -> ... }
1616 -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
1617 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1618 -- In the new alts we build, we have the new case binder, so it must retain
1620 -- NB: we don't use alt_env further; it has the substEnv for
1621 -- the alternatives, and we don't want that
1623 ; (env, alts') <- mkDupableAlts env case_bndr' alts'
1624 ; return (env, -- Note [Duplicated env]
1625 Select OkToDup case_bndr' alts' (zapSubstEnv env)
1626 (mkBoringStop (contResultType dup_cont)),
1630 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1631 -> SimplM (SimplEnv, [InAlt])
1632 -- Absorbs the continuation into the new alternatives
1634 mkDupableAlts env case_bndr' alts
1637 go env [] = return (env, [])
1639 = do { (env, alt') <- mkDupableAlt env case_bndr' alt
1640 ; (env, alts') <- go env alts
1641 ; return (env, alt' : alts' ) }
1643 mkDupableAlt env case_bndr' (con, bndrs', rhs')
1644 | exprIsDupable rhs' -- Note [Small alternative rhs]
1645 = return (env, (con, bndrs', rhs'))
1647 = do { let rhs_ty' = exprType rhs'
1648 used_bndrs' = filter abstract_over (case_bndr' : bndrs')
1650 | isTyVar bndr = True -- Abstract over all type variables just in case
1651 | otherwise = not (isDeadBinder bndr)
1652 -- The deadness info on the new Ids is preserved by simplBinders
1654 ; (final_bndrs', final_args) -- Note [Join point abstraction]
1655 <- if (any isId used_bndrs')
1656 then return (used_bndrs', varsToCoreExprs used_bndrs')
1657 else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy
1658 ; return ([rw_id], [Var realWorldPrimId]) }
1660 ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty')
1661 -- Note [Funky mkPiTypes]
1663 ; let -- We make the lambdas into one-shot-lambdas. The
1664 -- join point is sure to be applied at most once, and doing so
1665 -- prevents the body of the join point being floated out by
1666 -- the full laziness pass
1667 really_final_bndrs = map one_shot final_bndrs'
1668 one_shot v | isId v = setOneShotLambda v
1670 join_rhs = mkLams really_final_bndrs rhs'
1671 join_call = mkApps (Var join_bndr) final_args
1673 ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
1674 -- See Note [Duplicated env]
1677 Note [Duplicated env]
1678 ~~~~~~~~~~~~~~~~~~~~~
1679 Some of the alternatives are simplified, but have not been turned into a join point
1680 So they *must* have an zapped subst-env. So we can't use completeNonRecX to
1681 bind the join point, because it might to do PostInlineUnconditionally, and
1682 we'd lose that when zapping the subst-env. We could have a per-alt subst-env,
1683 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1684 at worst delays the join-point inlining.
1686 Note [Small alterantive rhs]
1687 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1688 It is worth checking for a small RHS because otherwise we
1689 get extra let bindings that may cause an extra iteration of the simplifier to
1690 inline back in place. Quite often the rhs is just a variable or constructor.
1691 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1692 iterations because the version with the let bindings looked big, and so wasn't
1693 inlined, but after the join points had been inlined it looked smaller, and so
1696 NB: we have to check the size of rhs', not rhs.
1697 Duplicating a small InAlt might invalidate occurrence information
1698 However, if it *is* dupable, we return the *un* simplified alternative,
1699 because otherwise we'd need to pair it up with an empty subst-env....
1700 but we only have one env shared between all the alts.
1701 (Remember we must zap the subst-env before re-simplifying something).
1702 Rather than do this we simply agree to re-simplify the original (small) thing later.
1704 Note [Funky mkPiTypes]
1705 ~~~~~~~~~~~~~~~~~~~~~~
1706 Notice the funky mkPiTypes. If the contructor has existentials
1707 it's possible that the join point will be abstracted over
1708 type varaibles as well as term variables.
1709 Example: Suppose we have
1710 data T = forall t. C [t]
1712 case (case e of ...) of
1714 We get the join point
1715 let j :: forall t. [t] -> ...
1716 j = /\t \xs::[t] -> rhs
1718 case (case e of ...) of
1719 C t xs::[t] -> j t xs
1721 Note [Join point abstaction]
1722 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1723 If we try to lift a primitive-typed something out
1724 for let-binding-purposes, we will *caseify* it (!),
1725 with potentially-disastrous strictness results. So
1726 instead we turn it into a function: \v -> e
1727 where v::State# RealWorld#. The value passed to this function
1728 is realworld#, which generates (almost) no code.
1730 There's a slight infelicity here: we pass the overall
1731 case_bndr to all the join points if it's used in *any* RHS,
1732 because we don't know its usage in each RHS separately
1734 We used to say "&& isUnLiftedType rhs_ty'" here, but now
1735 we make the join point into a function whenever used_bndrs'
1736 is empty. This makes the join-point more CPR friendly.
1737 Consider: let j = if .. then I# 3 else I# 4
1738 in case .. of { A -> j; B -> j; C -> ... }
1740 Now CPR doesn't w/w j because it's a thunk, so
1741 that means that the enclosing function can't w/w either,
1742 which is a lose. Here's the example that happened in practice:
1743 kgmod :: Int -> Int -> Int
1744 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1748 I have seen a case alternative like this:
1750 It's a bit silly to add the realWorld dummy arg in this case, making
1753 (the \v alone is enough to make CPR happy) but I think it's rare
1755 Note [Duplicating strict continuations]
1756 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1757 Do *not* duplicate StrictBind and StritArg continuations. We gain
1758 nothing by propagating them into the expressions, and we do lose a
1759 lot. Here's an example:
1760 && (case x of { T -> F; F -> T }) E
1761 Now, && is strict so we end up simplifying the case with
1762 an ArgOf continuation. If we let-bind it, we get
1764 let $j = \v -> && v E
1765 in simplExpr (case x of { T -> F; F -> T })
1767 And after simplifying more we get
1769 let $j = \v -> && v E
1770 in case x of { T -> $j F; F -> $j T }
1771 Which is a Very Bad Thing
1773 The desire not to duplicate is the entire reason that
1774 mkDupableCont returns a pair of continuations.
1776 The original plan had:
1777 e.g. (...strict-fn...) [...hole...]
1779 let $j = \a -> ...strict-fn...
1782 Note [Single-alternative cases]
1783 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1784 This case is just like the ArgOf case. Here's an example:
1788 case (case x of I# x' ->
1790 True -> I# (negate# x')
1791 False -> I# x') of y {
1793 Because the (case x) has only one alternative, we'll transform to
1795 case (case x' <# 0# of
1796 True -> I# (negate# x')
1797 False -> I# x') of y {
1799 But now we do *NOT* want to make a join point etc, giving
1801 let $j = \y -> MkT y
1803 True -> $j (I# (negate# x'))
1805 In this case the $j will inline again, but suppose there was a big
1806 strict computation enclosing the orginal call to MkT. Then, it won't
1807 "see" the MkT any more, because it's big and won't get duplicated.
1808 And, what is worse, nothing was gained by the case-of-case transform.
1810 When should use this case of mkDupableCont?
1811 However, matching on *any* single-alternative case is a *disaster*;
1812 e.g. case (case ....) of (a,b) -> (# a,b #)
1813 We must push the outer case into the inner one!
1816 * Match [(DEFAULT,_,_)], but in the common case of Int,
1817 the alternative-filling-in code turned the outer case into
1818 case (...) of y { I# _ -> MkT y }
1820 * Match on single alternative plus (not (isDeadBinder case_bndr))
1821 Rationale: pushing the case inwards won't eliminate the construction.
1822 But there's a risk of
1823 case (...) of y { (a,b) -> let z=(a,b) in ... }
1824 Now y looks dead, but it'll come alive again. Still, this
1825 seems like the best option at the moment.
1827 * Match on single alternative plus (all (isDeadBinder bndrs))
1828 Rationale: this is essentially seq.
1830 * Match when the rhs is *not* duplicable, and hence would lead to a
1831 join point. This catches the disaster-case above. We can test
1832 the *un-simplified* rhs, which is fine. It might get bigger or
1833 smaller after simplification; if it gets smaller, this case might
1834 fire next time round. NB also that we must test contIsDupable
1835 case_cont *btoo, because case_cont might be big!
1837 HOWEVER: I found that this version doesn't work well, because
1838 we can get let x = case (...) of { small } in ...case x...
1839 When x is inlined into its full context, we find that it was a bad
1840 idea to have pushed the outer case inside the (...) case.