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, addIdArity,
25 getIdDemandInfo, addIdDemandInfo,
26 GenId{-instance NamedThing-}
28 import Name ( isExported )
29 import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
30 atLeastArity, unknownArity )
31 import Literal ( isNoRepLit )
32 import Maybes ( maybeToBool )
33 --import Name ( isExported )
34 import PprStyle ( PprStyle(..) )
35 import PprType ( GenType{-instance Outputable-} )
36 import Pretty ( ppAbove )
37 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
38 import SimplCase ( simplCase, bindLargeRhs )
41 import SimplVar ( completeVar )
43 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
44 splitFunTy, getFunTy_maybe, eqTy
46 import TysWiredIn ( realWorldStateTy )
47 import Util ( isSingleton, zipEqual, zipWithEqual, panic, pprPanic, assertPanic )
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)
184 * No floating. Case floating is obviously out. Let floating is
185 theoretically OK, but dangerous because of space leaks.
186 The long-distance let-floater lifts these lets.
189 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
191 simplTopBinds env [] = returnSmpl []
193 -- Dead code is now discarded by the occurrence analyser,
195 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
196 = -- No cloning necessary at top level
197 -- Process the binding
198 simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) ->
199 completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
201 -- Process the other bindings
202 simplTopBinds new_env binds `thenSmpl` \ binds2' ->
204 -- Glue together and return ...
205 returnSmpl (binds1' ++ binds2')
207 simplTopBinds env (Rec pairs : binds)
208 = simplRecursiveGroup env ids pairs `thenSmpl` \ (bind', new_env) ->
210 -- Process the other bindings
211 simplTopBinds new_env binds `thenSmpl` \ binds' ->
213 -- Glue together and return
214 returnSmpl (bind' : binds')
216 ids = [id | (binder@(id,_), rhs) <- pairs] -- No cloning necessary at top level
219 %************************************************************************
221 \subsection[Simplify-simplExpr]{The main function: simplExpr}
223 %************************************************************************
227 simplExpr :: SimplEnv
228 -> InExpr -> [OutArg]
232 The expression returned has the same meaning as the input expression
233 applied to the specified arguments.
238 Check if there's a macro-expansion, and if so rattle on. Otherwise do
239 the more sophisticated stuff.
242 simplExpr env (Var v) args
243 = case (lookupId env v) of
244 LitArg lit -- A boring old literal
245 -> ASSERT( null args )
248 VarArg var -- More interesting! An id!
249 -> completeVar env var args
250 -- Either Id is in the local envt, or it's a global.
251 -- In either case we don't need to apply the type
252 -- environment to it.
259 simplExpr env (Lit l) [] = returnSmpl (Lit l)
261 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
265 Primitive applications are simple.
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
268 NB: Prim expects an empty argument list! (Because it should be
269 saturated and not higher-order. ADR)
272 simplExpr env (Prim op prim_args) args
275 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
278 completePrim env op' prim_args'
280 -- PrimOps just need any types in them renamed.
282 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
284 arg_tys' = map (simplTy env) arg_tys
285 result_ty' = simplTy env result_ty
287 CCallOp label is_asm may_gc arg_tys' result_ty'
289 simpl_op other_op = other_op
292 Constructor applications
293 ~~~~~~~~~~~~~~~~~~~~~~~~
294 Nothing to try here. We only reuse constructors when they appear as the
295 rhs of a let binding (see completeLetBinding).
298 simplExpr env (Con con con_args) args
299 = ASSERT( null args )
300 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
304 Applications are easy too:
305 ~~~~~~~~~~~~~~~~~~~~~~~~~~
306 Just stuff 'em in the arg stack
309 simplExpr env (App fun arg) args
310 = simplExpr env fun (simplArg env arg : args)
316 We only eta-reduce a type lambda if all type arguments in the body can
317 be eta-reduced. This requires us to collect up all tyvar parameters so
318 we can pass them all to @mkTyLamTryingEta@.
321 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
322 = -- ASSERT(not (isPrimType ty))
323 tick TyBetaReduction `thenSmpl_`
324 simplExpr (extendTyEnv env tyvar ty) body args
326 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
327 = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
329 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
331 simplExpr new_env body [] `thenSmpl` \ body' ->
332 returnSmpl (Lam (TyBinder tyvar') body')
335 simplExpr env (Lam (TyBinder _) _) (_ : _)
336 = panic "simplExpr:TyLam with non-TyArg"
344 There's a complication with lambdas that aren't saturated.
349 If we did nothing, x is used inside the \y, so would be marked
350 as dangerous to dup. But in the common case where the abstraction
351 is applied to two arguments this is over-pessimistic.
352 So instead we don't take account of the \y when dealing with x's usage;
353 instead, the simplifier is careful when partially applying lambdas.
356 simplExpr env expr@(Lam (ValBinder binder) body) orig_args
357 = go 0 env expr orig_args
359 go n env (Lam (ValBinder binder) body) (val_arg : args)
360 | isValArg val_arg -- The lambda has an argument
361 = tick BetaReduction `thenSmpl_`
362 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
364 go n env expr@(Lam (ValBinder binder) body) args
365 -- The lambda is un-saturated, so we must zap the occurrence info
366 -- on the arguments we've already beta-reduced into the body of the lambda
367 = ASSERT( null args ) -- Value lambda must match value argument!
369 new_env = markDangerousOccs env (take n orig_args)
371 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
372 `thenSmpl` \ (expr', arity) ->
375 go n env non_val_lam_expr args -- The lambda had enough arguments
376 = simplExpr env non_val_lam_expr args
384 simplExpr env (Let bind body) args
385 = simplBind env bind (\env -> simplExpr env body args)
386 (computeResultType env body args)
393 simplExpr env expr@(Case scrut alts) args
394 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
395 (computeResultType env expr args)
402 simplExpr env (Coerce coercion ty body) args
403 = simplCoerce env coercion ty body args
410 1) Eliminating nested sccs ...
411 We must be careful to maintain the scc counts ...
414 simplExpr env (SCC cc1 (SCC cc2 expr)) args
415 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
416 -- eliminate inner scc if no call counts and same cc as outer
417 = simplExpr env (SCC cc1 expr) args
419 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
420 -- eliminate outer scc if no call counts associated with either ccs
421 = simplExpr env (SCC cc2 expr) args
424 2) Moving sccs inside lambdas ...
427 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args
428 | not (isSccCountCostCentre cc)
429 -- move scc inside lambda only if no call counts
430 = simplExpr env (Lam binder (SCC cc body)) args
432 simplExpr env (SCC cc (Lam binder body)) args
433 -- always ok to move scc inside type/usage lambda
434 = simplExpr env (Lam binder (SCC cc body)) args
437 3) Eliminating dict sccs ...
440 simplExpr env (SCC cc expr) args
441 | squashableDictishCcExpr cc expr
442 -- eliminate dict cc if trivial dict expression
443 = simplExpr env expr args
446 4) Moving arguments inside the body of an scc ...
447 This moves the cost of doing the application inside the scc
448 (which may include the cost of extracting methods etc)
451 simplExpr env (SCC cost_centre body) args
453 new_env = setEnclosingCC env cost_centre
455 simplExpr new_env body args `thenSmpl` \ body' ->
456 returnSmpl (SCC cost_centre body')
459 %************************************************************************
461 \subsection{Simplify RHS of a Let/Letrec}
463 %************************************************************************
465 simplRhsExpr does arity-expansion. That is, given:
467 * a right hand side /\ tyvars -> \a1 ... an -> e
468 * the information (stored in BinderInfo) that the function will always
469 be applied to at least k arguments
471 it transforms the rhs to
473 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
475 This is a Very Good Thing!
482 -> SmplM (OutExpr, ArityInfo)
484 simplRhsExpr env binder@(id,occ_info) rhs
485 = -- Deal with the big lambda part
486 ASSERT( null uvars ) -- For now
488 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
490 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
492 -- Deal with the little lambda part
493 -- Note that we call simplLam even if there are no binders,
494 -- in case it can do arity expansion.
495 simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ (lambda', arity) ->
497 -- Put it back together
498 returnSmpl (mkTyLam tyvars' lambda', arity)
501 rhs_env | -- not (switchIsSet env IgnoreINLINEPragma) &&
502 -- No! Don't ever inline in a INLINE thing's rhs, because
503 -- doing so will inline a worker straight back into its wrapper!
504 idWantsToBeINLINEd id
505 = switchOffInlining env
509 -- Switch off all inlining in the RHS of things that have an INLINE pragma.
510 -- They are going to be inlined wherever they are used, and then all the
511 -- inlining will take effect. Meanwhile, there isn't
512 -- much point in doing anything to the as-yet-un-INLINEd rhs.
513 -- It's very important to switch off inlining! Consider:
515 -- let f = \pq -> BIG
517 -- let g = \y -> f y y
519 -- in ...g...g...g...g...g...
521 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
522 -- and thence copied multiple times when g is inlined.
524 -- Andy disagrees! Example:
525 -- all xs = foldr (&&) True xs
526 -- any p = all . map p {-# INLINE any #-}
528 -- Problem: any won't get deforested, and so if it's exported and
529 -- the importer doesn't use the inlining, (eg passes it as an arg)
530 -- then we won't get deforestation at all.
531 -- We havn't solved this problem yet!
533 (uvars, tyvars, body) = collectUsageAndTyBinders rhs
537 %************************************************************************
539 \subsection{Simplify a lambda abstraction}
541 %************************************************************************
543 Simplify (\binders -> body) trying eta expansion and reduction, given that
544 the abstraction will always be applied to at least min_no_of_args.
547 simplValLam env expr min_no_of_args
548 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
550 -- We used to disable eta expansion for thunks, but I don't see why.
551 -- null binders || -- or it's a thunk
553 null potential_extra_binder_tys || -- or ain't a function
554 no_of_extra_binders <= 0 -- or no extra binders needed
555 = cloneIds env binders `thenSmpl` \ binders' ->
557 new_env = extendIdEnvWithClones env binders binders'
559 simplExpr new_env body [] `thenSmpl` \ body' ->
560 returnSmpl (mkValLam binders' body', atLeastArity no_of_binders)
562 | otherwise -- Eta expansion possible
563 = tick EtaExpansion `thenSmpl_`
564 cloneIds env binders `thenSmpl` \ binders' ->
566 new_env = extendIdEnvWithClones env binders binders'
568 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
569 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
571 mkValLam (binders' ++ extra_binders') body',
572 atLeastArity (no_of_binders + no_of_extra_binders)
576 (binders,body) = collectValBinders expr
577 no_of_binders = length binders
578 (potential_extra_binder_tys, res_ty)
579 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
580 -- Note: it's possible that simplValLam will be applied to something
581 -- with a forall type. Eg when being applied to the rhs of
583 -- where wurble has a forall-type, but no big lambdas at the top.
584 -- We could be clever an insert new big lambdas, but we don't bother.
586 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
588 no_of_extra_binders = -- First, use the info about how many args it's
589 -- always applied to in its scope; but ignore this
590 -- if it's a thunk! To see why we ignore it for thunks,
591 -- consider let f = lookup env key in (f 1, f 2)
592 -- We'd better not eta expand f just because it is
596 else min_no_of_args - no_of_binders)
598 -- Next, try seeing if there's a lambda hidden inside
603 -- Finally, see if it's a state transformer, in which
604 -- case we eta-expand on principle! This can waste work,
605 -- but usually doesn't
607 case potential_extra_binder_tys of
608 [ty] | ty `eqTy` realWorldStateTy -> 1
614 %************************************************************************
616 \subsection[Simplify-coerce]{Coerce expressions}
618 %************************************************************************
621 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
622 simplCoerce env coercion ty expr@(Case scrut alts) args
623 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
624 (computeResultType env expr args)
626 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
627 simplCoerce env coercion ty (Let bind body) args
628 = simplBind env bind (\env -> simplCoerce env coercion ty body args)
629 (computeResultType env body args)
632 simplCoerce env coercion ty expr args
633 = simplExpr env expr [] `thenSmpl` \ expr' ->
634 returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
637 -- Try cancellation; we do this "on the way up" because
638 -- I think that's where it'll bite best
639 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
640 mkCoerce coercion ty body = Coerce coercion ty body
644 %************************************************************************
646 \subsection[Simplify-let]{Let-expressions}
648 %************************************************************************
651 simplBind :: SimplEnv
653 -> (SimplEnv -> SmplM OutExpr)
658 When floating cases out of lets, remember this:
660 let x* = case e of alts
663 where x* is sure to be demanded or e is a cheap operation that cannot
664 fail, e.g. unboxed addition. Here we should be prepared to duplicate
665 <small expr>. A good example:
674 p1 -> foldr c n (build e1)
675 p2 -> foldr c n (build e2)
677 NEW: We use the same machinery that we use for case-of-case to
678 *always* do case floating from let, that is we let bind and abstract
679 the original let body, and let the occurrence analyser later decide
680 whether the new let should be inlined or not. The example above
684 let join_body x' = foldr c n x'
686 p1 -> let x* = build e1
688 p2 -> let x* = build e2
691 note that join_body is a let-no-escape.
692 In this particular example join_body will later be inlined,
693 achieving the same effect.
694 ToDo: check this is OK with andy
699 -- Dead code is now discarded by the occurrence analyser,
701 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
702 | idWantsToBeINLINEd id
703 = complete_bind env rhs -- Don't messa bout with floating or let-to-case on
708 -- Try let-to-case; see notes below about let-to-case
709 simpl_bind env rhs | will_be_demanded &&
711 type_ok_for_let_to_case rhs_ty &&
712 not rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
713 = tick Let2Case `thenSmpl_`
714 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
715 simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty
716 -- NB: it's tidier to call complete_bind not simpl_bind, else
717 -- we nearly end up in a loop. Consider:
719 -- ==> case rhs of (p,q) -> let x=(p,q) in b
720 -- This effectively what the above simplCase call does.
721 -- Now, the inner let is a let-to-case target again! Actually, since
722 -- the RHS is in WHNF it won't happen, but it's a close thing!
725 simpl_bind env (Let bind rhs) | let_floating_ok
726 = tick LetFloatFromLet `thenSmpl_`
727 simplBind env (fix_up_demandedness will_be_demanded bind)
728 (\env -> simpl_bind env rhs) body_ty
730 -- Try case-from-let; this deals with a strict let of error too
731 simpl_bind env (Case scrut alts) | will_be_demanded ||
732 (float_primops && is_cheap_prim_app scrut)
733 = tick CaseFloatFromLet `thenSmpl_`
735 -- First, bind large let-body if necessary
736 if ok_to_dup || isSingleton (nonErrorRHSs alts)
738 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
740 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
742 body_c' = \env -> simplExpr env new_body []
743 case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
745 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
746 returnSmpl (Let extra_binding case_expr)
748 -- None of the above; simplify rhs and tidy up
749 simpl_bind env rhs = complete_bind env rhs
751 complete_bind env rhs
752 = simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) ->
753 cloneId env binder `thenSmpl` \ new_id ->
754 completeNonRec env binder
755 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
756 body_c new_env `thenSmpl` \ body' ->
757 returnSmpl (mkCoLetsAny binds body')
760 -- All this stuff is computed at the start of the simpl_bind loop
761 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
762 float_primops = switchIsSet env SimplOkToFloatPrimOps
763 ok_to_dup = switchIsSet env SimplOkToDupCode
764 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
765 try_let_to_case = switchIsSet env SimplLetToCase
766 no_float = switchIsSet env SimplNoLetFromStrictLet
768 will_be_demanded = willBeDemanded (getIdDemandInfo id)
771 rhs_is_whnf = case mkFormSummary rhs of
776 let_floating_ok = (will_be_demanded && not no_float) ||
777 always_float_let_from_let ||
778 floatExposesHNF float_lets float_primops ok_to_dup rhs
783 It's important to try let-to-case before floating. Consider
785 let a*::Int = case v of {p1->e1; p2->e2}
788 (The * means that a is sure to be demanded.)
789 If we do case-floating first we get this:
793 p1-> let a*=e1 in k a
794 p2-> let a*=e2 in k a
796 Now watch what happens if we do let-to-case first:
798 case (case v of {p1->e1; p2->e2}) of
799 Int a# -> let a*=I# a# in b
801 let k = \a# -> let a*=I# a# in b
803 p1 -> case e1 of I# a# -> k a#
804 p1 -> case e1 of I# a# -> k a#
806 The latter is clearly better. (Remember the reboxing let-decl for a
807 is likely to go away, because after all b is strict in a.)
809 We do not do let to case for WHNFs, e.g.
815 as this is less efficient. but we don't mind doing let-to-case for
816 "bottom", as that will allow us to remove more dead code, if anything:
820 case error of x -> ...
824 Notice that let to case occurs only if x is used strictly in its body
831 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
832 on and it'll expose a HNF), and bang the whole resulting mess together
835 1. Any "macros" should be expanded. The main application of this
844 Here we would like the single call to g to be inlined.
846 We can spot this easily, because g will be tagged as having just one
847 occurrence. The "inlineUnconditionally" predicate is just what we want.
849 A worry: could this lead to non-termination? For example:
858 Here, f and g call each other (just once) and neither is used elsewhere.
861 * the occurrence analyser will drop any (sub)-group that isn't used at
864 * If the group is used outside itself (ie in the "in" part), then there
867 ** IMPORTANT: check that NewOccAnal has the property that a group of
868 bindings like the above has f&g dropped.! ***
871 2. We'd also like to pull out any top-level let(rec)s from the
875 f = let h = ... in \x -> ....h...f...h...
881 f = \x -> ....h...f...h...
885 But floating cases is less easy? (Don't for now; ToDo?)
888 3. We'd like to arrange that the RHSs "know" about members of the
889 group that are bound to constructors. For example:
893 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
894 /= a b = unpack tuple a, unpack tuple b, call f
897 here, by knowing about d.Eq in f's rhs, one could get rid of
898 the case (and break out the recursion completely).
899 [This occurred with more aggressive inlining threshold (4),
900 nofib/spectral/knights]
903 1: we simplify constructor rhss first.
904 2: we record the "known constructors" in the environment
905 3: we simplify the other rhss, with the knowledge about the constructors
910 simplBind env (Rec pairs) body_c body_ty
911 = -- Do floating, if necessary
913 floated_pairs | do_floating = float_pairs pairs
916 ticks | do_floating = length floated_pairs - length pairs
919 binders = map fst floated_pairs
921 tickN LetFloatFromLet ticks `thenSmpl_`
922 -- It's important to increment the tick counts if we
923 -- do any floating. A situation where this turns out
924 -- to be important is this:
925 -- Float in produces:
926 -- letrec x = let y = Ey in Ex
928 -- Now floating gives this:
932 --- We now want to iterate once more in case Ey doesn't
933 -- mention x, in which case the y binding can be pulled
934 -- out as an enclosing let(rec), which in turn gives
935 -- the strictness analyser more chance.
937 cloneIds env binders `thenSmpl` \ ids' ->
939 env_w_clones = extendIdEnvWithClones env binders ids'
941 simplRecursiveGroup env_w_clones ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
943 body_c new_env `thenSmpl` \ body' ->
945 returnSmpl (Let binding body')
948 ------------ Floating stuff -------------------
950 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
951 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
952 do_floating = float_lets || always_float_let_from_let
954 float_pairs pairs = concat (map float_pair pairs)
956 float_pair (binder, rhs)
957 | always_float_let_from_let ||
958 floatExposesHNF True False False rhs
959 = (binder,rhs') : pairs'
964 (pairs', rhs') = do_float rhs
966 -- Float just pulls out any top-level let(rec) bindings
967 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
968 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
970 (pairs', body') = do_float body
971 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
973 (pairs', body') = do_float body
974 do_float other = ([], other)
977 -- The env passed to simplRecursiveGroup already has
978 -- bindings that clone the variables of the group.
979 simplRecursiveGroup env new_ids pairs
980 = -- Add unfoldings to the new_ids corresponding to their RHS
982 binders = map fst pairs
983 occs = map snd binders
984 new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
985 rhs_env = foldl extendEnvForRecBinding
989 mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss_w_arities ->
992 new_pairs = zipWithEqual "simplRecGp" mk_new_pair new_ids new_rhss_w_arities
993 mk_new_pair id (rhs,arity) = (id `withArity` arity, rhs)
994 -- NB: the new arity isn't used when processing its own
995 -- right hand sides, nor in the subsequent code
996 -- The latter is something of a pity, and not hard to fix; but
997 -- the info will percolate on the next iteration anyway
999 {- THE NEXT FEW LINES ARE PLAIN WRONG
1000 occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
1001 new_env = foldl add_binding env occs_w_new_pairs
1003 add_binding env (occ_info,(new_id,new_rhs))
1004 = extendEnvGivenBinding env occ_info new_id new_rhs
1006 Here's why it's wrong: consider
1007 let f x = ...f x'...
1011 If the RHS is small we'll inline f in the body of the let, then
1012 again, then again...URK
1015 returnSmpl (Rec new_pairs, rhs_env)
1019 @completeLet@ looks at the simplified post-floating RHS of the
1020 let-expression, and decides what to do. There's one interesting
1021 aspect to this, namely constructor reuse. Consider
1027 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1028 bit on the compiler technology, but in general I believe not. For
1029 example, here's some code from a real program:
1031 const.Int.max.wrk{-s2516-} =
1032 \ upk.s3297# upk.s3298# ->
1036 a.s3299 = I#! upk.s3297#
1038 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1039 _LT -> I#! upk.s3298#
1044 The a.s3299 really isn't doing much good. We'd be better off inlining
1045 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1047 So the current strategy is to inline all known-form constructors, and
1048 only do the reverse (turn a constructor application back into a
1049 variable) when we find a let-expression:
1053 ... (let y = C a1 .. an in ...) ...
1055 where it is always good to ditch the binding for y, and replace y by
1056 x. That's just what completeLetBinding does.
1060 -- We want to ensure that all let-bound Coerces have
1061 -- atomic bodies, so they can freely be inlined.
1062 completeNonRec env binder new_id (Coerce coercion ty rhs)
1063 | not (is_atomic rhs)
1064 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1066 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1067 -- Dangerous occ because, like constructor args,
1068 -- it can be duplicated easily
1070 atomic_rhs = case lookupId env1 inner_id of
1074 completeNonRec env1 binder new_id
1075 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1077 returnSmpl (env2, binds1 ++ binds2)
1079 -- Right hand sides that are constructors
1082 --- ...(let w = C same-args in ...)...
1083 -- Then use v instead of w. This may save
1084 -- re-constructing an existing constructor.
1085 completeNonRec env binder new_id rhs@(Con con con_args)
1086 | switchIsSet env SimplReuseCon &&
1087 maybeToBool maybe_existing_con &&
1088 not (isExported new_id) -- Don't bother for exported things
1089 -- because we won't be able to drop
1091 = tick ConReused `thenSmpl_`
1092 returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
1094 maybe_existing_con = lookForConstructor env con con_args
1095 Just it = maybe_existing_con
1099 -- Check for atomic right-hand sides.
1100 -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
1101 -- than it's worth. For a top-level binding a = b, where a is exported,
1102 -- we can't drop the binding, so we get repeated AtomicRhs ticks
1103 completeNonRec env binder@(id,occ_info) new_id new_rhs
1104 = returnSmpl (new_env , [NonRec new_id new_rhs])
1106 new_env | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1107 = extendIdEnvWithAtom env binder the_arg
1109 | otherwise -- Non-atomic
1110 = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
1111 occ_info new_id new_rhs -- Don't eta if it doesn't eliminate the binding
1113 eta'd_rhs = etaCoreExpr new_rhs
1114 the_arg = case eta'd_rhs of
1119 %************************************************************************
1121 \subsection[Simplify-atoms]{Simplifying atoms}
1123 %************************************************************************
1126 simplArg :: SimplEnv -> InArg -> OutArg
1128 simplArg env (LitArg lit) = LitArg lit
1129 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1130 simplArg env (VarArg id) = lookupId env id
1133 %************************************************************************
1135 \subsection[Simplify-quickies]{Some local help functions}
1137 %************************************************************************
1141 -- fix_up_demandedness switches off the willBeDemanded Info field
1142 -- for bindings floated out of a non-demanded let
1143 fix_up_demandedness True {- Will be demanded -} bind
1144 = bind -- Simple; no change to demand info needed
1145 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1146 = NonRec (un_demandify binder) rhs
1147 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1148 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1150 un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1152 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1153 is_cheap_prim_app other = False
1155 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1156 computeResultType env expr args
1159 expr_ty = coreExprType (unTagBinders expr)
1160 expr_ty' = simplTy env expr_ty
1163 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1164 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1165 Just (_, res_ty) -> go res_ty args
1166 Nothing -> panic "computeResultType"
1168 var `withArity` UnknownArity = var
1169 var `withArity` arity = var `addIdArity` arity
1171 is_atomic (Var v) = True
1172 is_atomic (Lit l) = not (isNoRepLit l)
1173 is_atomic other = False