2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[Simplify]{The main module of the simplifier}
7 module Simplify ( simplTopBinds, simplExpr, simplBind ) where
9 #include "HsVersions.h"
12 import CmdLineOpts ( SimplifierSwitch(..) )
13 import ConFold ( completePrim )
14 import CoreUnfold ( Unfolding, mkFormSummary, noUnfolding,
15 exprIsTrivial, whnfOrBottom, inlineUnconditionally,
18 import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
20 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
21 unTagBinders, squashableDictishCcExpr
23 import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
24 addIdArity, getIdArity, getIdSpecialisation, setIdSpecialisation,
25 getIdDemandInfo, addIdDemandInfo, isSpecPragmaId
27 import Name ( isExported, isLocallyDefined )
28 import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
29 atLeastArity, unknownArity )
30 import Literal ( isNoRepLit )
31 import Maybes ( maybeToBool )
32 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
33 import SimplCase ( simplCase, bindLargeRhs )
36 import SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders )
38 import SpecEnv ( isEmptySpecEnv, substSpecEnv )
39 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
40 mkFunTys, splitAlgTyConApp_maybe,
41 splitFunTys, splitFunTy_maybe, isUnpointedType
43 import TysPrim ( realWorldStatePrimTy )
44 import Util ( Eager, appEager, returnEager, runEager, mapEager,
45 isSingleton, zipEqual, zipWithEqual, mapAndUnzip
51 The controlling flags, and what they do
52 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
56 -fsimplify = run the simplifier
57 -ffloat-inwards = runs the float lets inwards pass
58 -ffloat = runs the full laziness pass
59 (ToDo: rename to -ffull-laziness)
60 -fupdate-analysis = runs update analyser
61 -fstrictness = runs strictness analyser
62 -fsaturate-apps = saturates applications (eta expansion)
66 -ffloat-past-lambda = OK to do full laziness.
67 (ToDo: remove, as the full laziness pass is
68 useless without this flag, therefore
69 it is unnecessary. Just -ffull-laziness
72 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
73 let is strict or if the floating will expose
76 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
77 is a primop that cannot fail [simplifier].
79 -fcode-duplication-ok = allows the previous option to work on cases with
80 multiple branches [simplifier].
82 -flet-to-case = does let-to-case transformation [simplifier].
84 -fcase-of-case = does case of case transformation [simplifier].
86 -fpedantic-bottoms = does not allow:
87 case x of y -> e ===> e[x/y]
88 (which may turn bottom into non-bottom)
94 Inlining is one of the delicate aspects of the simplifier. By
95 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
96 the RHS of x's definition. Thus
98 let x = e in ...x... ===> let x = e in ...e...
100 We have two mechanisms for inlining:
102 1. Unconditional. The occurrence analyser has pinned an (OneOcc
103 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
104 certainly safe to inline this variable, and to drop its binding''.
105 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
106 happy to be duplicating code...) When it encounters such a beast, the
107 simplifer binds the variable to its RHS (in the id_env) and continues.
108 It doesn't even look at the RHS at that stage. It also drops the
111 2. Conditional. In all other situations, the simplifer simplifies
112 the RHS anyway, and keeps the new binding. It also binds the new
113 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
115 Here, ``suitable'' might mean NoUnfolding (if the occurrence
116 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
117 the variable has an INLINE pragma on it). The idea is that anything
118 in the UnfoldEnv is safe to use, but also has an enclosing binding if
119 you decide not to use it.
123 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
126 At one time I thought it would be OK to put non-HNF unfoldings in for
127 variables which occur only once [if they got inlined at that
128 occurrence the RHS of the binding would become dead, so no duplication
129 would occur]. But consider:
132 f = \y -> ...y...y...y...
135 Now, it seems that @x@ appears only once, but even so it is NOT safe
136 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
137 duplicate the references to @x@.
139 Because of this, the "unconditional-inline" mechanism above is the
140 only way in which non-HNFs can get inlined.
145 When a variable has an INLINE pragma on it --- which includes wrappers
146 produced by the strictness analyser --- we treat it rather carefully.
148 For a start, we are careful not to substitute into its RHS, because
149 that might make it BIG, and the user said "inline exactly this", not
150 "inline whatever you get after inlining other stuff inside me". For
154 in {-# INLINE y #-} y = f 3
157 Here we don't want to substitute BIG for the (single) occurrence of f,
158 because then we'd duplicate BIG when we inline'd y. (Exception:
159 things in the UnfoldEnv with UnfoldAlways flags, which originated in
160 other INLINE pragmas.)
162 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
163 going into such an RHS.
165 What about imports? They don't really matter much because we only
166 inline relatively small things via imports.
168 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
169 INLINE pragma. We also do this for the RHSs of recursive decls,
170 before looking at the recursive decls. That way we achieve the effect
171 of inlining a wrapper in the body of its worker, in the case of a
172 mutually-recursive worker/wrapper split.
175 %************************************************************************
177 \subsection[Simplify-simplExpr]{The main function: simplExpr}
179 %************************************************************************
181 At the top level things are a little different.
183 * No cloning (not allowed for exported Ids, unnecessary for the others)
184 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
187 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
189 -- Dead code is now discarded by the occurrence analyser,
191 simplTopBinds env binds
192 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
193 simpl_top_binds env (concat binds_s)
195 simpl_top_binds env [] = returnSmpl []
197 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
198 = --- No cloning necessary at top level
199 simplBinder env binder `thenSmpl` \ (env1, out_id) ->
200 simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) ->
201 completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1) ->
202 simpl_top_binds new_env binds `thenSmpl` \ binds2 ->
203 returnSmpl (binds1 ++ binds2)
205 simpl_top_binds env (Rec pairs : binds)
206 = -- No cloning necessary at top level, but we nevertheless
207 -- add the Ids to the environment. This makes sure that
208 -- info carried on the Id (such as arity info) gets propagated
211 -- This may seem optional, but I found an occasion when it Really matters.
212 -- Consider foo{n} = ...foo...
215 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
216 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
217 -- thing: baz*{n} = ...baz...
219 -- Sure we could have made the indirection-shorting a bit cleverer, but
220 -- propagating pragma info is a Good Idea anyway.
221 simplBinders env (map fst pairs) `thenSmpl` \ (env1, out_ids) ->
222 simplRecursiveGroup env1 out_ids pairs `thenSmpl` \ (bind', new_env) ->
223 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
224 returnSmpl (Rec bind' : binds')
227 %************************************************************************
229 \subsection[Simplify-simplExpr]{The main function: simplExpr}
231 %************************************************************************
235 simplExpr :: SimplEnv
236 -> InExpr -> [OutArg]
237 -> OutType -- Type of (e args); i.e. type of overall result
241 The expression returned has the same meaning as the input expression
242 applied to the specified arguments.
249 simplExpr env (Var var) args result_ty
250 = simplVar env False {- No InlineCall -} var args result_ty
257 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
259 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
263 Primitive applications are simple.
264 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
266 NB: Prim expects an empty argument list! (Because it should be
267 saturated and not higher-order. ADR)
270 simplExpr env (Prim op prim_args) args result_ty
272 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
273 simpl_op op `appEager` \ op' ->
274 completePrim env op' prim_args'
276 -- PrimOps just need any types in them renamed.
278 simpl_op (CCallOp label is_asm may_gc cconv arg_tys result_ty)
279 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
280 simplTy env result_ty `appEager` \ result_ty' ->
281 returnEager (CCallOp label is_asm may_gc cconv arg_tys' result_ty')
283 simpl_op other_op = returnEager other_op
286 Constructor applications
287 ~~~~~~~~~~~~~~~~~~~~~~~~
288 Nothing to try here. We only reuse constructors when they appear as the
289 rhs of a let binding (see completeLetBinding).
292 simplExpr env (Con con con_args) args result_ty
293 = ASSERT( null args )
294 mapEager (simplArg env) con_args `appEager` \ con_args' ->
295 returnSmpl (Con con con_args')
299 Applications are easy too:
300 ~~~~~~~~~~~~~~~~~~~~~~~~~~
301 Just stuff 'em in the arg stack
304 simplExpr env (App fun arg) args result_ty
305 = simplArg env arg `appEager` \ arg' ->
306 simplExpr env fun (arg' : args) result_ty
312 First the case when it's applied to an argument.
315 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
316 = tick TyBetaReduction `thenSmpl_`
317 simplExpr (bindTyVar env tyvar ty) body args result_ty
321 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
322 = simplTyBinder env tyvar `thenSmpl` \ (new_env, tyvar') ->
324 new_result_ty = applyTy result_ty (mkTyVarTy tyvar')
326 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
327 returnSmpl (Lam (TyBinder tyvar') body')
330 simplExpr env e@(Lam (TyBinder _) _) args@(_ : _) result_ty
331 = pprPanic "simplExpr:TyLam with non-TyArg" (ppr e $$ ppr args)
339 There's a complication with lambdas that aren't saturated.
344 If we did nothing, x is used inside the \y, so would be marked
345 as dangerous to dup. But in the common case where the abstraction
346 is applied to two arguments this is over-pessimistic.
347 So instead we don't take account of the \y when dealing with x's usage;
348 instead, the simplifier is careful when partially applying lambdas.
351 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
352 = go 0 env expr orig_args
354 go n env (Lam (ValBinder binder) body) (val_arg : args)
355 | isValArg val_arg -- The lambda has an argument
356 = tick BetaReduction `thenSmpl_`
357 go (n+1) (bindIdToAtom env binder val_arg) body args
359 go n env expr@(Lam (ValBinder binder) body) args
360 -- The lambda is un-saturated, so we must zap the occurrence info
361 -- on the arguments we've already beta-reduced into the body of the lambda
362 = ASSERT( null args ) -- Value lambda must match value argument!
364 new_env = markDangerousOccs env orig_args
366 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
367 `thenSmpl` \ (expr', arity) ->
370 go n env non_val_lam_expr args -- The lambda had enough arguments
371 = simplExpr env non_val_lam_expr args result_ty
379 simplExpr env (Let bind body) args result_ty
380 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
387 simplExpr env expr@(Case scrut alts) args result_ty
388 = simplCase env scrut
389 (getSubstEnvs env, alts)
390 (\env rhs -> simplExpr env rhs args result_ty)
398 simplExpr env (Note (Coerce to_ty from_ty) body) args result_ty
399 = simplCoerce env to_ty from_ty body args result_ty
401 simplExpr env (Note (SCC cc) body) args result_ty
402 = simplSCC env cc body args result_ty
404 -- InlineCall is simple enough to deal with on the spot
405 -- The only complication is that we slide the InlineCall
406 -- inwards past any function arguments
407 simplExpr env (Note InlineCall expr) args result_ty
410 go (Var v) args = simplVar env True {- InlineCall -} v args result_ty
412 go (App fun arg) args = simplArg env arg `appEager` \ arg' ->
415 go other args = -- Unexpected discard; report it
416 pprTrace "simplExpr: discarding InlineCall" (ppr expr) $
417 simplExpr env other args result_ty
422 %************************************************************************
424 \subsection{Simplify RHS of a Let/Letrec}
426 %************************************************************************
428 simplRhsExpr does arity-expansion. That is, given:
430 * a right hand side /\ tyvars -> \a1 ... an -> e
431 * the information (stored in BinderInfo) that the function will always
432 be applied to at least k arguments
434 it transforms the rhs to
436 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
438 This is a Very Good Thing!
445 -> OutId -- The new binder (used only for its type)
446 -> SmplM (OutExpr, ArityInfo)
451 simplRhsExpr env binder@(id,occ_info) rhs new_id
452 | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
453 -- Deal with the data type case, in which case the elaborate
454 -- eta-expansion nonsense is really quite a waste of time.
455 = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
456 returnSmpl (rhs', ArityExactly 0)
458 | otherwise -- OK, use the big hammer
459 = -- Deal with the big lambda part
460 simplTyBinders rhs_env tyvars `thenSmpl` \ (lam_env, tyvars') ->
462 body_ty = applyTys rhs_ty (mkTyVarTys tyvars')
464 -- Deal with the little lambda part
465 -- Note that we call simplLam even if there are no binders,
466 -- in case it can do arity expansion.
467 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
469 -- Put on the big lambdas, trying to float out any bindings caught inside
470 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
472 returnSmpl (rhs', arity)
474 rhs_ty = idType new_id
475 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
476 = switchOffInlining env1 -- See comments with switchOffInlining
480 -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
481 -- for the rhs of top level defs is "OST_CENTRE". Consider
483 -- g = \y -> let v = f y in scc "x" (v ...)
484 -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
485 -- want to inline "v" since its CC is dynamically determined.
487 current_cc = getEnclosingCC env
488 env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
491 (tyvars, body) = collectTyBinders rhs
495 ----------------------------------------------------------------
496 An old special case that is now nuked.
498 First a special case for variable right-hand sides
500 It's OK to simplify the RHS, but it's often a waste of time. Often
501 these v = w things persist because v is exported, and w is used
502 elsewhere. So if we're not careful we'll eta expand the rhs, only
503 to eta reduce it in competeNonRec.
505 If we leave the binding unchanged, we will certainly replace v by w at
506 every occurrence of v, which is good enough.
508 In fact, it's *better* to replace v by w than to inline w in v's rhs,
509 even if this is the only occurrence of w. Why? Because w might have
510 IdInfo (such as strictness) that v doesn't.
512 Furthermore, there might be other uses of w; if so, inlining w in
513 v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
515 HOWEVER, we have to be careful if w is something that *must* be
516 inlined. In particular, its binding may have been dropped. Here's
517 an example that actually happened:
518 let x = let y = e in y
520 The "let y" was floated out, and then (since y occurs once in a
521 definitely inlinable position) the binding was dropped, leaving
522 {y=e} let x = y in f x
523 But now using the reasoning of this little section,
524 y wasn't inlined, because it was a let x=y form.
529 This "optimisation" turned out to be a bad idea. If there's are
530 top-level exported bindings like
535 then y wasn't getting inlined in x's rhs, and we were getting
536 bad code. So I've removed the special case from here, and
537 instead we only try eta reduction and constructor reuse
538 in completeNonRec if the thing is *not* exported.
542 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
543 | maybeToBool maybe_stop_at_var
544 = returnSmpl (Var the_var, getIdArity the_var)
547 = case (runEager $ lookupId env v) of
548 VarArg v' | not (must_unfold v') -> Just v'
551 Just the_var = maybe_stop_at_var
553 must_unfold v' = idMustBeINLINEd v'
554 || case lookupOutIdEnv env v' of
555 Just (_, _, InUnfolding _ _) -> True
559 End of old, nuked, special case.
560 ------------------------------------------------------------------
563 %************************************************************************
565 \subsection{Simplify a lambda abstraction}
567 %************************************************************************
569 Simplify (\binders -> body) trying eta expansion and reduction, given that
570 the abstraction will always be applied to at least min_no_of_args.
573 simplValLam env expr min_no_of_args expr_ty
574 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
576 exprIsTrivial expr || -- or it's a trivial RHS
577 -- No eta expansion for trivial RHSs
578 -- It's rather a Bad Thing to expand
581 -- g = \a b c -> f alpha beta a b c
583 -- The original RHS is "trivial" (exprIsTrivial), because it generates
584 -- no code (renames f to g). But the new RHS isn't.
586 null potential_extra_binder_tys || -- or ain't a function
587 no_of_extra_binders <= 0 -- or no extra binders needed
588 = simplBinders env binders `thenSmpl` \ (new_env, binders') ->
589 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
590 returnSmpl (mkValLam binders' body', final_arity)
592 | otherwise -- Eta expansion possible
593 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
594 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
595 pprTrace "simplValLam" (vcat [ppr expr,
598 int no_of_extra_binders,
599 ppr potential_extra_binder_tys])
602 tick EtaExpansion `thenSmpl_`
603 simplBinders env binders `thenSmpl` \ (new_env, binders') ->
604 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
605 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
607 mkValLam (binders' ++ extra_binders') body',
612 (binders,body) = collectValBinders expr
613 no_of_binders = length binders
614 (arg_tys, res_ty) = splitFunTys expr_ty
615 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
616 pprTrace "simplValLam" (vcat [ppr expr,
620 drop no_of_binders arg_tys
621 body_ty = mkFunTys potential_extra_binder_tys res_ty
623 -- Note: it's possible that simplValLam will be applied to something
624 -- with a forall type. Eg when being applied to the rhs of
626 -- where wurble has a forall-type, but no big lambdas at the top.
627 -- We could be clever an insert new big lambdas, but we don't bother.
629 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
630 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
631 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
633 no_of_extra_binders = -- First, use the info about how many args it's
634 -- always applied to in its scope; but ignore this
635 -- info for thunks. To see why we ignore it for thunks,
636 -- consider let f = lookup env key in (f 1, f 2)
637 -- We'd better not eta expand f just because it is
639 (min_no_of_args - no_of_binders)
641 -- Next, try seeing if there's a lambda hidden inside
643 -- etaExpandCount can reuturn a huge number (like 10000!) if
644 -- it finds that the body is a call to "error"; hence
645 -- the use of "min" here.
647 (etaExpandCount body `min` length potential_extra_binder_tys)
649 -- Finally, see if it's a state transformer, in which
650 -- case we eta-expand on principle! This can waste work,
651 -- but usually doesn't
653 case potential_extra_binder_tys of
654 [ty] | ty == realWorldStatePrimTy -> 1
659 %************************************************************************
661 \subsection[Simplify-var]{Variables}
663 %************************************************************************
665 Check if there's a macro-expansion, and if so rattle on. Otherwise do
666 the more sophisticated stuff.
669 simplVar env inline_call var args result_ty
670 = case lookupIdSubst env var of
672 Just (SubstExpr ty_subst id_subst expr)
673 -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty
675 Just (SubstLit lit) -- A boring old literal
676 -> ASSERT( null args )
679 Just (SubstVar var') -- More interesting! An id!
680 -> completeVar env inline_call var' args result_ty
682 Nothing -- Not in the substitution; hand off to completeVar
683 -> completeVar env inline_call var args result_ty
687 %************************************************************************
689 \subsection[Simplify-coerce]{Coerce expressions}
691 %************************************************************************
694 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
695 simplCoerce env to_ty from_ty expr@(Case scrut alts) args result_ty
696 = simplCase env scrut (getSubstEnvs env, alts)
697 (\env rhs -> simplCoerce env to_ty from_ty rhs args result_ty)
700 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
701 simplCoerce env to_ty from_ty (Let bind body) args result_ty
702 = simplBind env bind (\env -> simplCoerce env to_ty from_ty body args result_ty) result_ty
705 -- NB: we do *not* push the argments inside the coercion
707 simplCoerce env to_ty from_ty expr args result_ty
708 = simplTy env to_ty `appEager` \ to_ty' ->
709 simplTy env from_ty `appEager` \ from_ty' ->
710 simplExpr env expr [] from_ty' `thenSmpl` \ expr' ->
711 returnSmpl (mkGenApp (mkCoerce to_ty' from_ty' expr') args)
713 -- Try cancellation; we do this "on the way up" because
714 -- I think that's where it'll bite best
715 mkCoerce to_ty1 from_ty1 (Note (Coerce to_ty2 from_ty2) body)
716 = ASSERT( from_ty1 == to_ty2 )
717 mkCoerce to_ty1 from_ty2 body
718 mkCoerce to_ty from_ty body
719 | to_ty == from_ty = body
720 | otherwise = Note (Coerce to_ty from_ty) body
724 %************************************************************************
726 \subsection[Simplify-scc]{SCC expressions
728 %************************************************************************
730 1) Eliminating nested sccs ...
731 We must be careful to maintain the scc counts ...
734 simplSCC env cc1 (Note (SCC cc2) expr) args result_ty
735 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
736 -- eliminate inner scc if no call counts and same cc as outer
737 = simplSCC env cc1 expr args result_ty
739 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
740 -- eliminate outer scc if no call counts associated with either ccs
741 = simplSCC env cc2 expr args result_ty
744 2) Moving sccs inside lambdas ...
747 simplSCC env cc (Lam binder@(ValBinder _) body) args result_ty
748 | not (isSccCountCostCentre cc)
749 -- move scc inside lambda only if no call counts
750 = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
752 simplSCC env cc (Lam binder body) args result_ty
753 -- always ok to move scc inside type/usage lambda
754 = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
757 3) Eliminating dict sccs ...
760 simplSCC env cc expr args result_ty
761 | squashableDictishCcExpr cc expr
762 -- eliminate dict cc if trivial dict expression
763 = simplExpr env expr args result_ty
766 4) Moving arguments inside the body of an scc ...
767 This moves the cost of doing the application inside the scc
768 (which may include the cost of extracting methods etc)
771 simplSCC env cc body args result_ty
773 new_env = setEnclosingCC env cc
775 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
776 returnSmpl (Note (SCC cc) body')
780 %************************************************************************
782 \subsection[Simplify-bind]{Binding groups}
784 %************************************************************************
787 simplBind :: SimplEnv
789 -> (SimplEnv -> SmplM OutExpr)
793 simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
794 simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
798 %************************************************************************
800 \subsection[Simplify-let]{Let-expressions}
802 %************************************************************************
806 The booleans controlling floating have to be set with a little care.
807 Here's one performance bug I found:
809 let x = let y = let z = case a# +# 1 of {b# -> E1}
814 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
815 Before case_floating_ok included float_exposes_hnf, the case expression was floated
816 *one level per simplifier iteration* outwards. So it made th s
819 Floating case from let
820 ~~~~~~~~~~~~~~~~~~~~~~
821 When floating cases out of lets, remember this:
823 let x* = case e of alts
826 where x* is sure to be demanded or e is a cheap operation that cannot
827 fail, e.g. unboxed addition. Here we should be prepared to duplicate
828 <small expr>. A good example:
837 p1 -> foldr c n (build e1)
838 p2 -> foldr c n (build e2)
840 NEW: We use the same machinery that we use for case-of-case to
841 *always* do case floating from let, that is we let bind and abstract
842 the original let body, and let the occurrence analyser later decide
843 whether the new let should be inlined or not. The example above
847 let join_body x' = foldr c n x'
849 p1 -> let x* = build e1
851 p2 -> let x* = build e2
854 note that join_body is a let-no-escape.
855 In this particular example join_body will later be inlined,
856 achieving the same effect.
857 ToDo: check this is OK with andy
860 Let to case: two points
863 Point 1. We defer let-to-case for all data types except single-constructor
864 ones. Suppose we change
870 It can be the case that we find that b ultimately contains ...(case x of ..)....
871 and this is the only occurrence of x. Then if we've done let-to-case
872 we can't inline x, which is a real pain. On the other hand, we lose no
873 transformations by not doing this transformation, because the relevant
874 case-of-X transformations are also implemented by simpl_bind.
876 If x is a single-constructor type, then we go ahead anyway, giving
878 case e of (y,z) -> let x = (y,z) in b
880 because now we can squash case-on-x wherever they occur in b.
882 We do let-to-case on multi-constructor types in the tidy-up phase
883 (tidyCoreExpr) mainly so that the code generator doesn't need to
884 spot the demand-flag.
887 Point 2. It's important to try let-to-case before doing the
888 strict-let-of-case transformation, which happens in the next equation
891 let a*::Int = case v of {p1->e1; p2->e2}
894 (The * means that a is sure to be demanded.)
895 If we do case-floating first we get this:
899 p1-> let a*=e1 in k a
900 p2-> let a*=e2 in k a
902 Now watch what happens if we do let-to-case first:
904 case (case v of {p1->e1; p2->e2}) of
905 Int a# -> let a*=I# a# in b
907 let k = \a# -> let a*=I# a# in b
909 p1 -> case e1 of I# a# -> k a#
910 p1 -> case e2 of I# a# -> k a#
912 The latter is clearly better. (Remember the reboxing let-decl for a
913 is likely to go away, because after all b is strict in a.)
915 We do not do let to case for WHNFs, e.g.
921 as this is less efficient. but we don't mind doing let-to-case for
922 "bottom", as that will allow us to remove more dead code, if anything:
926 case error of x -> ...
930 Notice that let to case occurs only if x is used strictly in its body
935 -- Dead code is now discarded by the occurrence analyser,
937 simplNonRec env binder@(id,_) rhs body_c body_ty
938 | inlineUnconditionally binder
939 = -- The binder is used in definitely-inline way in the body
940 -- So add it to the environment, drop the binding, and continue
941 body_c (bindIdToExpr env binder rhs)
943 | idWantsToBeINLINEd id
944 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
947 -- Do let-to-case right away for unpointed types
948 -- These shouldn't occur much, but do occur right after desugaring,
949 -- because we havn't done dependency analysis at that point, so
950 -- we can't trivially do let-to-case (because there may be some unboxed
951 -- things bound in letrecs that aren't really recursive).
952 | isUnpointedType rhs_ty && not rhs_is_whnf
953 = simplCase env rhs (getSubstEnvs env, PrimAlts [] (BindDefault binder (Var id)))
954 (\env rhs -> complete_bind env rhs) body_ty
956 -- Try let-to-case; see notes below about let-to-case
960 || (not rhs_is_whnf && singleConstructorType rhs_ty)
961 -- Don't do let-to-case if the RHS is a constructor application.
962 -- Even then only do it for single constructor types.
963 -- For other types we defer doing it until the tidy-up phase at
964 -- the end of simplification.
966 = tick Let2Case `thenSmpl_`
967 simplCase env rhs (getSubstEnvs env, AlgAlts [] (BindDefault binder (Var id)))
968 (\env rhs -> complete_bind env rhs) body_ty
969 -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
970 -- NB: it's tidier to call complete_bind not simpl_bind, else
971 -- we nearly end up in a loop. Consider:
973 -- ==> case rhs of (p,q) -> let x=(p,q) in b
974 -- This effectively what the above simplCase call does.
975 -- Now, the inner let is a let-to-case target again! Actually, since
976 -- the RHS is in WHNF it won't happen, but it's a close thing!
982 simpl_bind env (Let bind rhs) | let_floating_ok
983 = tick LetFloatFromLet `thenSmpl_`
984 simplBind env (if will_be_demanded then bind
985 else un_demandify_bind bind)
986 (\env -> simpl_bind env rhs) body_ty
988 -- Try case-from-let; this deals with a strict let of error too
989 simpl_bind env (Case scrut alts) | case_floating_ok scrut
990 = tick CaseFloatFromLet `thenSmpl_`
992 -- First, bind large let-body if necessary
993 if isSingleton (nonErrorRHSs alts)
995 simplCase env scrut (getSubstEnvs env, alts)
996 (\env rhs -> simpl_bind env rhs) body_ty
998 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
1000 body_c' = \env -> simplExpr env new_body [] body_ty
1001 case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
1003 simplCase env scrut (getSubstEnvs env, alts) case_c body_ty `thenSmpl` \ case_expr ->
1004 returnSmpl (Let extra_binding case_expr)
1006 -- None of the above; simplify rhs and tidy up
1007 simpl_bind env rhs = complete_bind env rhs
1009 complete_bind env rhs
1010 = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) ->
1011 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
1012 completeNonRec env_w_clone binder
1013 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
1014 body_c new_env `thenSmpl` \ body' ->
1015 returnSmpl (mkCoLetsAny binds body')
1018 -- All this stuff is computed at the start of the simpl_bind loop
1019 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1020 float_primops = switchIsSet env SimplOkToFloatPrimOps
1021 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1022 try_let_to_case = switchIsSet env SimplLetToCase
1023 no_float = switchIsSet env SimplNoLetFromStrictLet
1025 demand_info = getIdDemandInfo id
1026 will_be_demanded = willBeDemanded demand_info
1029 form = mkFormSummary rhs
1030 rhs_is_bot = case form of
1033 rhs_is_whnf = case form of
1038 float_exposes_hnf = floatExposesHNF float_lets float_primops rhs
1040 let_floating_ok = (will_be_demanded && not no_float) ||
1041 always_float_let_from_let ||
1044 case_floating_ok scrut = (will_be_demanded && not no_float) ||
1045 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
1050 @completeNonRec@ looks at the simplified post-floating RHS of the
1051 let-expression, with a view to turning
1055 where y is just a variable. Now we can eliminate the binding
1056 altogether, and replace x by y throughout.
1058 There are two cases when we can do this:
1060 * When e is a constructor application, and we have
1061 another variable in scope bound to the same
1062 constructor application. [This is just a special
1063 case of common-subexpression elimination.]
1065 * When e can be eta-reduced to a variable. E.g.
1069 HOWEVER, if x is exported, we don't attempt this at all. Why not?
1070 Because then we can't remove the x=y binding, in which case we
1071 have just made things worse, perhaps a lot worse.
1074 completeNonRec env binder new_id new_rhs
1075 = returnSmpl (env', [NonRec b r | (b,r) <- binds])
1077 (env', binds) = completeBind env binder new_id new_rhs
1080 completeBind :: SimplEnv
1081 -> InBinder -> OutId -> OutExpr -- Id and RHS
1082 -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
1084 completeBind env binder@(old_id,occ_info) new_id new_rhs
1085 | not (idMustNotBeINLINEd new_id)
1086 && atomic_rhs -- If rhs (after eta reduction) is atomic
1087 && not (isExported new_id) -- and binder isn't exported
1088 && not (isSpecPragmaId new_id) -- Don't discard spec prag Ids
1090 = -- Drop the binding completely
1092 env1 = notInScope env new_id
1093 env2 = bindIdToAtom env1 binder the_arg
1097 | otherwise -- Non-atomic
1098 -- The big deal here is that we simplify the
1099 -- SpecEnv of the Id, if any. We used to do that in simplBinders, but
1100 -- that didn't work because it didn't take account of the fact that
1101 -- one of the mutually recursive group might mention one of the others
1104 id_w_specenv | isEmptySpecEnv spec_env = new_id
1105 | otherwise = setIdSpecialisation new_id spec_env'
1107 env1 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1108 = extendEnvGivenUnfolding env id_w_specenv occ_info noUnfolding
1109 -- Still need to record the new_id with its SpecEnv
1111 | otherwise -- Can inline it
1112 = extendEnvGivenBinding env occ_info id_w_specenv new_rhs
1114 new_binds = [(id_w_specenv, new_rhs)]
1119 spec_env = getIdSpecialisation old_id
1120 spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
1121 (ty_subst,id_subst) = getSubstEnvs env
1123 atomic_rhs = is_atomic eta'd_rhs
1124 eta'd_rhs = case lookForConstructor env new_rhs of
1126 other -> etaCoreExpr new_rhs
1128 the_arg = case eta'd_rhs of
1133 ----------------------------------------------------------------------------
1134 A digression on constructor CSE
1142 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1143 bit on the compiler technology, but in general I believe not. For
1144 example, here's some code from a real program:
1146 const.Int.max.wrk{-s2516-} =
1147 \ upk.s3297# upk.s3298# ->
1151 a.s3299 = I#! upk.s3297#
1153 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1154 _LT -> I#! upk.s3298#
1159 The a.s3299 really isn't doing much good. We'd be better off inlining
1160 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1162 So the current strategy is to inline all known-form constructors, and
1163 only do the reverse (turn a constructor application back into a
1164 variable) when we find a let-expression:
1168 ... (let y = C a1 .. an in ...) ...
1170 where it is always good to ditch the binding for y, and replace y by
1173 ----------------------------------------------------------------------------
1175 ----------------------------------------------------------------------------
1176 A digression on "optimising" coercions
1178 The trouble is that we kept transforming
1186 and counting a couple of ticks for this non-transformation
1188 -- We want to ensure that all let-bound Coerces have
1189 -- atomic bodies, so they can freely be inlined.
1190 completeNonRec env binder new_id (Coerce coercion ty rhs)
1191 | not (is_atomic rhs)
1192 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1194 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1195 -- Dangerous occ because, like constructor args,
1196 -- it can be duplicated easily
1198 atomic_rhs = case runEager $ lookupId env1 inner_id of
1202 completeNonRec env1 binder new_id
1203 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1205 returnSmpl (env2, binds1 ++ binds2)
1207 ----------------------------------------------------------------------------
1211 %************************************************************************
1213 \subsection[Simplify-letrec]{Letrec-expressions}
1215 %************************************************************************
1219 Here's the game plan
1221 1. Float any let(rec)s out of the RHSs
1222 2. Clone all the Ids and extend the envt with these clones
1223 3. Simplify one binding at a time, adding each binding to the
1224 environment once it's done.
1226 This relies on the occurrence analyser to
1227 a) break all cycles with an Id marked MustNotBeInlined
1228 b) sort the decls into topological order
1229 The former prevents infinite inlinings, and the latter means
1230 that we get maximum benefit from working top to bottom.
1234 simplRec env pairs body_c body_ty
1235 = -- Do floating, if necessary
1236 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1238 binders = map fst pairs'
1240 simplBinders env binders `thenSmpl` \ (env_w_clones, ids') ->
1241 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1243 body_c new_env `thenSmpl` \ body' ->
1245 returnSmpl (Let (Rec pairs') body')
1249 -- The env passed to simplRecursiveGroup already has
1250 -- bindings that clone the variables of the group.
1251 simplRecursiveGroup env new_ids []
1252 = returnSmpl ([], env)
1254 simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs)
1255 | inlineUnconditionally binder
1256 = -- Single occurrence, so drop binding and extend env with the inlining
1257 -- This is a little delicate, because what if the unique occurrence
1258 -- is *before* this binding? This'll never happen, because
1259 -- either it'll be marked "never inline" or else its occurrence will
1260 -- occur after its binding in the group.
1262 -- If these claims aren't right Core Lint will spot an unbound
1263 -- variable. A quick fix is to delete this clause for simplRecursiveGroup
1265 new_env = bindIdToExpr env binder rhs
1267 simplRecursiveGroup new_env new_ids pairs
1269 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1271 new_id' = new_id `withArity` arity
1272 (new_env, new_binds') = completeBind env binder new_id' new_rhs
1274 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1275 returnSmpl (new_binds' ++ new_pairs, final_env)
1281 floatBind :: SimplEnv
1282 -> Bool -- True <=> Top level
1284 -> SmplM [InBinding]
1286 floatBind env top_level bind
1292 = tickN LetFloatFromLet n_extras `thenSmpl_`
1293 -- It's important to increment the tick counts if we
1294 -- do any floating. A situation where this turns out
1295 -- to be important is this:
1296 -- Float in produces:
1297 -- letrec x = let y = Ey in Ex
1299 -- Now floating gives this:
1303 --- We now want to iterate once more in case Ey doesn't
1304 -- mention x, in which case the y binding can be pulled
1305 -- out as an enclosing let(rec), which in turn gives
1306 -- the strictness analyser more chance.
1310 binds' = fltBind bind
1311 n_extras = sum (map no_of_binds binds') - no_of_binds bind
1313 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1314 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1316 -- fltBind guarantees not to return leaky floats
1317 -- and all the binders of the floats have had their demand-info zapped
1318 fltBind (NonRec bndr rhs)
1319 = binds ++ [NonRec bndr rhs']
1321 (binds, rhs') = fltRhs rhs
1326 pairs' = concat [ let
1327 (binds, rhs') = fltRhs rhs
1329 foldr get_pairs [(bndr, rhs')] binds
1330 | (bndr, rhs) <- pairs
1333 get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest
1334 get_pairs (Rec pairs) rest = pairs ++ rest
1336 -- fltRhs has same invariant as fltBind
1338 | (always_float_let_from_let ||
1339 floatExposesHNF True False rhs)
1346 -- fltExpr has same invariant as fltBind
1347 fltExpr (Let bind body)
1348 | not top_level || binds_wont_leak
1349 -- fltExpr guarantees not to return leaky floats
1350 = (binds' ++ body_binds, body')
1352 binds_wont_leak = all leakFreeBind binds'
1353 (body_binds, body') = fltExpr body
1354 binds' = fltBind (un_demandify_bind bind)
1356 fltExpr expr = ([], expr)
1358 -- Crude but effective
1359 no_of_binds (NonRec _ _) = 1
1360 no_of_binds (Rec pairs) = length pairs
1362 leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
1363 leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
1365 leakFree (id,_) rhs = case getIdArity id of
1366 ArityAtLeast n | n > 0 -> True
1367 ArityExactly n | n > 0 -> True
1368 other -> whnfOrBottom (mkFormSummary rhs)
1372 %************************************************************************
1374 \subsection[Simplify-atoms]{Simplifying atoms}
1376 %************************************************************************
1379 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1381 simplArg env (LitArg lit) = returnEager (LitArg lit)
1382 simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
1383 returnEager (TyArg ty')
1384 simplArg env arg@(VarArg id)
1385 = case lookupIdSubst env id of
1386 Just (SubstVar id') -> returnEager (VarArg id')
1387 Just (SubstLit lit) -> returnEager (LitArg lit)
1388 Just (SubstExpr _ __) -> panic "simplArg"
1389 Nothing -> case lookupOutIdEnv env id of
1390 Just (id', _, _) -> returnEager (VarArg id')
1391 Nothing -> returnEager arg
1394 %************************************************************************
1396 \subsection[Simplify-quickies]{Some local help functions}
1398 %************************************************************************
1402 -- un_demandify_bind switches off the willBeDemanded Info field
1403 -- for bindings floated out of a non-demanded let
1404 un_demandify_bind (NonRec binder rhs)
1405 = NonRec (un_demandify_bndr binder) rhs
1406 un_demandify_bind (Rec pairs)
1407 = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
1409 un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1411 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1412 is_cheap_prim_app other = False
1414 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1415 computeResultType env expr_ty orig_args
1416 = simplTy env expr_ty `appEager` \ expr_ty' ->
1419 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1420 go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
1421 Just (_, res_ty) -> go res_ty args
1423 pprPanic "computeResultType" (vcat [
1429 go expr_ty' orig_args
1432 var `withArity` UnknownArity = var
1433 var `withArity` arity = var `addIdArity` arity
1435 is_atomic (Var v) = True
1436 is_atomic (Lit l) = not (isNoRepLit l)
1437 is_atomic other = False