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
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
50 The controlling flags, and what they do
51 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
55 -fsimplify = run the simplifier
56 -ffloat-inwards = runs the float lets inwards pass
57 -ffloat = runs the full laziness pass
58 (ToDo: rename to -ffull-laziness)
59 -fupdate-analysis = runs update analyser
60 -fstrictness = runs strictness analyser
61 -fsaturate-apps = saturates applications (eta expansion)
65 -ffloat-past-lambda = OK to do full laziness.
66 (ToDo: remove, as the full laziness pass is
67 useless without this flag, therefore
68 it is unnecessary. Just -ffull-laziness
71 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
72 let is strict or if the floating will expose
75 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
76 is a primop that cannot fail [simplifier].
78 -fcode-duplication-ok = allows the previous option to work on cases with
79 multiple branches [simplifier].
81 -flet-to-case = does let-to-case transformation [simplifier].
83 -fcase-of-case = does case of case transformation [simplifier].
85 -fpedantic-bottoms = does not allow:
86 case x of y -> e ===> e[x/y]
87 (which may turn bottom into non-bottom)
93 Inlining is one of the delicate aspects of the simplifier. By
94 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
95 the RHS of x's definition. Thus
97 let x = e in ...x... ===> let x = e in ...e...
99 We have two mechanisms for inlining:
101 1. Unconditional. The occurrence analyser has pinned an (OneOcc
102 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
103 certainly safe to inline this variable, and to drop its binding''.
104 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
105 happy to be duplicating code...) When it encounters such a beast, the
106 simplifer binds the variable to its RHS (in the id_env) and continues.
107 It doesn't even look at the RHS at that stage. It also drops the
110 2. Conditional. In all other situations, the simplifer simplifies
111 the RHS anyway, and keeps the new binding. It also binds the new
112 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
114 Here, ``suitable'' might mean NoUnfolding (if the occurrence
115 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
116 the variable has an INLINE pragma on it). The idea is that anything
117 in the UnfoldEnv is safe to use, but also has an enclosing binding if
118 you decide not to use it.
122 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
125 At one time I thought it would be OK to put non-HNF unfoldings in for
126 variables which occur only once [if they got inlined at that
127 occurrence the RHS of the binding would become dead, so no duplication
128 would occur]. But consider:
131 f = \y -> ...y...y...y...
134 Now, it seems that @x@ appears only once, but even so it is NOT safe
135 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
136 duplicate the references to @x@.
138 Because of this, the "unconditional-inline" mechanism above is the
139 only way in which non-HNFs can get inlined.
144 When a variable has an INLINE pragma on it --- which includes wrappers
145 produced by the strictness analyser --- we treat it rather carefully.
147 For a start, we are careful not to substitute into its RHS, because
148 that might make it BIG, and the user said "inline exactly this", not
149 "inline whatever you get after inlining other stuff inside me". For
153 in {-# INLINE y #-} y = f 3
156 Here we don't want to substitute BIG for the (single) occurrence of f,
157 because then we'd duplicate BIG when we inline'd y. (Exception:
158 things in the UnfoldEnv with UnfoldAlways flags, which originated in
159 other INLINE pragmas.)
161 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
162 going into such an RHS.
164 What about imports? They don't really matter much because we only
165 inline relatively small things via imports.
167 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
168 INLINE pragma. We also do this for the RHSs of recursive decls,
169 before looking at the recursive decls. That way we achieve the effect
170 of inlining a wrapper in the body of its worker, in the case of a
171 mutually-recursive worker/wrapper split.
174 %************************************************************************
176 \subsection[Simplify-simplExpr]{The main function: simplExpr}
178 %************************************************************************
180 At the top level things are a little different.
182 * No cloning (not allowed for exported Ids, unnecessary for the others)
183 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
186 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
188 -- Dead code is now discarded by the occurrence analyser,
190 simplTopBinds env binds
191 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
192 simpl_top_binds env (concat binds_s)
194 simpl_top_binds env [] = returnSmpl []
196 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
197 = --- No cloning necessary at top level
198 simplBinder env binder `thenSmpl` \ (env1, out_id) ->
199 simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) ->
200 completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
201 simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
202 returnSmpl (binds1' ++ binds2')
204 simpl_top_binds env (Rec pairs : binds)
205 = -- No cloning necessary at top level, but we nevertheless
206 -- add the Ids to the environment. This makes sure that
207 -- info carried on the Id (such as arity info) gets propagated
210 -- This may seem optional, but I found an occasion when it Really matters.
211 -- Consider foo{n} = ...foo...
214 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
215 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
216 -- thing: baz*{n} = ...baz...
218 -- Sure we could have made the indirection-shorting a bit cleverer, but
219 -- propagating pragma info is a Good Idea anyway.
220 simplBinders env (map fst pairs) `thenSmpl` \ (env1, out_ids) ->
221 simplRecursiveGroup env1 out_ids pairs `thenSmpl` \ (bind', new_env) ->
222 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
223 returnSmpl (Rec bind' : binds')
226 %************************************************************************
228 \subsection[Simplify-simplExpr]{The main function: simplExpr}
230 %************************************************************************
234 simplExpr :: SimplEnv
235 -> InExpr -> [OutArg]
236 -> OutType -- Type of (e args); i.e. type of overall result
240 The expression returned has the same meaning as the input expression
241 applied to the specified arguments.
248 simplExpr env (Var var) args result_ty
249 = simplVar env False {- No InlineCall -} var args result_ty
256 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
258 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
262 Primitive applications are simple.
263 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
265 NB: Prim expects an empty argument list! (Because it should be
266 saturated and not higher-order. ADR)
269 simplExpr env (Prim op prim_args) args result_ty
271 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
272 simpl_op op `appEager` \ op' ->
273 completePrim env op' prim_args'
275 -- PrimOps just need any types in them renamed.
277 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
278 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
279 simplTy env result_ty `appEager` \ result_ty' ->
280 returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
282 simpl_op other_op = returnEager other_op
285 Constructor applications
286 ~~~~~~~~~~~~~~~~~~~~~~~~
287 Nothing to try here. We only reuse constructors when they appear as the
288 rhs of a let binding (see completeLetBinding).
291 simplExpr env (Con con con_args) args result_ty
292 = ASSERT( null args )
293 mapEager (simplArg env) con_args `appEager` \ con_args' ->
294 returnSmpl (Con con con_args')
298 Applications are easy too:
299 ~~~~~~~~~~~~~~~~~~~~~~~~~~
300 Just stuff 'em in the arg stack
303 simplExpr env (App fun arg) args result_ty
304 = simplArg env arg `appEager` \ arg' ->
305 simplExpr env fun (arg' : args) result_ty
311 First the case when it's applied to an argument.
314 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
315 = tick TyBetaReduction `thenSmpl_`
316 simplExpr (bindTyVar env tyvar ty) body args result_ty
320 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
321 = simplTyBinder env tyvar `thenSmpl` \ (new_env, tyvar') ->
323 new_result_ty = applyTy result_ty (mkTyVarTy tyvar')
325 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
326 returnSmpl (Lam (TyBinder tyvar') body')
329 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
330 = panic "simplExpr:TyLam with non-TyArg"
338 There's a complication with lambdas that aren't saturated.
343 If we did nothing, x is used inside the \y, so would be marked
344 as dangerous to dup. But in the common case where the abstraction
345 is applied to two arguments this is over-pessimistic.
346 So instead we don't take account of the \y when dealing with x's usage;
347 instead, the simplifier is careful when partially applying lambdas.
350 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
351 = go 0 env expr orig_args
353 go n env (Lam (ValBinder binder) body) (val_arg : args)
354 | isValArg val_arg -- The lambda has an argument
355 = tick BetaReduction `thenSmpl_`
356 go (n+1) (bindIdToAtom env binder val_arg) body args
358 go n env expr@(Lam (ValBinder binder) body) args
359 -- The lambda is un-saturated, so we must zap the occurrence info
360 -- on the arguments we've already beta-reduced into the body of the lambda
361 = ASSERT( null args ) -- Value lambda must match value argument!
363 new_env = markDangerousOccs env orig_args
365 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
366 `thenSmpl` \ (expr', arity) ->
369 go n env non_val_lam_expr args -- The lambda had enough arguments
370 = simplExpr env non_val_lam_expr args result_ty
378 simplExpr env (Let bind body) args result_ty
379 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
386 simplExpr env expr@(Case scrut alts) args result_ty
387 = simplCase env scrut
388 (getSubstEnvs env, alts)
389 (\env rhs -> simplExpr env rhs args result_ty)
397 simplExpr env (Note (Coerce to_ty from_ty) body) args result_ty
398 = simplCoerce env to_ty from_ty body args result_ty
400 simplExpr env (Note (SCC cc) body) args result_ty
401 = simplSCC env cc body args result_ty
403 -- InlineCall is simple enough to deal with on the spot
404 -- The only complication is that we slide the InlineCall
405 -- inwards past any function arguments
406 simplExpr env (Note InlineCall expr) args result_ty
409 go (Var v) args = simplVar env True {- InlineCall -} v args result_ty
411 go (App fun arg) args = simplArg env arg `appEager` \ arg' ->
414 go other args = -- Unexpected discard; report it
415 pprTrace "simplExpr: discarding InlineCall" (ppr expr) $
416 simplExpr env other args result_ty
421 %************************************************************************
423 \subsection{Simplify RHS of a Let/Letrec}
425 %************************************************************************
427 simplRhsExpr does arity-expansion. That is, given:
429 * a right hand side /\ tyvars -> \a1 ... an -> e
430 * the information (stored in BinderInfo) that the function will always
431 be applied to at least k arguments
433 it transforms the rhs to
435 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
437 This is a Very Good Thing!
444 -> OutId -- The new binder (used only for its type)
445 -> SmplM (OutExpr, ArityInfo)
450 simplRhsExpr env binder@(id,occ_info) rhs new_id
451 | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
452 -- Deal with the data type case, in which case the elaborate
453 -- eta-expansion nonsense is really quite a waste of time.
454 = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
455 returnSmpl (rhs', ArityExactly 0)
457 | otherwise -- OK, use the big hammer
458 = -- Deal with the big lambda part
459 simplTyBinders rhs_env tyvars `thenSmpl` \ (lam_env, tyvars') ->
461 body_ty = applyTys rhs_ty (mkTyVarTys tyvars')
463 -- Deal with the little lambda part
464 -- Note that we call simplLam even if there are no binders,
465 -- in case it can do arity expansion.
466 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
468 -- Put on the big lambdas, trying to float out any bindings caught inside
469 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
471 returnSmpl (rhs', arity)
473 rhs_ty = idType new_id
474 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
475 = switchOffInlining env1 -- See comments with switchOffInlining
479 -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
480 -- for the rhs of top level defs is "OST_CENTRE". Consider
482 -- g = \y -> let v = f y in scc "x" (v ...)
483 -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
484 -- want to inline "v" since its CC is dynamically determined.
486 current_cc = getEnclosingCC env
487 env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
490 (tyvars, body) = collectTyBinders rhs
494 ----------------------------------------------------------------
495 An old special case that is now nuked.
497 First a special case for variable right-hand sides
499 It's OK to simplify the RHS, but it's often a waste of time. Often
500 these v = w things persist because v is exported, and w is used
501 elsewhere. So if we're not careful we'll eta expand the rhs, only
502 to eta reduce it in competeNonRec.
504 If we leave the binding unchanged, we will certainly replace v by w at
505 every occurrence of v, which is good enough.
507 In fact, it's *better* to replace v by w than to inline w in v's rhs,
508 even if this is the only occurrence of w. Why? Because w might have
509 IdInfo (such as strictness) that v doesn't.
511 Furthermore, there might be other uses of w; if so, inlining w in
512 v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
514 HOWEVER, we have to be careful if w is something that *must* be
515 inlined. In particular, its binding may have been dropped. Here's
516 an example that actually happened:
517 let x = let y = e in y
519 The "let y" was floated out, and then (since y occurs once in a
520 definitely inlinable position) the binding was dropped, leaving
521 {y=e} let x = y in f x
522 But now using the reasoning of this little section,
523 y wasn't inlined, because it was a let x=y form.
528 This "optimisation" turned out to be a bad idea. If there's are
529 top-level exported bindings like
534 then y wasn't getting inlined in x's rhs, and we were getting
535 bad code. So I've removed the special case from here, and
536 instead we only try eta reduction and constructor reuse
537 in completeNonRec if the thing is *not* exported.
541 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
542 | maybeToBool maybe_stop_at_var
543 = returnSmpl (Var the_var, getIdArity the_var)
546 = case (runEager $ lookupId env v) of
547 VarArg v' | not (must_unfold v') -> Just v'
550 Just the_var = maybe_stop_at_var
552 must_unfold v' = idMustBeINLINEd v'
553 || case lookupOutIdEnv env v' of
554 Just (_, _, InUnfolding _ _) -> True
558 End of old, nuked, special case.
559 ------------------------------------------------------------------
562 %************************************************************************
564 \subsection{Simplify a lambda abstraction}
566 %************************************************************************
568 Simplify (\binders -> body) trying eta expansion and reduction, given that
569 the abstraction will always be applied to at least min_no_of_args.
572 simplValLam env expr min_no_of_args expr_ty
573 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
575 exprIsTrivial expr || -- or it's a trivial RHS
576 -- No eta expansion for trivial RHSs
577 -- It's rather a Bad Thing to expand
580 -- g = \a b c -> f alpha beta a b c
582 -- The original RHS is "trivial" (exprIsTrivial), because it generates
583 -- no code (renames f to g). But the new RHS isn't.
585 null potential_extra_binder_tys || -- or ain't a function
586 no_of_extra_binders <= 0 -- or no extra binders needed
587 = simplBinders env binders `thenSmpl` \ (new_env, binders') ->
588 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
589 returnSmpl (mkValLam binders' body', final_arity)
591 | otherwise -- Eta expansion possible
592 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
593 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
594 pprTrace "simplValLam" (vcat [ppr expr,
597 int no_of_extra_binders,
598 ppr potential_extra_binder_tys])
601 tick EtaExpansion `thenSmpl_`
602 simplBinders env binders `thenSmpl` \ (new_env, binders') ->
603 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
604 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
606 mkValLam (binders' ++ extra_binders') body',
611 (binders,body) = collectValBinders expr
612 no_of_binders = length binders
613 (arg_tys, res_ty) = splitFunTys expr_ty
614 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
615 pprTrace "simplValLam" (vcat [ppr expr,
619 drop no_of_binders arg_tys
620 body_ty = mkFunTys potential_extra_binder_tys res_ty
622 -- Note: it's possible that simplValLam will be applied to something
623 -- with a forall type. Eg when being applied to the rhs of
625 -- where wurble has a forall-type, but no big lambdas at the top.
626 -- We could be clever an insert new big lambdas, but we don't bother.
628 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
629 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
630 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
632 no_of_extra_binders = -- First, use the info about how many args it's
633 -- always applied to in its scope; but ignore this
634 -- info for thunks. To see why we ignore it for thunks,
635 -- consider let f = lookup env key in (f 1, f 2)
636 -- We'd better not eta expand f just because it is
638 (min_no_of_args - no_of_binders)
640 -- Next, try seeing if there's a lambda hidden inside
642 -- etaExpandCount can reuturn a huge number (like 10000!) if
643 -- it finds that the body is a call to "error"; hence
644 -- the use of "min" here.
646 (etaExpandCount body `min` length potential_extra_binder_tys)
648 -- Finally, see if it's a state transformer, in which
649 -- case we eta-expand on principle! This can waste work,
650 -- but usually doesn't
652 case potential_extra_binder_tys of
653 [ty] | ty == realWorldStatePrimTy -> 1
658 %************************************************************************
660 \subsection[Simplify-var]{Variables}
662 %************************************************************************
664 Check if there's a macro-expansion, and if so rattle on. Otherwise do
665 the more sophisticated stuff.
668 simplVar env inline_call var args result_ty
669 = case lookupIdSubst env var of
671 Just (SubstExpr ty_subst id_subst expr)
672 -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty
674 Just (SubstLit lit) -- A boring old literal
675 -> ASSERT( null args )
678 Just (SubstVar var') -- More interesting! An id!
679 -> completeVar env inline_call var' args result_ty
681 Nothing -- Not in the substitution; hand off to completeVar
682 -> completeVar env inline_call var args result_ty
686 %************************************************************************
688 \subsection[Simplify-coerce]{Coerce expressions}
690 %************************************************************************
693 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
694 simplCoerce env to_ty from_ty expr@(Case scrut alts) args result_ty
695 = simplCase env scrut (getSubstEnvs env, alts)
696 (\env rhs -> simplCoerce env to_ty from_ty rhs args result_ty)
699 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
700 simplCoerce env to_ty from_ty (Let bind body) args result_ty
701 = simplBind env bind (\env -> simplCoerce env to_ty from_ty body args result_ty) result_ty
704 -- NB: we do *not* push the argments inside the coercion
706 simplCoerce env to_ty from_ty expr args result_ty
707 = simplTy env to_ty `appEager` \ to_ty' ->
708 simplTy env from_ty `appEager` \ from_ty' ->
709 simplExpr env expr [] from_ty' `thenSmpl` \ expr' ->
710 returnSmpl (mkGenApp (mkCoerce to_ty' from_ty' expr') args)
712 -- Try cancellation; we do this "on the way up" because
713 -- I think that's where it'll bite best
714 mkCoerce to_ty1 from_ty1 (Note (Coerce to_ty2 from_ty2) body)
715 = ASSERT( from_ty1 == to_ty2 )
716 mkCoerce to_ty1 from_ty2 body
717 mkCoerce to_ty from_ty body
718 | to_ty == from_ty = body
719 | otherwise = Note (Coerce to_ty from_ty) body
723 %************************************************************************
725 \subsection[Simplify-scc]{SCC expressions
727 %************************************************************************
729 1) Eliminating nested sccs ...
730 We must be careful to maintain the scc counts ...
733 simplSCC env cc1 (Note (SCC cc2) expr) args result_ty
734 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
735 -- eliminate inner scc if no call counts and same cc as outer
736 = simplSCC env cc1 expr args result_ty
738 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
739 -- eliminate outer scc if no call counts associated with either ccs
740 = simplSCC env cc2 expr args result_ty
743 2) Moving sccs inside lambdas ...
746 simplSCC env cc (Lam binder@(ValBinder _) body) args result_ty
747 | not (isSccCountCostCentre cc)
748 -- move scc inside lambda only if no call counts
749 = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
751 simplSCC env cc (Lam binder body) args result_ty
752 -- always ok to move scc inside type/usage lambda
753 = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
756 3) Eliminating dict sccs ...
759 simplSCC env cc expr args result_ty
760 | squashableDictishCcExpr cc expr
761 -- eliminate dict cc if trivial dict expression
762 = simplExpr env expr args result_ty
765 4) Moving arguments inside the body of an scc ...
766 This moves the cost of doing the application inside the scc
767 (which may include the cost of extracting methods etc)
770 simplSCC env cc body args result_ty
772 new_env = setEnclosingCC env cc
774 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
775 returnSmpl (Note (SCC cc) body')
779 %************************************************************************
781 \subsection[Simplify-bind]{Binding groups}
783 %************************************************************************
786 simplBind :: SimplEnv
788 -> (SimplEnv -> SmplM OutExpr)
792 simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
793 simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
797 %************************************************************************
799 \subsection[Simplify-let]{Let-expressions}
801 %************************************************************************
805 The booleans controlling floating have to be set with a little care.
806 Here's one performance bug I found:
808 let x = let y = let z = case a# +# 1 of {b# -> E1}
813 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
814 Before case_floating_ok included float_exposes_hnf, the case expression was floated
815 *one level per simplifier iteration* outwards. So it made th s
818 Floating case from let
819 ~~~~~~~~~~~~~~~~~~~~~~
820 When floating cases out of lets, remember this:
822 let x* = case e of alts
825 where x* is sure to be demanded or e is a cheap operation that cannot
826 fail, e.g. unboxed addition. Here we should be prepared to duplicate
827 <small expr>. A good example:
836 p1 -> foldr c n (build e1)
837 p2 -> foldr c n (build e2)
839 NEW: We use the same machinery that we use for case-of-case to
840 *always* do case floating from let, that is we let bind and abstract
841 the original let body, and let the occurrence analyser later decide
842 whether the new let should be inlined or not. The example above
846 let join_body x' = foldr c n x'
848 p1 -> let x* = build e1
850 p2 -> let x* = build e2
853 note that join_body is a let-no-escape.
854 In this particular example join_body will later be inlined,
855 achieving the same effect.
856 ToDo: check this is OK with andy
859 Let to case: two points
862 Point 1. We defer let-to-case for all data types except single-constructor
863 ones. Suppose we change
869 It can be the case that we find that b ultimately contains ...(case x of ..)....
870 and this is the only occurrence of x. Then if we've done let-to-case
871 we can't inline x, which is a real pain. On the other hand, we lose no
872 transformations by not doing this transformation, because the relevant
873 case-of-X transformations are also implemented by simpl_bind.
875 If x is a single-constructor type, then we go ahead anyway, giving
877 case e of (y,z) -> let x = (y,z) in b
879 because now we can squash case-on-x wherever they occur in b.
881 We do let-to-case on multi-constructor types in the tidy-up phase
882 (tidyCoreExpr) mainly so that the code generator doesn't need to
883 spot the demand-flag.
886 Point 2. It's important to try let-to-case before doing the
887 strict-let-of-case transformation, which happens in the next equation
890 let a*::Int = case v of {p1->e1; p2->e2}
893 (The * means that a is sure to be demanded.)
894 If we do case-floating first we get this:
898 p1-> let a*=e1 in k a
899 p2-> let a*=e2 in k a
901 Now watch what happens if we do let-to-case first:
903 case (case v of {p1->e1; p2->e2}) of
904 Int a# -> let a*=I# a# in b
906 let k = \a# -> let a*=I# a# in b
908 p1 -> case e1 of I# a# -> k a#
909 p1 -> case e2 of I# a# -> k a#
911 The latter is clearly better. (Remember the reboxing let-decl for a
912 is likely to go away, because after all b is strict in a.)
914 We do not do let to case for WHNFs, e.g.
920 as this is less efficient. but we don't mind doing let-to-case for
921 "bottom", as that will allow us to remove more dead code, if anything:
925 case error of x -> ...
929 Notice that let to case occurs only if x is used strictly in its body
934 -- Dead code is now discarded by the occurrence analyser,
936 simplNonRec env binder@(id,_) rhs body_c body_ty
937 | inlineUnconditionally binder
938 = -- The binder is used in definitely-inline way in the body
939 -- So add it to the environment, drop the binding, and continue
940 body_c (bindIdToExpr env binder rhs)
942 | idWantsToBeINLINEd id
943 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
946 -- Do let-to-case right away for unpointed types
947 -- These shouldn't occur much, but do occur right after desugaring,
948 -- because we havn't done dependency analysis at that point, so
949 -- we can't trivially do let-to-case (because there may be some unboxed
950 -- things bound in letrecs that aren't really recursive).
951 | isUnpointedType rhs_ty && not rhs_is_whnf
952 = simplCase env rhs (getSubstEnvs env, PrimAlts [] (BindDefault binder (Var id)))
953 (\env rhs -> complete_bind env rhs) body_ty
955 -- Try let-to-case; see notes below about let-to-case
959 || (not rhs_is_whnf && singleConstructorType rhs_ty)
960 -- Don't do let-to-case if the RHS is a constructor application.
961 -- Even then only do it for single constructor types.
962 -- For other types we defer doing it until the tidy-up phase at
963 -- the end of simplification.
965 = tick Let2Case `thenSmpl_`
966 simplCase env rhs (getSubstEnvs env, AlgAlts [] (BindDefault binder (Var id)))
967 (\env rhs -> complete_bind env rhs) body_ty
968 -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
969 -- NB: it's tidier to call complete_bind not simpl_bind, else
970 -- we nearly end up in a loop. Consider:
972 -- ==> case rhs of (p,q) -> let x=(p,q) in b
973 -- This effectively what the above simplCase call does.
974 -- Now, the inner let is a let-to-case target again! Actually, since
975 -- the RHS is in WHNF it won't happen, but it's a close thing!
981 simpl_bind env (Let bind rhs) | let_floating_ok
982 = tick LetFloatFromLet `thenSmpl_`
983 simplBind env (if will_be_demanded then bind
984 else un_demandify_bind bind)
985 (\env -> simpl_bind env rhs) body_ty
987 -- Try case-from-let; this deals with a strict let of error too
988 simpl_bind env (Case scrut alts) | case_floating_ok scrut
989 = tick CaseFloatFromLet `thenSmpl_`
991 -- First, bind large let-body if necessary
992 if isSingleton (nonErrorRHSs alts)
994 simplCase env scrut (getSubstEnvs env, alts)
995 (\env rhs -> simpl_bind env rhs) body_ty
997 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
999 body_c' = \env -> simplExpr env new_body [] body_ty
1000 case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
1002 simplCase env scrut (getSubstEnvs env, alts) case_c body_ty `thenSmpl` \ case_expr ->
1003 returnSmpl (Let extra_binding case_expr)
1005 -- None of the above; simplify rhs and tidy up
1006 simpl_bind env rhs = complete_bind env rhs
1008 complete_bind env rhs
1009 = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) ->
1010 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
1011 completeNonRec env_w_clone binder
1012 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
1013 body_c new_env `thenSmpl` \ body' ->
1014 returnSmpl (mkCoLetsAny binds body')
1017 -- All this stuff is computed at the start of the simpl_bind loop
1018 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1019 float_primops = switchIsSet env SimplOkToFloatPrimOps
1020 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1021 try_let_to_case = switchIsSet env SimplLetToCase
1022 no_float = switchIsSet env SimplNoLetFromStrictLet
1024 demand_info = getIdDemandInfo id
1025 will_be_demanded = willBeDemanded demand_info
1028 form = mkFormSummary rhs
1029 rhs_is_bot = case form of
1032 rhs_is_whnf = case form of
1037 float_exposes_hnf = floatExposesHNF float_lets float_primops rhs
1039 let_floating_ok = (will_be_demanded && not no_float) ||
1040 always_float_let_from_let ||
1043 case_floating_ok scrut = (will_be_demanded && not no_float) ||
1044 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
1049 @completeNonRec@ looks at the simplified post-floating RHS of the
1050 let-expression, with a view to turning
1054 where y is just a variable. Now we can eliminate the binding
1055 altogether, and replace x by y throughout.
1057 There are two cases when we can do this:
1059 * When e is a constructor application, and we have
1060 another variable in scope bound to the same
1061 constructor application. [This is just a special
1062 case of common-subexpression elimination.]
1064 * When e can be eta-reduced to a variable. E.g.
1068 HOWEVER, if x is exported, we don't attempt this at all. Why not?
1069 Because then we can't remove the x=y binding, in which case we
1070 have just made things worse, perhaps a lot worse.
1073 completeNonRec env binder new_id new_rhs
1074 = returnSmpl (env', [NonRec b r | (b,r) <- binds])
1076 (env', binds) = completeBind env binder new_id new_rhs
1079 completeBind :: SimplEnv
1080 -> InBinder -> OutId -> OutExpr -- Id and RHS
1081 -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
1083 completeBind env binder@(old_id,occ_info) new_id new_rhs
1084 | atomic_rhs -- If rhs (after eta reduction) is atomic
1085 && not (isExported new_id) -- and binder isn't exported
1086 = -- Drop the binding completely
1088 env1 = notInScope env new_id
1089 env2 = bindIdToAtom env1 binder the_arg
1093 | otherwise -- Non-atomic
1094 -- The big deal here is that we simplify the
1095 -- SpecEnv of the Id, if any. We used to do that in simplBinders, but
1096 -- that didn't work because it didn't take account of the fact that
1097 -- one of the mutually recursive group might mention one of the others
1100 id_w_specenv | isEmptySpecEnv spec_env = new_id
1101 | otherwise = setIdSpecialisation new_id spec_env'
1103 env1 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1104 = extendEnvGivenUnfolding env id_w_specenv occ_info noUnfolding
1105 -- Still need to record the new_id with its SpecEnv
1107 | otherwise -- Can inline it
1108 = extendEnvGivenBinding env occ_info id_w_specenv new_rhs
1114 spec_env = getIdSpecialisation old_id
1115 spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
1116 (ty_subst,id_subst) = getSubstEnvs env
1118 new_binds = [(new_id, new_rhs)]
1119 atomic_rhs = is_atomic eta'd_rhs
1120 eta'd_rhs = case lookForConstructor env new_rhs of
1122 other -> etaCoreExpr new_rhs
1124 the_arg = case eta'd_rhs of
1129 ----------------------------------------------------------------------------
1130 A digression on constructor CSE
1138 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1139 bit on the compiler technology, but in general I believe not. For
1140 example, here's some code from a real program:
1142 const.Int.max.wrk{-s2516-} =
1143 \ upk.s3297# upk.s3298# ->
1147 a.s3299 = I#! upk.s3297#
1149 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1150 _LT -> I#! upk.s3298#
1155 The a.s3299 really isn't doing much good. We'd be better off inlining
1156 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1158 So the current strategy is to inline all known-form constructors, and
1159 only do the reverse (turn a constructor application back into a
1160 variable) when we find a let-expression:
1164 ... (let y = C a1 .. an in ...) ...
1166 where it is always good to ditch the binding for y, and replace y by
1169 ----------------------------------------------------------------------------
1171 ----------------------------------------------------------------------------
1172 A digression on "optimising" coercions
1174 The trouble is that we kept transforming
1182 and counting a couple of ticks for this non-transformation
1184 -- We want to ensure that all let-bound Coerces have
1185 -- atomic bodies, so they can freely be inlined.
1186 completeNonRec env binder new_id (Coerce coercion ty rhs)
1187 | not (is_atomic rhs)
1188 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1190 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1191 -- Dangerous occ because, like constructor args,
1192 -- it can be duplicated easily
1194 atomic_rhs = case runEager $ lookupId env1 inner_id of
1198 completeNonRec env1 binder new_id
1199 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1201 returnSmpl (env2, binds1 ++ binds2)
1203 ----------------------------------------------------------------------------
1207 %************************************************************************
1209 \subsection[Simplify-letrec]{Letrec-expressions}
1211 %************************************************************************
1215 Here's the game plan
1217 1. Float any let(rec)s out of the RHSs
1218 2. Clone all the Ids and extend the envt with these clones
1219 3. Simplify one binding at a time, adding each binding to the
1220 environment once it's done.
1222 This relies on the occurrence analyser to
1223 a) break all cycles with an Id marked MustNotBeInlined
1224 b) sort the decls into topological order
1225 The former prevents infinite inlinings, and the latter means
1226 that we get maximum benefit from working top to bottom.
1230 simplRec env pairs body_c body_ty
1231 = -- Do floating, if necessary
1232 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1234 binders = map fst pairs'
1236 simplBinders env binders `thenSmpl` \ (env_w_clones, ids') ->
1237 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1239 body_c new_env `thenSmpl` \ body' ->
1241 returnSmpl (Let (Rec pairs') body')
1245 -- The env passed to simplRecursiveGroup already has
1246 -- bindings that clone the variables of the group.
1247 simplRecursiveGroup env new_ids []
1248 = returnSmpl ([], env)
1250 simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs)
1251 | inlineUnconditionally binder
1252 = -- Single occurrence, so drop binding and extend env with the inlining
1253 -- This is a little delicate, because what if the unique occurrence
1254 -- is *before* this binding? This'll never happen, because
1255 -- either it'll be marked "never inline" or else its occurrence will
1256 -- occur after its binding in the group.
1258 -- If these claims aren't right Core Lint will spot an unbound
1259 -- variable. A quick fix is to delete this clause for simplRecursiveGroup
1261 new_env = bindIdToExpr env binder rhs
1263 simplRecursiveGroup new_env new_ids pairs
1266 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1268 new_id' = new_id `withArity` arity
1269 (new_env, new_binds') = completeBind env binder new_id' new_rhs
1271 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1272 returnSmpl (new_binds' ++ new_pairs, final_env)
1278 floatBind :: SimplEnv
1279 -> Bool -- True <=> Top level
1281 -> SmplM [InBinding]
1283 floatBind env top_level bind
1289 = tickN LetFloatFromLet n_extras `thenSmpl_`
1290 -- It's important to increment the tick counts if we
1291 -- do any floating. A situation where this turns out
1292 -- to be important is this:
1293 -- Float in produces:
1294 -- letrec x = let y = Ey in Ex
1296 -- Now floating gives this:
1300 --- We now want to iterate once more in case Ey doesn't
1301 -- mention x, in which case the y binding can be pulled
1302 -- out as an enclosing let(rec), which in turn gives
1303 -- the strictness analyser more chance.
1307 binds' = fltBind bind
1308 n_extras = sum (map no_of_binds binds') - no_of_binds bind
1310 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1311 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1313 -- fltBind guarantees not to return leaky floats
1314 -- and all the binders of the floats have had their demand-info zapped
1315 fltBind (NonRec bndr rhs)
1316 = binds ++ [NonRec bndr rhs']
1318 (binds, rhs') = fltRhs rhs
1323 pairs' = concat [ let
1324 (binds, rhs') = fltRhs rhs
1326 foldr get_pairs [(bndr, rhs')] binds
1327 | (bndr, rhs) <- pairs
1330 get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest
1331 get_pairs (Rec pairs) rest = pairs ++ rest
1333 -- fltRhs has same invariant as fltBind
1335 | (always_float_let_from_let ||
1336 floatExposesHNF True False rhs)
1343 -- fltExpr has same invariant as fltBind
1344 fltExpr (Let bind body)
1345 | not top_level || binds_wont_leak
1346 -- fltExpr guarantees not to return leaky floats
1347 = (binds' ++ body_binds, body')
1349 binds_wont_leak = all leakFreeBind binds'
1350 (body_binds, body') = fltExpr body
1351 binds' = fltBind (un_demandify_bind bind)
1353 fltExpr expr = ([], expr)
1355 -- Crude but effective
1356 no_of_binds (NonRec _ _) = 1
1357 no_of_binds (Rec pairs) = length pairs
1359 leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
1360 leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
1362 leakFree (id,_) rhs = case getIdArity id of
1363 ArityAtLeast n | n > 0 -> True
1364 ArityExactly n | n > 0 -> True
1365 other -> whnfOrBottom (mkFormSummary rhs)
1369 %************************************************************************
1371 \subsection[Simplify-atoms]{Simplifying atoms}
1373 %************************************************************************
1376 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1378 simplArg env (LitArg lit) = returnEager (LitArg lit)
1379 simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
1380 returnEager (TyArg ty')
1381 simplArg env arg@(VarArg id)
1382 = case lookupIdSubst env id of
1383 Just (SubstVar id') -> returnEager (VarArg id')
1384 Just (SubstLit lit) -> returnEager (LitArg lit)
1385 Just (SubstExpr _ __) -> panic "simplArg"
1386 Nothing -> case lookupOutIdEnv env id of
1387 Just (id', _, _) -> returnEager (VarArg id')
1388 Nothing -> returnEager arg
1391 %************************************************************************
1393 \subsection[Simplify-quickies]{Some local help functions}
1395 %************************************************************************
1399 -- un_demandify_bind switches off the willBeDemanded Info field
1400 -- for bindings floated out of a non-demanded let
1401 un_demandify_bind (NonRec binder rhs)
1402 = NonRec (un_demandify_bndr binder) rhs
1403 un_demandify_bind (Rec pairs)
1404 = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
1406 un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1408 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1409 is_cheap_prim_app other = False
1411 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1412 computeResultType env expr_ty orig_args
1413 = simplTy env expr_ty `appEager` \ expr_ty' ->
1416 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1417 go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
1418 Just (_, res_ty) -> go res_ty args
1420 pprPanic "computeResultType" (vcat [
1426 go expr_ty' orig_args
1429 var `withArity` UnknownArity = var
1430 var `withArity` arity = var `addIdArity` arity
1432 is_atomic (Var v) = True
1433 is_atomic (Lit l) = not (isNoRepLit l)
1434 is_atomic other = False