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,
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,
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 Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
39 mkFunTys, splitAlgTyConApp_maybe,
40 splitFunTys, splitFunTy_maybe, isUnpointedType
42 import TysPrim ( realWorldStatePrimTy )
43 import Util ( Eager, appEager, returnEager, runEager, mapEager,
44 isSingleton, zipEqual, zipWithEqual, mapAndUnzip
49 The controlling flags, and what they do
50 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
54 -fsimplify = run the simplifier
55 -ffloat-inwards = runs the float lets inwards pass
56 -ffloat = runs the full laziness pass
57 (ToDo: rename to -ffull-laziness)
58 -fupdate-analysis = runs update analyser
59 -fstrictness = runs strictness analyser
60 -fsaturate-apps = saturates applications (eta expansion)
64 -ffloat-past-lambda = OK to do full laziness.
65 (ToDo: remove, as the full laziness pass is
66 useless without this flag, therefore
67 it is unnecessary. Just -ffull-laziness
70 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
71 let is strict or if the floating will expose
74 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
75 is a primop that cannot fail [simplifier].
77 -fcode-duplication-ok = allows the previous option to work on cases with
78 multiple branches [simplifier].
80 -flet-to-case = does let-to-case transformation [simplifier].
82 -fcase-of-case = does case of case transformation [simplifier].
84 -fpedantic-bottoms = does not allow:
85 case x of y -> e ===> e[x/y]
86 (which may turn bottom into non-bottom)
92 Inlining is one of the delicate aspects of the simplifier. By
93 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
94 the RHS of x's definition. Thus
96 let x = e in ...x... ===> let x = e in ...e...
98 We have two mechanisms for inlining:
100 1. Unconditional. The occurrence analyser has pinned an (OneOcc
101 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
102 certainly safe to inline this variable, and to drop its binding''.
103 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
104 happy to be duplicating code...) When it encounters such a beast, the
105 simplifer binds the variable to its RHS (in the id_env) and continues.
106 It doesn't even look at the RHS at that stage. It also drops the
109 2. Conditional. In all other situations, the simplifer simplifies
110 the RHS anyway, and keeps the new binding. It also binds the new
111 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
113 Here, ``suitable'' might mean NoUnfolding (if the occurrence
114 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
115 the variable has an INLINE pragma on it). The idea is that anything
116 in the UnfoldEnv is safe to use, but also has an enclosing binding if
117 you decide not to use it.
121 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
124 At one time I thought it would be OK to put non-HNF unfoldings in for
125 variables which occur only once [if they got inlined at that
126 occurrence the RHS of the binding would become dead, so no duplication
127 would occur]. But consider:
130 f = \y -> ...y...y...y...
133 Now, it seems that @x@ appears only once, but even so it is NOT safe
134 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
135 duplicate the references to @x@.
137 Because of this, the "unconditional-inline" mechanism above is the
138 only way in which non-HNFs can get inlined.
143 When a variable has an INLINE pragma on it --- which includes wrappers
144 produced by the strictness analyser --- we treat it rather carefully.
146 For a start, we are careful not to substitute into its RHS, because
147 that might make it BIG, and the user said "inline exactly this", not
148 "inline whatever you get after inlining other stuff inside me". For
152 in {-# INLINE y #-} y = f 3
155 Here we don't want to substitute BIG for the (single) occurrence of f,
156 because then we'd duplicate BIG when we inline'd y. (Exception:
157 things in the UnfoldEnv with UnfoldAlways flags, which originated in
158 other INLINE pragmas.)
160 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
161 going into such an RHS.
163 What about imports? They don't really matter much because we only
164 inline relatively small things via imports.
166 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
167 INLINE pragma. We also do this for the RHSs of recursive decls,
168 before looking at the recursive decls. That way we achieve the effect
169 of inlining a wrapper in the body of its worker, in the case of a
170 mutually-recursive worker/wrapper split.
173 %************************************************************************
175 \subsection[Simplify-simplExpr]{The main function: simplExpr}
177 %************************************************************************
179 At the top level things are a little different.
181 * No cloning (not allowed for exported Ids, unnecessary for the others)
182 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
185 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
187 -- Dead code is now discarded by the occurrence analyser,
189 simplTopBinds env binds
190 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
191 simpl_top_binds env (concat binds_s)
193 simpl_top_binds env [] = returnSmpl []
195 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
196 = --- No cloning necessary at top level
197 simplBinder env binder `thenSmpl` \ (env1, out_id) ->
198 simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) ->
199 completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
200 simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
201 returnSmpl (binds1' ++ binds2')
203 simpl_top_binds env (Rec pairs : binds)
204 = -- No cloning necessary at top level, but we nevertheless
205 -- add the Ids to the environment. This makes sure that
206 -- info carried on the Id (such as arity info) gets propagated
209 -- This may seem optional, but I found an occasion when it Really matters.
210 -- Consider foo{n} = ...foo...
213 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
214 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
215 -- thing: baz*{n} = ...baz...
217 -- Sure we could have made the indirection-shorting a bit cleverer, but
218 -- propagating pragma info is a Good Idea anyway.
219 simplBinders env (map fst pairs) `thenSmpl` \ (env1, out_ids) ->
220 simplRecursiveGroup env1 out_ids pairs `thenSmpl` \ (bind', new_env) ->
221 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
222 returnSmpl (Rec bind' : binds')
225 %************************************************************************
227 \subsection[Simplify-simplExpr]{The main function: simplExpr}
229 %************************************************************************
233 simplExpr :: SimplEnv
234 -> InExpr -> [OutArg]
235 -> OutType -- Type of (e args); i.e. type of overall result
239 The expression returned has the same meaning as the input expression
240 applied to the specified arguments.
247 simplExpr env (Var var) args result_ty
248 = simplVar env False {- No InlineCall -} var args result_ty
255 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
257 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
261 Primitive applications are simple.
262 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
264 NB: Prim expects an empty argument list! (Because it should be
265 saturated and not higher-order. ADR)
268 simplExpr env (Prim op prim_args) args result_ty
270 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
271 simpl_op op `appEager` \ op' ->
272 completePrim env op' prim_args'
274 -- PrimOps just need any types in them renamed.
276 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
277 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
278 simplTy env result_ty `appEager` \ result_ty' ->
279 returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
281 simpl_op other_op = returnEager other_op
284 Constructor applications
285 ~~~~~~~~~~~~~~~~~~~~~~~~
286 Nothing to try here. We only reuse constructors when they appear as the
287 rhs of a let binding (see completeLetBinding).
290 simplExpr env (Con con con_args) args result_ty
291 = ASSERT( null args )
292 mapEager (simplArg env) con_args `appEager` \ con_args' ->
293 returnSmpl (Con con con_args')
297 Applications are easy too:
298 ~~~~~~~~~~~~~~~~~~~~~~~~~~
299 Just stuff 'em in the arg stack
302 simplExpr env (App fun arg) args result_ty
303 = simplArg env arg `appEager` \ arg' ->
304 simplExpr env fun (arg' : args) result_ty
310 First the case when it's applied to an argument.
313 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
314 = tick TyBetaReduction `thenSmpl_`
315 simplExpr (bindTyVar env tyvar ty) body args result_ty
319 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
320 = simplTyBinder env tyvar `thenSmpl` \ (new_env, tyvar') ->
322 new_result_ty = applyTy result_ty (mkTyVarTy tyvar')
324 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
325 returnSmpl (Lam (TyBinder tyvar') body')
328 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
329 = panic "simplExpr:TyLam with non-TyArg"
337 There's a complication with lambdas that aren't saturated.
342 If we did nothing, x is used inside the \y, so would be marked
343 as dangerous to dup. But in the common case where the abstraction
344 is applied to two arguments this is over-pessimistic.
345 So instead we don't take account of the \y when dealing with x's usage;
346 instead, the simplifier is careful when partially applying lambdas.
349 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
350 = go 0 env expr orig_args
352 go n env (Lam (ValBinder binder) body) (val_arg : args)
353 | isValArg val_arg -- The lambda has an argument
354 = tick BetaReduction `thenSmpl_`
355 go (n+1) (bindIdToAtom env binder val_arg) body args
357 go n env expr@(Lam (ValBinder binder) body) args
358 -- The lambda is un-saturated, so we must zap the occurrence info
359 -- on the arguments we've already beta-reduced into the body of the lambda
360 = ASSERT( null args ) -- Value lambda must match value argument!
362 new_env = markDangerousOccs env orig_args
364 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
365 `thenSmpl` \ (expr', arity) ->
368 go n env non_val_lam_expr args -- The lambda had enough arguments
369 = simplExpr env non_val_lam_expr args result_ty
377 simplExpr env (Let bind body) args result_ty
378 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
385 simplExpr env expr@(Case scrut alts) args result_ty
386 = simplCase env scrut
387 (getSubstEnvs env, alts)
388 (\env rhs -> simplExpr env rhs args result_ty)
396 simplExpr env (Note (Coerce to_ty from_ty) body) args result_ty
397 = simplCoerce env to_ty from_ty body args result_ty
399 simplExpr env (Note (SCC cc) body) args result_ty
400 = simplSCC env cc body args result_ty
402 -- InlineCall is simple enough to deal with on the spot
403 -- The only complication is that we slide the InlineCall
404 -- inwards past any function arguments
405 simplExpr env (Note InlineCall expr) args result_ty
408 go (Var v) args = simplVar env True {- InlineCall -} v args result_ty
410 go (App fun arg) args = simplArg env arg `appEager` \ arg' ->
413 go other args = -- Unexpected discard; report it
414 pprTrace "simplExpr: discarding InlineCall" (ppr expr) $
415 simplExpr env other args result_ty
420 %************************************************************************
422 \subsection{Simplify RHS of a Let/Letrec}
424 %************************************************************************
426 simplRhsExpr does arity-expansion. That is, given:
428 * a right hand side /\ tyvars -> \a1 ... an -> e
429 * the information (stored in BinderInfo) that the function will always
430 be applied to at least k arguments
432 it transforms the rhs to
434 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
436 This is a Very Good Thing!
443 -> OutId -- The new binder (used only for its type)
444 -> SmplM (OutExpr, ArityInfo)
449 simplRhsExpr env binder@(id,occ_info) rhs new_id
450 | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
451 -- Deal with the data type case, in which case the elaborate
452 -- eta-expansion nonsense is really quite a waste of time.
453 = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
454 returnSmpl (rhs', ArityExactly 0)
456 | otherwise -- OK, use the big hammer
457 = -- Deal with the big lambda part
458 simplTyBinders rhs_env tyvars `thenSmpl` \ (lam_env, tyvars') ->
460 body_ty = applyTys rhs_ty (mkTyVarTys tyvars')
462 -- Deal with the little lambda part
463 -- Note that we call simplLam even if there are no binders,
464 -- in case it can do arity expansion.
465 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
467 -- Put on the big lambdas, trying to float out any bindings caught inside
468 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
470 returnSmpl (rhs', arity)
472 rhs_ty = idType new_id
473 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
474 = switchOffInlining env1 -- See comments with switchOffInlining
478 -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
479 -- for the rhs of top level defs is "OST_CENTRE". Consider
481 -- g = \y -> let v = f y in scc "x" (v ...)
482 -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
483 -- want to inline "v" since its CC is dynamically determined.
485 current_cc = getEnclosingCC env
486 env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
489 (tyvars, body) = collectTyBinders rhs
493 ----------------------------------------------------------------
494 An old special case that is now nuked.
496 First a special case for variable right-hand sides
498 It's OK to simplify the RHS, but it's often a waste of time. Often
499 these v = w things persist because v is exported, and w is used
500 elsewhere. So if we're not careful we'll eta expand the rhs, only
501 to eta reduce it in competeNonRec.
503 If we leave the binding unchanged, we will certainly replace v by w at
504 every occurrence of v, which is good enough.
506 In fact, it's *better* to replace v by w than to inline w in v's rhs,
507 even if this is the only occurrence of w. Why? Because w might have
508 IdInfo (such as strictness) that v doesn't.
510 Furthermore, there might be other uses of w; if so, inlining w in
511 v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
513 HOWEVER, we have to be careful if w is something that *must* be
514 inlined. In particular, its binding may have been dropped. Here's
515 an example that actually happened:
516 let x = let y = e in y
518 The "let y" was floated out, and then (since y occurs once in a
519 definitely inlinable position) the binding was dropped, leaving
520 {y=e} let x = y in f x
521 But now using the reasoning of this little section,
522 y wasn't inlined, because it was a let x=y form.
527 This "optimisation" turned out to be a bad idea. If there's are
528 top-level exported bindings like
533 then y wasn't getting inlined in x's rhs, and we were getting
534 bad code. So I've removed the special case from here, and
535 instead we only try eta reduction and constructor reuse
536 in completeNonRec if the thing is *not* exported.
540 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
541 | maybeToBool maybe_stop_at_var
542 = returnSmpl (Var the_var, getIdArity the_var)
545 = case (runEager $ lookupId env v) of
546 VarArg v' | not (must_unfold v') -> Just v'
549 Just the_var = maybe_stop_at_var
551 must_unfold v' = idMustBeINLINEd v'
552 || case lookupOutIdEnv env v' of
553 Just (_, _, InUnfolding _ _) -> True
557 End of old, nuked, special case.
558 ------------------------------------------------------------------
561 %************************************************************************
563 \subsection{Simplify a lambda abstraction}
565 %************************************************************************
567 Simplify (\binders -> body) trying eta expansion and reduction, given that
568 the abstraction will always be applied to at least min_no_of_args.
571 simplValLam env expr min_no_of_args expr_ty
572 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
574 exprIsTrivial expr || -- or it's a trivial RHS
575 -- No eta expansion for trivial RHSs
576 -- It's rather a Bad Thing to expand
579 -- g = \a b c -> f alpha beta a b c
581 -- The original RHS is "trivial" (exprIsTrivial), because it generates
582 -- no code (renames f to g). But the new RHS isn't.
584 null potential_extra_binder_tys || -- or ain't a function
585 no_of_extra_binders <= 0 -- or no extra binders needed
586 = simplBinders env binders `thenSmpl` \ (new_env, binders') ->
587 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
588 returnSmpl (mkValLam binders' body', final_arity)
590 | otherwise -- Eta expansion possible
591 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
592 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
593 pprTrace "simplValLam" (vcat [ppr expr,
596 int no_of_extra_binders,
597 ppr potential_extra_binder_tys])
600 tick EtaExpansion `thenSmpl_`
601 simplBinders env binders `thenSmpl` \ (new_env, binders') ->
602 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
603 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
605 mkValLam (binders' ++ extra_binders') body',
610 (binders,body) = collectValBinders expr
611 no_of_binders = length binders
612 (arg_tys, res_ty) = splitFunTys expr_ty
613 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
614 pprTrace "simplValLam" (vcat [ppr expr,
618 drop no_of_binders arg_tys
619 body_ty = mkFunTys potential_extra_binder_tys res_ty
621 -- Note: it's possible that simplValLam will be applied to something
622 -- with a forall type. Eg when being applied to the rhs of
624 -- where wurble has a forall-type, but no big lambdas at the top.
625 -- We could be clever an insert new big lambdas, but we don't bother.
627 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
628 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
629 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
631 no_of_extra_binders = -- First, use the info about how many args it's
632 -- always applied to in its scope; but ignore this
633 -- info for thunks. To see why we ignore it for thunks,
634 -- consider let f = lookup env key in (f 1, f 2)
635 -- We'd better not eta expand f just because it is
637 (min_no_of_args - no_of_binders)
639 -- Next, try seeing if there's a lambda hidden inside
641 -- etaExpandCount can reuturn a huge number (like 10000!) if
642 -- it finds that the body is a call to "error"; hence
643 -- the use of "min" here.
645 (etaExpandCount body `min` length potential_extra_binder_tys)
647 -- Finally, see if it's a state transformer, in which
648 -- case we eta-expand on principle! This can waste work,
649 -- but usually doesn't
651 case potential_extra_binder_tys of
652 [ty] | ty == realWorldStatePrimTy -> 1
657 %************************************************************************
659 \subsection[Simplify-var]{Variables}
661 %************************************************************************
663 Check if there's a macro-expansion, and if so rattle on. Otherwise do
664 the more sophisticated stuff.
667 simplVar env inline_call var args result_ty
668 = case lookupIdSubst env var of
670 Just (SubstExpr ty_subst id_subst expr)
671 -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty
673 Just (SubstLit lit) -- A boring old literal
674 -> ASSERT( null args )
677 Just (SubstVar var') -- More interesting! An id!
678 -> completeVar env inline_call var' args result_ty
680 Nothing -- Not in the substitution; hand off to completeVar
681 -> completeVar env inline_call var args result_ty
685 %************************************************************************
687 \subsection[Simplify-coerce]{Coerce expressions}
689 %************************************************************************
692 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
693 simplCoerce env to_ty from_ty expr@(Case scrut alts) args result_ty
694 = simplCase env scrut (getSubstEnvs env, alts)
695 (\env rhs -> simplCoerce env to_ty from_ty rhs args result_ty)
698 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
699 simplCoerce env to_ty from_ty (Let bind body) args result_ty
700 = simplBind env bind (\env -> simplCoerce env to_ty from_ty body args result_ty) result_ty
703 -- NB: we do *not* push the argments inside the coercion
705 simplCoerce env to_ty from_ty expr args result_ty
706 = simplTy env to_ty `appEager` \ to_ty' ->
707 simplTy env from_ty `appEager` \ from_ty' ->
708 simplExpr env expr [] from_ty' `thenSmpl` \ expr' ->
709 returnSmpl (mkGenApp (mkCoerce to_ty' from_ty' expr') args)
711 -- Try cancellation; we do this "on the way up" because
712 -- I think that's where it'll bite best
713 mkCoerce to_ty1 from_ty1 (Note (Coerce to_ty2 from_ty2) body)
714 = ASSERT( from_ty1 == to_ty2 )
715 mkCoerce to_ty1 from_ty2 body
716 mkCoerce to_ty from_ty body
717 | to_ty == from_ty = body
718 | otherwise = Note (Coerce to_ty from_ty) body
722 %************************************************************************
724 \subsection[Simplify-scc]{SCC expressions
726 %************************************************************************
728 1) Eliminating nested sccs ...
729 We must be careful to maintain the scc counts ...
732 simplSCC env cc1 (Note (SCC cc2) expr) args result_ty
733 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
734 -- eliminate inner scc if no call counts and same cc as outer
735 = simplSCC env cc1 expr args result_ty
737 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
738 -- eliminate outer scc if no call counts associated with either ccs
739 = simplSCC env cc2 expr args result_ty
742 2) Moving sccs inside lambdas ...
745 simplSCC env cc (Lam binder@(ValBinder _) body) args result_ty
746 | not (isSccCountCostCentre cc)
747 -- move scc inside lambda only if no call counts
748 = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
750 simplSCC env cc (Lam binder body) args result_ty
751 -- always ok to move scc inside type/usage lambda
752 = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
755 3) Eliminating dict sccs ...
758 simplSCC env cc expr args result_ty
759 | squashableDictishCcExpr cc expr
760 -- eliminate dict cc if trivial dict expression
761 = simplExpr env expr args result_ty
764 4) Moving arguments inside the body of an scc ...
765 This moves the cost of doing the application inside the scc
766 (which may include the cost of extracting methods etc)
769 simplSCC env cc body args result_ty
771 new_env = setEnclosingCC env cc
773 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
774 returnSmpl (Note (SCC cc) body')
778 %************************************************************************
780 \subsection[Simplify-bind]{Binding groups}
782 %************************************************************************
785 simplBind :: SimplEnv
787 -> (SimplEnv -> SmplM OutExpr)
791 simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
792 simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
796 %************************************************************************
798 \subsection[Simplify-let]{Let-expressions}
800 %************************************************************************
804 The booleans controlling floating have to be set with a little care.
805 Here's one performance bug I found:
807 let x = let y = let z = case a# +# 1 of {b# -> E1}
812 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
813 Before case_floating_ok included float_exposes_hnf, the case expression was floated
814 *one level per simplifier iteration* outwards. So it made th s
817 Floating case from let
818 ~~~~~~~~~~~~~~~~~~~~~~
819 When floating cases out of lets, remember this:
821 let x* = case e of alts
824 where x* is sure to be demanded or e is a cheap operation that cannot
825 fail, e.g. unboxed addition. Here we should be prepared to duplicate
826 <small expr>. A good example:
835 p1 -> foldr c n (build e1)
836 p2 -> foldr c n (build e2)
838 NEW: We use the same machinery that we use for case-of-case to
839 *always* do case floating from let, that is we let bind and abstract
840 the original let body, and let the occurrence analyser later decide
841 whether the new let should be inlined or not. The example above
845 let join_body x' = foldr c n x'
847 p1 -> let x* = build e1
849 p2 -> let x* = build e2
852 note that join_body is a let-no-escape.
853 In this particular example join_body will later be inlined,
854 achieving the same effect.
855 ToDo: check this is OK with andy
858 Let to case: two points
861 Point 1. We defer let-to-case for all data types except single-constructor
862 ones. Suppose we change
868 It can be the case that we find that b ultimately contains ...(case x of ..)....
869 and this is the only occurrence of x. Then if we've done let-to-case
870 we can't inline x, which is a real pain. On the other hand, we lose no
871 transformations by not doing this transformation, because the relevant
872 case-of-X transformations are also implemented by simpl_bind.
874 If x is a single-constructor type, then we go ahead anyway, giving
876 case e of (y,z) -> let x = (y,z) in b
878 because now we can squash case-on-x wherever they occur in b.
880 We do let-to-case on multi-constructor types in the tidy-up phase
881 (tidyCoreExpr) mainly so that the code generator doesn't need to
882 spot the demand-flag.
885 Point 2. It's important to try let-to-case before doing the
886 strict-let-of-case transformation, which happens in the next equation
889 let a*::Int = case v of {p1->e1; p2->e2}
892 (The * means that a is sure to be demanded.)
893 If we do case-floating first we get this:
897 p1-> let a*=e1 in k a
898 p2-> let a*=e2 in k a
900 Now watch what happens if we do let-to-case first:
902 case (case v of {p1->e1; p2->e2}) of
903 Int a# -> let a*=I# a# in b
905 let k = \a# -> let a*=I# a# in b
907 p1 -> case e1 of I# a# -> k a#
908 p1 -> case e2 of I# a# -> k a#
910 The latter is clearly better. (Remember the reboxing let-decl for a
911 is likely to go away, because after all b is strict in a.)
913 We do not do let to case for WHNFs, e.g.
919 as this is less efficient. but we don't mind doing let-to-case for
920 "bottom", as that will allow us to remove more dead code, if anything:
924 case error of x -> ...
928 Notice that let to case occurs only if x is used strictly in its body
933 -- Dead code is now discarded by the occurrence analyser,
935 simplNonRec env binder@(id,_) rhs body_c body_ty
936 | inlineUnconditionally binder
937 = -- The binder is used in definitely-inline way in the body
938 -- So add it to the environment, drop the binding, and continue
939 body_c (bindIdToExpr env binder rhs)
941 | idWantsToBeINLINEd id
942 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
945 -- Do let-to-case right away for unpointed types
946 -- These shouldn't occur much, but do occur right after desugaring,
947 -- because we havn't done dependency analysis at that point, so
948 -- we can't trivially do let-to-case (because there may be some unboxed
949 -- things bound in letrecs that aren't really recursive).
950 | isUnpointedType rhs_ty && not rhs_is_whnf
951 = simplCase env rhs (getSubstEnvs env, PrimAlts [] (BindDefault binder (Var id)))
952 (\env rhs -> complete_bind env rhs) body_ty
954 -- Try let-to-case; see notes below about let-to-case
958 || (not rhs_is_whnf && singleConstructorType rhs_ty)
959 -- Don't do let-to-case if the RHS is a constructor application.
960 -- Even then only do it for single constructor types.
961 -- For other types we defer doing it until the tidy-up phase at
962 -- the end of simplification.
964 = tick Let2Case `thenSmpl_`
965 simplCase env rhs (getSubstEnvs env, AlgAlts [] (BindDefault binder (Var id)))
966 (\env rhs -> complete_bind env rhs) body_ty
967 -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
968 -- NB: it's tidier to call complete_bind not simpl_bind, else
969 -- we nearly end up in a loop. Consider:
971 -- ==> case rhs of (p,q) -> let x=(p,q) in b
972 -- This effectively what the above simplCase call does.
973 -- Now, the inner let is a let-to-case target again! Actually, since
974 -- the RHS is in WHNF it won't happen, but it's a close thing!
980 simpl_bind env (Let bind rhs) | let_floating_ok
981 = tick LetFloatFromLet `thenSmpl_`
982 simplBind env (if will_be_demanded then bind
983 else un_demandify_bind bind)
984 (\env -> simpl_bind env rhs) body_ty
986 -- Try case-from-let; this deals with a strict let of error too
987 simpl_bind env (Case scrut alts) | case_floating_ok scrut
988 = tick CaseFloatFromLet `thenSmpl_`
990 -- First, bind large let-body if necessary
991 if isSingleton (nonErrorRHSs alts)
993 simplCase env scrut (getSubstEnvs env, alts)
994 (\env rhs -> simpl_bind env rhs) body_ty
996 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
998 body_c' = \env -> simplExpr env new_body [] body_ty
999 case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
1001 simplCase env scrut (getSubstEnvs env, alts) case_c body_ty `thenSmpl` \ case_expr ->
1002 returnSmpl (Let extra_binding case_expr)
1004 -- None of the above; simplify rhs and tidy up
1005 simpl_bind env rhs = complete_bind env rhs
1007 complete_bind env rhs
1008 = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) ->
1009 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
1010 completeNonRec env_w_clone binder
1011 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
1012 body_c new_env `thenSmpl` \ body' ->
1013 returnSmpl (mkCoLetsAny binds body')
1016 -- All this stuff is computed at the start of the simpl_bind loop
1017 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1018 float_primops = switchIsSet env SimplOkToFloatPrimOps
1019 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1020 try_let_to_case = switchIsSet env SimplLetToCase
1021 no_float = switchIsSet env SimplNoLetFromStrictLet
1023 demand_info = getIdDemandInfo id
1024 will_be_demanded = willBeDemanded demand_info
1027 form = mkFormSummary rhs
1028 rhs_is_bot = case form of
1031 rhs_is_whnf = case form of
1036 float_exposes_hnf = floatExposesHNF float_lets float_primops rhs
1038 let_floating_ok = (will_be_demanded && not no_float) ||
1039 always_float_let_from_let ||
1042 case_floating_ok scrut = (will_be_demanded && not no_float) ||
1043 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
1048 @completeNonRec@ looks at the simplified post-floating RHS of the
1049 let-expression, with a view to turning
1053 where y is just a variable. Now we can eliminate the binding
1054 altogether, and replace x by y throughout.
1056 There are two cases when we can do this:
1058 * When e is a constructor application, and we have
1059 another variable in scope bound to the same
1060 constructor application. [This is just a special
1061 case of common-subexpression elimination.]
1063 * When e can be eta-reduced to a variable. E.g.
1067 HOWEVER, if x is exported, we don't attempt this at all. Why not?
1068 Because then we can't remove the x=y binding, in which case we
1069 have just made things worse, perhaps a lot worse.
1072 completeNonRec env binder new_id new_rhs
1073 = returnSmpl (env', [NonRec b r | (b,r) <- binds])
1075 (env', binds) = completeBind env binder new_id new_rhs
1078 completeBind :: SimplEnv
1079 -> InBinder -> OutId -> OutExpr -- Id and RHS
1080 -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
1082 completeBind env binder@(_,occ_info) new_id new_rhs
1083 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1086 | atomic_rhs -- If rhs (after eta reduction) is atomic
1087 && not (isExported new_id) -- and binder isn't exported
1088 = -- Drop the binding completely
1090 env1 = notInScope env new_id
1091 env2 = bindIdToAtom env1 binder the_arg
1095 {- This case is WRONG. It attempts to exploit knowledge that indirections
1096 are eliminated (by OccurAnal), but they *aren't* for recursive bindings.
1097 If this case is enabled, then
1100 ... = case global of ...
1102 never gets simplified
1104 | atomic_rhs -- Rhs is atomic, and new_id is exported
1105 && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False }
1106 = -- The local variable v will be eliminated next time round
1107 -- in favour of new_id, so it's a waste to replace all new_id's with v's
1109 -- This case is an optional improvement; saves a simplifier iteration
1110 (env, [(new_id, eta'd_rhs)])
1113 | otherwise -- Non-atomic
1115 env1 = extendEnvGivenBinding env occ_info new_id new_rhs
1120 new_binds = [(new_id, new_rhs)]
1121 atomic_rhs = is_atomic eta'd_rhs
1122 eta'd_rhs = case lookForConstructor env new_rhs of
1124 other -> etaCoreExpr new_rhs
1126 the_arg = case eta'd_rhs of
1131 ----------------------------------------------------------------------------
1132 A digression on constructor CSE
1140 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1141 bit on the compiler technology, but in general I believe not. For
1142 example, here's some code from a real program:
1144 const.Int.max.wrk{-s2516-} =
1145 \ upk.s3297# upk.s3298# ->
1149 a.s3299 = I#! upk.s3297#
1151 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1152 _LT -> I#! upk.s3298#
1157 The a.s3299 really isn't doing much good. We'd be better off inlining
1158 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1160 So the current strategy is to inline all known-form constructors, and
1161 only do the reverse (turn a constructor application back into a
1162 variable) when we find a let-expression:
1166 ... (let y = C a1 .. an in ...) ...
1168 where it is always good to ditch the binding for y, and replace y by
1171 ----------------------------------------------------------------------------
1173 ----------------------------------------------------------------------------
1174 A digression on "optimising" coercions
1176 The trouble is that we kept transforming
1184 and counting a couple of ticks for this non-transformation
1186 -- We want to ensure that all let-bound Coerces have
1187 -- atomic bodies, so they can freely be inlined.
1188 completeNonRec env binder new_id (Coerce coercion ty rhs)
1189 | not (is_atomic rhs)
1190 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1192 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1193 -- Dangerous occ because, like constructor args,
1194 -- it can be duplicated easily
1196 atomic_rhs = case runEager $ lookupId env1 inner_id of
1200 completeNonRec env1 binder new_id
1201 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1203 returnSmpl (env2, binds1 ++ binds2)
1205 ----------------------------------------------------------------------------
1209 %************************************************************************
1211 \subsection[Simplify-letrec]{Letrec-expressions}
1213 %************************************************************************
1217 Here's the game plan
1219 1. Float any let(rec)s out of the RHSs
1220 2. Clone all the Ids and extend the envt with these clones
1221 3. Simplify one binding at a time, adding each binding to the
1222 environment once it's done.
1224 This relies on the occurrence analyser to
1225 a) break all cycles with an Id marked MustNotBeInlined
1226 b) sort the decls into topological order
1227 The former prevents infinite inlinings, and the latter means
1228 that we get maximum benefit from working top to bottom.
1232 simplRec env pairs body_c body_ty
1233 = -- Do floating, if necessary
1234 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1236 binders = map fst pairs'
1238 simplBinders env binders `thenSmpl` \ (env_w_clones, ids') ->
1239 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1241 body_c new_env `thenSmpl` \ body' ->
1243 returnSmpl (Let (Rec pairs') body')
1247 -- The env passed to simplRecursiveGroup already has
1248 -- bindings that clone the variables of the group.
1249 simplRecursiveGroup env new_ids []
1250 = returnSmpl ([], env)
1252 simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs)
1253 | inlineUnconditionally binder
1254 = -- Single occurrence, so drop binding and extend env with the inlining
1255 -- This is a little delicate, because what if the unique occurrence
1256 -- is *before* this binding? This'll never happen, because
1257 -- either it'll be marked "never inline" or else its occurrence will
1258 -- occur after its binding in the group.
1260 -- If these claims aren't right Core Lint will spot an unbound
1261 -- variable. A quick fix is to delete this clause for simplRecursiveGroup
1263 new_env = bindIdToExpr env binder rhs
1265 simplRecursiveGroup new_env new_ids pairs
1268 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1270 new_id' = new_id `withArity` arity
1271 (new_env, new_binds') = completeBind env binder new_id' new_rhs
1273 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1274 returnSmpl (new_binds' ++ new_pairs, final_env)
1280 floatBind :: SimplEnv
1281 -> Bool -- True <=> Top level
1283 -> SmplM [InBinding]
1285 floatBind env top_level bind
1291 = tickN LetFloatFromLet n_extras `thenSmpl_`
1292 -- It's important to increment the tick counts if we
1293 -- do any floating. A situation where this turns out
1294 -- to be important is this:
1295 -- Float in produces:
1296 -- letrec x = let y = Ey in Ex
1298 -- Now floating gives this:
1302 --- We now want to iterate once more in case Ey doesn't
1303 -- mention x, in which case the y binding can be pulled
1304 -- out as an enclosing let(rec), which in turn gives
1305 -- the strictness analyser more chance.
1309 binds' = fltBind bind
1310 n_extras = sum (map no_of_binds binds') - no_of_binds bind
1312 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1313 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1315 -- fltBind guarantees not to return leaky floats
1316 -- and all the binders of the floats have had their demand-info zapped
1317 fltBind (NonRec bndr rhs)
1318 = binds ++ [NonRec bndr rhs']
1320 (binds, rhs') = fltRhs rhs
1325 pairs' = concat [ let
1326 (binds, rhs') = fltRhs rhs
1328 foldr get_pairs [(bndr, rhs')] binds
1329 | (bndr, rhs) <- pairs
1332 get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest
1333 get_pairs (Rec pairs) rest = pairs ++ rest
1335 -- fltRhs has same invariant as fltBind
1337 | (always_float_let_from_let ||
1338 floatExposesHNF True False rhs)
1345 -- fltExpr has same invariant as fltBind
1346 fltExpr (Let bind body)
1347 | not top_level || binds_wont_leak
1348 -- fltExpr guarantees not to return leaky floats
1349 = (binds' ++ body_binds, body')
1351 binds_wont_leak = all leakFreeBind binds'
1352 (body_binds, body') = fltExpr body
1353 binds' = fltBind (un_demandify_bind bind)
1355 fltExpr expr = ([], expr)
1357 -- Crude but effective
1358 no_of_binds (NonRec _ _) = 1
1359 no_of_binds (Rec pairs) = length pairs
1361 leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
1362 leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
1364 leakFree (id,_) rhs = case getIdArity id of
1365 ArityAtLeast n | n > 0 -> True
1366 ArityExactly n | n > 0 -> True
1367 other -> whnfOrBottom (mkFormSummary rhs)
1371 %************************************************************************
1373 \subsection[Simplify-atoms]{Simplifying atoms}
1375 %************************************************************************
1378 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1380 simplArg env (LitArg lit) = returnEager (LitArg lit)
1381 simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
1382 returnEager (TyArg ty')
1383 simplArg env arg@(VarArg id)
1384 = case lookupIdSubst env id of
1385 Just (SubstVar id') -> returnEager (VarArg id')
1386 Just (SubstLit lit) -> returnEager (LitArg lit)
1387 Just (SubstExpr _ __) -> panic "simplArg"
1388 Nothing -> case lookupOutIdEnv env id of
1389 Just (id', _, _) -> returnEager (VarArg id')
1390 Nothing -> returnEager arg
1393 %************************************************************************
1395 \subsection[Simplify-quickies]{Some local help functions}
1397 %************************************************************************
1401 -- un_demandify_bind switches off the willBeDemanded Info field
1402 -- for bindings floated out of a non-demanded let
1403 un_demandify_bind (NonRec binder rhs)
1404 = NonRec (un_demandify_bndr binder) rhs
1405 un_demandify_bind (Rec pairs)
1406 = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
1408 un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1410 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1411 is_cheap_prim_app other = False
1413 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1414 computeResultType env expr_ty orig_args
1415 = simplTy env expr_ty `appEager` \ expr_ty' ->
1418 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1419 go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
1420 Just (_, res_ty) -> go res_ty args
1422 pprPanic "computeResultType" (vcat [
1428 go expr_ty' orig_args
1431 var `withArity` UnknownArity = var
1432 var `withArity` arity = var `addIdArity` arity
1434 is_atomic (Var v) = True
1435 is_atomic (Lit l) = not (isNoRepLit l)
1436 is_atomic other = False