2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[Simplify]{The main module of the simplifier}
7 #include "HsVersions.h"
9 module Simplify ( simplTopBinds, simplExpr, simplBind ) where
12 IMPORT_DELOOPER(SmplLoop) -- paranoia checking
13 IMPORT_1_3(List(partition))
16 import CmdLineOpts ( SimplifierSwitch(..) )
17 import ConFold ( completePrim )
18 import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, FormSummary(..) )
19 import CostCentre ( isSccCountCostCentre, cmpCostCentre )
21 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
22 unTagBinders, squashableDictishCcExpr
24 import Id ( idType, idWantsToBeINLINEd,
26 getIdDemandInfo, addIdDemandInfo,
27 GenId{-instance NamedThing-}
29 import IdInfo ( willBeDemanded, DemandInfo )
30 import Literal ( isNoRepLit )
31 import Maybes ( maybeToBool )
32 --import Name ( isExported )
33 import PprStyle ( PprStyle(..) )
34 import PprType ( GenType{-instance Outputable-} )
35 import Pretty ( ppAbove )
36 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
37 import SimplCase ( simplCase, bindLargeRhs )
40 import SimplVar ( completeVar )
42 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
43 splitFunTy, getFunTy_maybe, eqTy
45 import TysWiredIn ( realWorldStateTy )
46 import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
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)
183 * No floating. Case floating is obviously out. Let floating is
184 theoretically OK, but dangerous because of space leaks.
185 The long-distance let-floater lifts these lets.
188 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
190 simplTopBinds env [] = returnSmpl []
192 -- Dead code is now discarded by the occurrence analyser,
194 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
195 = -- No cloning necessary at top level
196 -- Process the binding
197 simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
198 completeNonRec env binder in_id rhs' `thenSmpl` \ (new_env, binds1') ->
200 -- Process the other bindings
201 simplTopBinds new_env binds `thenSmpl` \ binds2' ->
203 -- Glue together and return ...
204 returnSmpl (binds1' ++ binds2')
206 simplTopBinds env (Rec pairs : binds)
207 = simplRecursiveGroup env ids pairs `thenSmpl` \ (bind', new_env) ->
209 -- Process the other bindings
210 simplTopBinds new_env binds `thenSmpl` \ binds' ->
212 -- Glue together and return
213 returnSmpl (bind' : binds')
215 ids = [id | (binder@(id,_), rhs) <- pairs] -- No cloning necessary at top level
218 %************************************************************************
220 \subsection[Simplify-simplExpr]{The main function: simplExpr}
222 %************************************************************************
226 simplExpr :: SimplEnv
227 -> InExpr -> [OutArg]
231 The expression returned has the same meaning as the input expression
232 applied to the specified arguments.
237 Check if there's a macro-expansion, and if so rattle on. Otherwise do
238 the more sophisticated stuff.
241 simplExpr env (Var v) args
242 = case (lookupId env v) of
243 LitArg lit -- A boring old literal
244 -> ASSERT( null args )
247 VarArg var -- More interesting! An id!
248 -> completeVar env var args
249 -- Either Id is in the local envt, or it's a global.
250 -- In either case we don't need to apply the type
251 -- environment to it.
258 simplExpr env (Lit l) [] = returnSmpl (Lit l)
260 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
264 Primitive applications are simple.
265 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
267 NB: Prim expects an empty argument list! (Because it should be
268 saturated and not higher-order. ADR)
271 simplExpr env (Prim op prim_args) args
274 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
277 completePrim env op' prim_args'
279 -- PrimOps just need any types in them renamed.
281 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
283 arg_tys' = map (simplTy env) arg_tys
284 result_ty' = simplTy env result_ty
286 CCallOp label is_asm may_gc arg_tys' result_ty'
288 simpl_op other_op = other_op
291 Constructor applications
292 ~~~~~~~~~~~~~~~~~~~~~~~~
293 Nothing to try here. We only reuse constructors when they appear as the
294 rhs of a let binding (see completeLetBinding).
297 simplExpr env (Con con con_args) args
298 = ASSERT( null args )
299 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
303 Applications are easy too:
304 ~~~~~~~~~~~~~~~~~~~~~~~~~~
305 Just stuff 'em in the arg stack
308 simplExpr env (App fun arg) args
309 = simplExpr env fun (simplArg env arg : args)
315 We only eta-reduce a type lambda if all type arguments in the body can
316 be eta-reduced. This requires us to collect up all tyvar parameters so
317 we can pass them all to @mkTyLamTryingEta@.
320 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
321 = -- ASSERT(not (isPrimType ty))
322 tick TyBetaReduction `thenSmpl_`
323 simplExpr (extendTyEnv env tyvar ty) body args
325 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
326 = do_tylambdas env [] tylam
328 do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
329 = -- Clone the type variable
330 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
332 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
334 do_tylambdas new_env (tyvar':tyvars') body
336 do_tylambdas env tyvars' body
337 = simplExpr env body [] `thenSmpl` \ body' ->
339 (if switchIsSet env SimplDoEtaReduction
340 then mkTyLamTryingEta
341 else mkTyLam) (reverse tyvars') body'
345 simplExpr env (Lam (TyBinder _) _) (_ : _)
346 = panic "simplExpr:TyLam with non-TyArg"
354 There's a complication with lambdas that aren't saturated.
359 If we did nothing, x is used inside the \y, so would be marked
360 as dangerous to dup. But in the common case where the abstraction
361 is applied to two arguments this is over-pessimistic.
362 So instead we don't take account of the \y when dealing with x's usage;
363 instead, the simplifier is careful when partially applying lambdas.
366 simplExpr env expr@(Lam (ValBinder binder) body) orig_args
367 = go 0 env expr orig_args
369 go n env (Lam (ValBinder binder) body) (val_arg : args)
370 | isValArg val_arg -- The lambda has an argument
371 = tick BetaReduction `thenSmpl_`
372 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
374 go n env expr@(Lam (ValBinder binder) body) args
375 -- The lambda is un-saturated, so we must zap the occurrence info
376 -- on the arguments we've already beta-reduced into the body of the lambda
377 = ASSERT( null args ) -- Value lambda must match value argument!
379 new_env = markDangerousOccs env (take n orig_args)
381 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
383 go n env non_val_lam_expr args -- The lambda had enough arguments
384 = simplExpr env non_val_lam_expr args
392 simplExpr env (Let bind body) args
393 = simplBind env bind (\env -> simplExpr env body args)
394 (computeResultType env body args)
401 simplExpr env expr@(Case scrut alts) args
402 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
403 (computeResultType env expr args)
410 simplExpr env (Coerce coercion ty body) args
411 = simplCoerce env coercion ty body args
418 1) Eliminating nested sccs ...
419 We must be careful to maintain the scc counts ...
422 simplExpr env (SCC cc1 (SCC cc2 expr)) args
423 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
424 -- eliminate inner scc if no call counts and same cc as outer
425 = simplExpr env (SCC cc1 expr) args
427 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
428 -- eliminate outer scc if no call counts associated with either ccs
429 = simplExpr env (SCC cc2 expr) args
432 2) Moving sccs inside lambdas ...
435 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args
436 | not (isSccCountCostCentre cc)
437 -- move scc inside lambda only if no call counts
438 = simplExpr env (Lam binder (SCC cc body)) args
440 simplExpr env (SCC cc (Lam binder body)) args
441 -- always ok to move scc inside type/usage lambda
442 = simplExpr env (Lam binder (SCC cc body)) args
445 3) Eliminating dict sccs ...
448 simplExpr env (SCC cc expr) args
449 | squashableDictishCcExpr cc expr
450 -- eliminate dict cc if trivial dict expression
451 = simplExpr env expr args
454 4) Moving arguments inside the body of an scc ...
455 This moves the cost of doing the application inside the scc
456 (which may include the cost of extracting methods etc)
459 simplExpr env (SCC cost_centre body) args
461 new_env = setEnclosingCC env cost_centre
463 simplExpr new_env body args `thenSmpl` \ body' ->
464 returnSmpl (SCC cost_centre body')
467 %************************************************************************
469 \subsection{Simplify RHS of a Let/Letrec}
471 %************************************************************************
473 simplRhsExpr does arity-expansion. That is, given:
475 * a right hand side /\ tyvars -> \a1 ... an -> e
476 * the information (stored in BinderInfo) that the function will always
477 be applied to at least k arguments
479 it transforms the rhs to
481 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
483 This is a Very Good Thing!
492 simplRhsExpr env binder@(id,occ_info) rhs
493 | dont_eta_expand rhs
494 = simplExpr rhs_env rhs []
496 | otherwise -- Have a go at eta expansion
497 = -- Deal with the big lambda part
498 ASSERT( null uvars ) -- For now
500 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
502 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
504 -- Deal with the little lambda part
505 -- Note that we call simplLam even if there are no binders,
506 -- in case it can do arity expansion.
507 simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ lambda' ->
509 -- Put it back together
511 (if switchIsSet env SimplDoEtaReduction
512 then mkTyLamTryingEta
513 else mkTyLam) tyvars' lambda'
517 rhs_env | not (switchIsSet env IgnoreINLINEPragma) &&
518 idWantsToBeINLINEd id
519 = switchOffInlining env
523 -- Switch off all inlining in the RHS of things that have an INLINE pragma.
524 -- They are going to be inlined wherever they are used, and then all the
525 -- inlining will take effect. Meanwhile, there isn't
526 -- much point in doing anything to the as-yet-un-INLINEd rhs.
527 -- It's very important to switch off inlining! Consider:
529 -- let f = \pq -> BIG
531 -- let g = \y -> f y y
533 -- in ...g...g...g...g...g...
535 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
536 -- and thence copied multiple times when g is inlined.
538 -- Andy disagrees! Example:
539 -- all xs = foldr (&&) True xs
540 -- any p = all . map p {-# INLINE any #-}
542 -- Problem: any won't get deforested, and so if it's exported and
543 -- the importer doesn't use the inlining, (eg passes it as an arg)
544 -- then we won't get deforestation at all.
545 -- We havn't solved this problem yet!
547 (uvars, tyvars, body) = collectUsageAndTyBinders rhs
549 -- dont_eta_expand prevents eta expansion in silly situations.
550 -- For example, consider the defn
552 -- It would be silly to eta expand the "y", because it would just
553 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
554 -- and x was exported, then the defn won't be eliminated, so this
555 -- silly expand/reduce cycle will happen every time, which makes the
557 -- The solution is to not even try eta expansion unless the rhs looks
559 dont_eta_expand (Lit _) = True
560 dont_eta_expand (Var _) = True
561 dont_eta_expand (Con _ _) = True
562 dont_eta_expand (App f a)
563 | notValArg a = dont_eta_expand f
564 dont_eta_expand (Lam x b)
565 | notValBinder x = dont_eta_expand b
566 dont_eta_expand _ = False
570 %************************************************************************
572 \subsection{Simplify a lambda abstraction}
574 %************************************************************************
576 Simplify (\binders -> body) trying eta expansion and reduction, given that
577 the abstraction will always be applied to at least min_no_of_args.
580 simplValLam env expr min_no_of_args
581 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
582 null binders || -- or it's a thunk
583 null potential_extra_binder_tys || -- or ain't a function
584 no_of_extra_binders <= 0 -- or no extra binders needed
585 = cloneIds env binders `thenSmpl` \ binders' ->
587 new_env = extendIdEnvWithClones env binders binders'
589 simplExpr new_env body [] `thenSmpl` \ body' ->
591 (if switchIsSet new_env SimplDoEtaReduction
592 then mkValLamTryingEta
593 else mkValLam) binders' body'
596 | otherwise -- Eta expansion possible
597 = tick EtaExpansion `thenSmpl_`
598 cloneIds env binders `thenSmpl` \ binders' ->
600 new_env = extendIdEnvWithClones env binders binders'
602 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
603 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
605 (if switchIsSet new_env SimplDoEtaReduction
606 then mkValLamTryingEta
607 else mkValLam) (binders' ++ extra_binders') body'
611 (binders,body) = collectValBinders expr
612 (potential_extra_binder_tys, res_ty)
613 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
614 -- Note: it's possible that simplValLam will be applied to something
615 -- with a forall type. Eg when being applied to the rhs of
617 -- where wurble has a forall-type, but no big lambdas at the top.
618 -- We could be clever an insert new big lambdas, but we don't bother.
620 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
622 no_of_extra_binders = -- First, use the info about how many args it's
623 -- always applied to in its scope
624 (min_no_of_args - length binders)
626 -- Next, try seeing if there's a lambda hidden inside
631 -- Finally, see if it's a state transformer, in which
632 -- case we eta-expand on principle! This can waste work,
633 -- but usually doesn't
635 case potential_extra_binder_tys of
636 [ty] | ty `eqTy` realWorldStateTy -> 1
643 %************************************************************************
645 \subsection[Simplify-coerce]{Coerce expressions}
647 %************************************************************************
650 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
651 simplCoerce env coercion ty expr@(Case scrut alts) args
652 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
653 (computeResultType env expr args)
655 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
656 simplCoerce env coercion ty (Let bind body) args
657 = simplBind env bind (\env -> simplCoerce env coercion ty body args)
658 (computeResultType env body args)
661 simplCoerce env coercion ty expr args
662 = simplExpr env expr [] `thenSmpl` \ expr' ->
663 returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
666 -- Try cancellation; we do this "on the way up" because
667 -- I think that's where it'll bite best
668 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
669 mkCoerce coercion ty body = Coerce coercion ty body
673 %************************************************************************
675 \subsection[Simplify-let]{Let-expressions}
677 %************************************************************************
680 simplBind :: SimplEnv
682 -> (SimplEnv -> SmplM OutExpr)
687 When floating cases out of lets, remember this:
689 let x* = case e of alts
692 where x* is sure to be demanded or e is a cheap operation that cannot
693 fail, e.g. unboxed addition. Here we should be prepared to duplicate
694 <small expr>. A good example:
703 p1 -> foldr c n (build e1)
704 p2 -> foldr c n (build e2)
706 NEW: We use the same machinery that we use for case-of-case to
707 *always* do case floating from let, that is we let bind and abstract
708 the original let body, and let the occurrence analyser later decide
709 whether the new let should be inlined or not. The example above
713 let join_body x' = foldr c n x'
715 p1 -> let x* = build e1
717 p2 -> let x* = build e2
720 note that join_body is a let-no-escape.
721 In this particular example join_body will later be inlined,
722 achieving the same effect.
723 ToDo: check this is OK with andy
728 -- Dead code is now discarded by the occurrence analyser,
730 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
733 -- Try let-to-case; see notes below about let-to-case
734 simpl_bind env rhs | will_be_demanded &&
736 type_ok_for_let_to_case rhs_ty &&
737 not rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
738 = tick Let2Case `thenSmpl_`
739 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
740 simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty
741 -- NB: it's tidier to call complete_bind not simpl_bind, else
742 -- we nearly end up in a loop. Consider:
744 -- ==> case rhs of (p,q) -> let x=(p,q) in b
745 -- This effectively what the above simplCase call does.
746 -- Now, the inner let is a let-to-case target again! Actually, since
747 -- the RHS is in WHNF it won't happen, but it's a close thing!
750 simpl_bind env (Let bind rhs) | let_floating_ok
751 = tick LetFloatFromLet `thenSmpl_`
752 simplBind env (fix_up_demandedness will_be_demanded bind)
753 (\env -> simpl_bind env rhs) body_ty
755 -- Try case-from-let; this deals with a strict let of error too
756 simpl_bind env (Case scrut alts) | will_be_demanded ||
757 (float_primops && is_cheap_prim_app scrut)
758 = tick CaseFloatFromLet `thenSmpl_`
760 -- First, bind large let-body if necessary
761 if ok_to_dup || isSingleton (nonErrorRHSs alts)
763 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
765 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
767 body_c' = \env -> simplExpr env new_body []
768 case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
770 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
771 returnSmpl (Let extra_binding case_expr)
773 -- None of the above; simplify rhs and tidy up
774 simpl_bind env rhs = complete_bind env rhs
776 complete_bind env rhs
777 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
778 cloneId env binder `thenSmpl` \ new_id ->
779 completeNonRec env binder new_id rhs' `thenSmpl` \ (new_env, binds) ->
780 body_c new_env `thenSmpl` \ body' ->
781 returnSmpl (mkCoLetsAny binds body')
784 -- All this stuff is computed at the start of the simpl_bind loop
785 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
786 float_primops = switchIsSet env SimplOkToFloatPrimOps
787 ok_to_dup = switchIsSet env SimplOkToDupCode
788 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
789 try_let_to_case = switchIsSet env SimplLetToCase
790 no_float = switchIsSet env SimplNoLetFromStrictLet
792 will_be_demanded = willBeDemanded (getIdDemandInfo id)
795 rhs_is_whnf = case mkFormSummary rhs of
800 let_floating_ok = (will_be_demanded && not no_float) ||
801 always_float_let_from_let ||
802 floatExposesHNF float_lets float_primops ok_to_dup rhs
807 It's important to try let-to-case before floating. Consider
809 let a*::Int = case v of {p1->e1; p2->e2}
812 (The * means that a is sure to be demanded.)
813 If we do case-floating first we get this:
817 p1-> let a*=e1 in k a
818 p2-> let a*=e2 in k a
820 Now watch what happens if we do let-to-case first:
822 case (case v of {p1->e1; p2->e2}) of
823 Int a# -> let a*=I# a# in b
825 let k = \a# -> let a*=I# a# in b
827 p1 -> case e1 of I# a# -> k a#
828 p1 -> case e1 of I# a# -> k a#
830 The latter is clearly better. (Remember the reboxing let-decl for a
831 is likely to go away, because after all b is strict in a.)
833 We do not do let to case for WHNFs, e.g.
839 as this is less efficient. but we don't mind doing let-to-case for
840 "bottom", as that will allow us to remove more dead code, if anything:
844 case error of x -> ...
848 Notice that let to case occurs only if x is used strictly in its body
855 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
856 on and it'll expose a HNF), and bang the whole resulting mess together
859 1. Any "macros" should be expanded. The main application of this
868 Here we would like the single call to g to be inlined.
870 We can spot this easily, because g will be tagged as having just one
871 occurrence. The "inlineUnconditionally" predicate is just what we want.
873 A worry: could this lead to non-termination? For example:
882 Here, f and g call each other (just once) and neither is used elsewhere.
885 * the occurrence analyser will drop any (sub)-group that isn't used at
888 * If the group is used outside itself (ie in the "in" part), then there
891 ** IMPORTANT: check that NewOccAnal has the property that a group of
892 bindings like the above has f&g dropped.! ***
895 2. We'd also like to pull out any top-level let(rec)s from the
899 f = let h = ... in \x -> ....h...f...h...
905 f = \x -> ....h...f...h...
909 But floating cases is less easy? (Don't for now; ToDo?)
912 3. We'd like to arrange that the RHSs "know" about members of the
913 group that are bound to constructors. For example:
917 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
918 /= a b = unpack tuple a, unpack tuple b, call f
921 here, by knowing about d.Eq in f's rhs, one could get rid of
922 the case (and break out the recursion completely).
923 [This occurred with more aggressive inlining threshold (4),
924 nofib/spectral/knights]
927 1: we simplify constructor rhss first.
928 2: we record the "known constructors" in the environment
929 3: we simplify the other rhss, with the knowledge about the constructors
934 simplBind env (Rec pairs) body_c body_ty
935 = -- Do floating, if necessary
937 floated_pairs | do_floating = float_pairs pairs
940 ticks | do_floating = length floated_pairs - length pairs
943 binders = map fst floated_pairs
945 tickN LetFloatFromLet ticks `thenSmpl_`
946 -- It's important to increment the tick counts if we
947 -- do any floating. A situation where this turns out
948 -- to be important is this:
949 -- Float in produces:
950 -- letrec x = let y = Ey in Ex
952 -- Now floating gives this:
956 --- We now want to iterate once more in case Ey doesn't
957 -- mention x, in which case the y binding can be pulled
958 -- out as an enclosing let(rec), which in turn gives
959 -- the strictness analyser more chance.
961 cloneIds env binders `thenSmpl` \ ids' ->
963 env_w_clones = extendIdEnvWithClones env binders ids'
965 simplRecursiveGroup env_w_clones ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
967 body_c new_env `thenSmpl` \ body' ->
969 returnSmpl (Let binding body')
972 ------------ Floating stuff -------------------
974 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
975 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
976 do_floating = float_lets || always_float_let_from_let
978 float_pairs pairs = concat (map float_pair pairs)
980 float_pair (binder, rhs)
981 | always_float_let_from_let ||
982 floatExposesHNF True False False rhs
983 = (binder,rhs') : pairs'
988 (pairs', rhs') = do_float rhs
990 -- Float just pulls out any top-level let(rec) bindings
991 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
992 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
994 (pairs', body') = do_float body
995 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
997 (pairs', body') = do_float body
998 do_float other = ([], other)
1000 simplRecursiveGroup env new_ids pairs
1001 = -- Add unfoldings to the new_ids corresponding to their RHS
1003 binders = map fst pairs
1004 occs = map snd binders
1005 new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
1006 rhs_env = foldl extendEnvForRecBinding
1010 mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss ->
1013 new_pairs = zipEqual "simplRecGp" new_ids new_rhss
1014 occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
1015 new_env = foldl add_binding env occs_w_new_pairs
1017 add_binding env (occ_info,(new_id,new_rhs))
1018 = extendEnvGivenBinding env occ_info new_id new_rhs
1020 returnSmpl (Rec new_pairs, new_env)
1024 @completeLet@ looks at the simplified post-floating RHS of the
1025 let-expression, and decides what to do. There's one interesting
1026 aspect to this, namely constructor reuse. Consider
1032 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1033 bit on the compiler technology, but in general I believe not. For
1034 example, here's some code from a real program:
1036 const.Int.max.wrk{-s2516-} =
1037 \ upk.s3297# upk.s3298# ->
1041 a.s3299 = I#! upk.s3297#
1043 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1044 _LT -> I#! upk.s3298#
1049 The a.s3299 really isn't doing much good. We'd be better off inlining
1050 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1052 So the current strategy is to inline all known-form constructors, and
1053 only do the reverse (turn a constructor application back into a
1054 variable) when we find a let-expression:
1058 ... (let y = C a1 .. an in ...) ...
1060 where it is always good to ditch the binding for y, and replace y by
1061 x. That's just what completeLetBinding does.
1065 -- We want to ensure that all let-bound Coerces have
1066 -- atomic bodies, so they can freely be inlined.
1067 completeNonRec env binder new_id (Coerce coercion ty rhs)
1068 | not (is_atomic rhs)
1069 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1071 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1072 -- Dangerous occ because, like constructor args,
1073 -- it can be duplicated easily
1075 atomic_rhs = case lookupId env1 inner_id of
1079 completeNonRec env1 binder new_id
1080 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1082 returnSmpl (env2, binds1 ++ binds2)
1084 is_atomic (Var v) = True
1085 is_atomic (Lit l) = not (isNoRepLit l)
1086 is_atomic other = False
1088 -- Atomic right-hand sides.
1089 -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
1090 -- than it's worth. For a top-level binding a = b, where a is exported,
1091 -- we can't drop the binding, so we get repeated AtomicRhs ticks
1092 completeNonRec env binder new_id rhs@(Var v)
1093 = returnSmpl (extendIdEnvWithAtom env binder (VarArg v), [NonRec new_id rhs])
1095 completeNonRec env binder new_id rhs@(Lit lit)
1096 | not (isNoRepLit lit)
1097 = returnSmpl (extendIdEnvWithAtom env binder (LitArg lit), [NonRec new_id rhs])
1099 -- Right hand sides that are constructors
1102 --- ...(let w = C same-args in ...)...
1103 -- Then use v instead of w. This may save
1104 -- re-constructing an existing constructor.
1105 completeNonRec env binder new_id rhs@(Con con con_args)
1106 | switchIsSet env SimplReuseCon &&
1107 maybeToBool maybe_existing_con &&
1108 not (externallyVisibleId new_id) -- Don't bother for exported things
1109 -- because we won't be able to drop
1111 = tick ConReused `thenSmpl_`
1112 returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
1114 maybe_existing_con = lookForConstructor env con con_args
1115 Just it = maybe_existing_con
1118 completeNonRec env binder@(id,occ_info) new_id rhs
1119 = returnSmpl (new_env, [NonRec new_id rhs])
1121 env1 = extendIdEnvWithClone env binder new_id
1122 new_env = extendEnvGivenBinding env1 occ_info new_id rhs
1125 %************************************************************************
1127 \subsection[Simplify-atoms]{Simplifying atoms}
1129 %************************************************************************
1132 simplArg :: SimplEnv -> InArg -> OutArg
1134 simplArg env (LitArg lit) = LitArg lit
1135 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1136 simplArg env (VarArg id) = lookupId env id
1139 %************************************************************************
1141 \subsection[Simplify-quickies]{Some local help functions}
1143 %************************************************************************
1147 -- fix_up_demandedness switches off the willBeDemanded Info field
1148 -- for bindings floated out of a non-demanded let
1149 fix_up_demandedness True {- Will be demanded -} bind
1150 = bind -- Simple; no change to demand info needed
1151 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1152 = NonRec (un_demandify binder) rhs
1153 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1154 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1156 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1158 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1159 is_cheap_prim_app other = False
1161 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1162 computeResultType env expr args
1165 expr_ty = coreExprType (unTagBinders expr)
1166 expr_ty' = simplTy env expr_ty
1169 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1170 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1171 Just (_, res_ty) -> go res_ty args
1172 Nothing -> panic "computeResultType"