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,
25 getIdDemandInfo, addIdDemandInfo,
26 GenId{-instance NamedThing-}
28 import IdInfo ( willBeDemanded, DemandInfo )
29 import Literal ( isNoRepLit )
30 import Maybes ( maybeToBool )
31 import Name ( isLocallyDefined )
32 import PprStyle ( PprStyle(..) )
33 import PprType ( GenType{-instance Outputable-} )
34 import Pretty ( ppAbove )
35 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
36 import SimplCase ( simplCase, bindLargeRhs )
39 import SimplVar ( completeVar )
41 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
42 splitFunTy, getFunTy_maybe, eqTy
44 import TysWiredIn ( realWorldStateTy )
45 import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
48 The controlling flags, and what they do
49 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
53 -fsimplify = run the simplifier
54 -ffloat-inwards = runs the float lets inwards pass
55 -ffloat = runs the full laziness pass
56 (ToDo: rename to -ffull-laziness)
57 -fupdate-analysis = runs update analyser
58 -fstrictness = runs strictness analyser
59 -fsaturate-apps = saturates applications (eta expansion)
63 -ffloat-past-lambda = OK to do full laziness.
64 (ToDo: remove, as the full laziness pass is
65 useless without this flag, therefore
66 it is unnecessary. Just -ffull-laziness
69 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
70 let is strict or if the floating will expose
73 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
74 is a primop that cannot fail [simplifier].
76 -fcode-duplication-ok = allows the previous option to work on cases with
77 multiple branches [simplifier].
79 -flet-to-case = does let-to-case transformation [simplifier].
81 -fcase-of-case = does case of case transformation [simplifier].
83 -fpedantic-bottoms = does not allow:
84 case x of y -> e ===> e[x/y]
85 (which may turn bottom into non-bottom)
91 Inlining is one of the delicate aspects of the simplifier. By
92 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
93 the RHS of x's definition. Thus
95 let x = e in ...x... ===> let x = e in ...e...
97 We have two mechanisms for inlining:
99 1. Unconditional. The occurrence analyser has pinned an (OneOcc
100 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
101 certainly safe to inline this variable, and to drop its binding''.
102 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
103 happy to be duplicating code...) When it encounters such a beast, the
104 simplifer binds the variable to its RHS (in the id_env) and continues.
105 It doesn't even look at the RHS at that stage. It also drops the
108 2. Conditional. In all other situations, the simplifer simplifies
109 the RHS anyway, and keeps the new binding. It also binds the new
110 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
112 Here, ``suitable'' might mean NoUnfolding (if the occurrence
113 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
114 the variable has an INLINE pragma on it). The idea is that anything
115 in the UnfoldEnv is safe to use, but also has an enclosing binding if
116 you decide not to use it.
120 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
123 At one time I thought it would be OK to put non-HNF unfoldings in for
124 variables which occur only once [if they got inlined at that
125 occurrence the RHS of the binding would become dead, so no duplication
126 would occur]. But consider:
129 f = \y -> ...y...y...y...
132 Now, it seems that @x@ appears only once, but even so it is NOT safe
133 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
134 duplicate the references to @x@.
136 Because of this, the "unconditional-inline" mechanism above is the
137 only way in which non-HNFs can get inlined.
142 When a variable has an INLINE pragma on it --- which includes wrappers
143 produced by the strictness analyser --- we treat it rather carefully.
145 For a start, we are careful not to substitute into its RHS, because
146 that might make it BIG, and the user said "inline exactly this", not
147 "inline whatever you get after inlining other stuff inside me". For
151 in {-# INLINE y #-} y = f 3
154 Here we don't want to substitute BIG for the (single) occurrence of f,
155 because then we'd duplicate BIG when we inline'd y. (Exception:
156 things in the UnfoldEnv with UnfoldAlways flags, which originated in
157 other INLINE pragmas.)
159 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
160 going into such an RHS.
162 What about imports? They don't really matter much because we only
163 inline relatively small things via imports.
165 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
166 INLINE pragma. We also do this for the RHSs of recursive decls,
167 before looking at the recursive decls. That way we achieve the effect
168 of inlining a wrapper in the body of its worker, in the case of a
169 mutually-recursive worker/wrapper split.
172 %************************************************************************
174 \subsection[Simplify-simplExpr]{The main function: simplExpr}
176 %************************************************************************
178 At the top level things are a little different.
180 * No cloning (not allowed for exported Ids, unnecessary for the others)
182 * No floating. Case floating is obviously out. Let floating is
183 theoretically OK, but dangerous because of space leaks.
184 The long-distance let-floater lifts these lets.
187 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
189 simplTopBinds env [] = returnSmpl []
191 -- Dead code is now discarded by the occurrence analyser,
193 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
194 = -- No cloning necessary at top level
195 -- Process the binding
196 simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
197 completeNonRec True env binder rhs' `thenSmpl` \ (new_env, binds1') ->
199 -- Process the other bindings
200 simplTopBinds new_env binds `thenSmpl` \ binds2' ->
202 -- Glue together and return ...
203 returnSmpl (binds1' ++ binds2')
205 simplTopBinds env (Rec pairs : binds)
206 = simplRecursiveGroup env ids pairs `thenSmpl` \ (bind', new_env) ->
208 -- Process the other bindings
209 simplTopBinds new_env binds `thenSmpl` \ binds' ->
211 -- Glue together and return
212 returnSmpl (bind' : binds')
214 ids = [id | (binder@(id,_), rhs) <- pairs] -- No cloning necessary at top level
217 %************************************************************************
219 \subsection[Simplify-simplExpr]{The main function: simplExpr}
221 %************************************************************************
225 simplExpr :: SimplEnv
226 -> InExpr -> [OutArg]
230 The expression returned has the same meaning as the input expression
231 applied to the specified arguments.
236 Check if there's a macro-expansion, and if so rattle on. Otherwise do
237 the more sophisticated stuff.
240 simplExpr env (Var v) args
241 = case (lookupId env v) of
242 LitArg lit -- A boring old literal
243 -> ASSERT( null args )
246 VarArg var -- More interesting! An id!
247 -> completeVar env var args
248 -- Either Id is in the local envt, or it's a global.
249 -- In either case we don't need to apply the type
250 -- environment to it.
257 simplExpr env (Lit l) [] = returnSmpl (Lit l)
259 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
263 Primitive applications are simple.
264 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
266 NB: Prim expects an empty argument list! (Because it should be
267 saturated and not higher-order. ADR)
270 simplExpr env (Prim op prim_args) args
273 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
276 completePrim env op' prim_args'
278 -- PrimOps just need any types in them renamed.
280 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
282 arg_tys' = map (simplTy env) arg_tys
283 result_ty' = simplTy env result_ty
285 CCallOp label is_asm may_gc arg_tys' result_ty'
287 simpl_op other_op = other_op
290 Constructor applications
291 ~~~~~~~~~~~~~~~~~~~~~~~~
292 Nothing to try here. We only reuse constructors when they appear as the
293 rhs of a let binding (see completeLetBinding).
296 simplExpr env (Con con con_args) args
297 = ASSERT( null args )
298 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
302 Applications are easy too:
303 ~~~~~~~~~~~~~~~~~~~~~~~~~~
304 Just stuff 'em in the arg stack
307 simplExpr env (App fun arg) args
308 = simplExpr env fun (simplArg env arg : args)
314 We only eta-reduce a type lambda if all type arguments in the body can
315 be eta-reduced. This requires us to collect up all tyvar parameters so
316 we can pass them all to @mkTyLamTryingEta@.
319 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
320 = -- ASSERT(not (isPrimType ty))
321 tick TyBetaReduction `thenSmpl_`
322 simplExpr (extendTyEnv env tyvar ty) body args
324 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
325 = do_tylambdas env [] tylam
327 do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
328 = -- Clone the type variable
329 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
331 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
333 do_tylambdas new_env (tyvar':tyvars') body
335 do_tylambdas env tyvars' body
336 = simplExpr env body [] `thenSmpl` \ body' ->
338 (if switchIsSet env SimplDoEtaReduction
339 then mkTyLamTryingEta
340 else mkTyLam) (reverse tyvars') body'
344 simplExpr env (Lam (TyBinder _) _) (_ : _)
345 = panic "simplExpr:TyLam with non-TyArg"
353 There's a complication with lambdas that aren't saturated.
358 If we did nothing, x is used inside the \y, so would be marked
359 as dangerous to dup. But in the common case where the abstraction
360 is applied to two arguments this is over-pessimistic.
361 So instead we don't take account of the \y when dealing with x's usage;
362 instead, the simplifier is careful when partially applying lambdas.
365 simplExpr env expr@(Lam (ValBinder binder) body) orig_args
366 = go 0 env expr orig_args
368 go n env (Lam (ValBinder binder) body) (val_arg : args)
369 | isValArg val_arg -- The lambda has an argument
370 = tick BetaReduction `thenSmpl_`
371 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
373 go n env expr@(Lam (ValBinder binder) body) args
374 -- The lambda is un-saturated, so we must zap the occurrence info
375 -- on the arguments we've already beta-reduced into the body of the lambda
376 = ASSERT( null args ) -- Value lambda must match value argument!
378 new_env = markDangerousOccs env (take n orig_args)
380 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
382 go n env non_val_lam_expr args -- The lambda had enough arguments
383 = simplExpr env non_val_lam_expr args
391 simplExpr env (Let bind body) args
392 = simplBind env bind (\env -> simplExpr env body args)
393 (computeResultType env body args)
400 simplExpr env expr@(Case scrut alts) args
401 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
402 (computeResultType env expr args)
409 simplExpr env (Coerce coercion ty body) args
410 = simplCoerce env coercion ty body args
417 1) Eliminating nested sccs ...
418 We must be careful to maintain the scc counts ...
421 simplExpr env (SCC cc1 (SCC cc2 expr)) args
422 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
423 -- eliminate inner scc if no call counts and same cc as outer
424 = simplExpr env (SCC cc1 expr) args
426 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
427 -- eliminate outer scc if no call counts associated with either ccs
428 = simplExpr env (SCC cc2 expr) args
431 2) Moving sccs inside lambdas ...
434 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args
435 | not (isSccCountCostCentre cc)
436 -- move scc inside lambda only if no call counts
437 = simplExpr env (Lam binder (SCC cc body)) args
439 simplExpr env (SCC cc (Lam binder body)) args
440 -- always ok to move scc inside type/usage lambda
441 = simplExpr env (Lam binder (SCC cc body)) args
444 3) Eliminating dict sccs ...
447 simplExpr env (SCC cc expr) args
448 | squashableDictishCcExpr cc expr
449 -- eliminate dict cc if trivial dict expression
450 = simplExpr env expr args
453 4) Moving arguments inside the body of an scc ...
454 This moves the cost of doing the application inside the scc
455 (which may include the cost of extracting methods etc)
458 simplExpr env (SCC cost_centre body) args
460 new_env = setEnclosingCC env cost_centre
462 simplExpr new_env body args `thenSmpl` \ body' ->
463 returnSmpl (SCC cost_centre body')
466 %************************************************************************
468 \subsection{Simplify RHS of a Let/Letrec}
470 %************************************************************************
472 simplRhsExpr does arity-expansion. That is, given:
474 * a right hand side /\ tyvars -> \a1 ... an -> e
475 * the information (stored in BinderInfo) that the function will always
476 be applied to at least k arguments
478 it transforms the rhs to
480 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
482 This is a Very Good Thing!
491 simplRhsExpr env binder@(id,occ_info) rhs
492 | dont_eta_expand rhs
493 = simplExpr rhs_env rhs []
495 | otherwise -- Have a go at eta expansion
496 = -- Deal with the big lambda part
497 ASSERT( null uvars ) -- For now
499 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
501 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
503 -- Deal with the little lambda part
504 -- Note that we call simplLam even if there are no binders,
505 -- in case it can do arity expansion.
506 simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ lambda' ->
508 -- Put it back together
510 (if switchIsSet env SimplDoEtaReduction
511 then mkTyLamTryingEta
512 else mkTyLam) tyvars' lambda'
516 rhs_env | not (switchIsSet env IgnoreINLINEPragma) &&
517 idWantsToBeINLINEd id
518 = switchOffInlining env
522 -- Switch off all inlining in the RHS of things that have an INLINE pragma.
523 -- They are going to be inlined wherever they are used, and then all the
524 -- inlining will take effect. Meanwhile, there isn't
525 -- much point in doing anything to the as-yet-un-INLINEd rhs.
526 -- It's very important to switch off inlining! Consider:
528 -- let f = \pq -> BIG
530 -- let g = \y -> f y y
532 -- in ...g...g...g...g...g...
534 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
535 -- and thence copied multiple times when g is inlined.
537 -- Andy disagrees! Example:
538 -- all xs = foldr (&&) True xs
539 -- any p = all . map p {-# INLINE any #-}
541 -- Problem: any won't get deforested, and so if it's exported and
542 -- the importer doesn't use the inlining, (eg passes it as an arg)
543 -- then we won't get deforestation at all.
544 -- We havn't solved this problem yet!
546 (uvars, tyvars, body) = collectUsageAndTyBinders rhs
548 -- dont_eta_expand prevents eta expansion in silly situations.
549 -- For example, consider the defn
551 -- It would be silly to eta expand the "y", because it would just
552 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
553 -- and x was exported, then the defn won't be eliminated, so this
554 -- silly expand/reduce cycle will happen every time, which makes the
556 -- The solution is to not even try eta expansion unless the rhs looks
558 dont_eta_expand (Lit _) = True
559 dont_eta_expand (Var _) = True
560 dont_eta_expand (Con _ _) = True
561 dont_eta_expand (App f a)
562 | notValArg a = dont_eta_expand f
563 dont_eta_expand (Lam x b)
564 | notValBinder x = dont_eta_expand b
565 dont_eta_expand _ = False
569 %************************************************************************
571 \subsection{Simplify a lambda abstraction}
573 %************************************************************************
575 Simplify (\binders -> body) trying eta expansion and reduction, given that
576 the abstraction will always be applied to at least min_no_of_args.
579 simplValLam env expr min_no_of_args
580 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
581 null binders || -- or it's a thunk
582 null potential_extra_binder_tys || -- or ain't a function
583 no_of_extra_binders <= 0 -- or no extra binders needed
584 = cloneIds env binders `thenSmpl` \ binders' ->
586 new_env = extendIdEnvWithClones env binders binders'
588 simplExpr new_env body [] `thenSmpl` \ body' ->
590 (if switchIsSet new_env SimplDoEtaReduction
591 then mkValLamTryingEta
592 else mkValLam) binders' body'
595 | otherwise -- Eta expansion possible
596 = tick EtaExpansion `thenSmpl_`
597 cloneIds env binders `thenSmpl` \ binders' ->
599 new_env = extendIdEnvWithClones env binders binders'
601 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
602 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
604 (if switchIsSet new_env SimplDoEtaReduction
605 then mkValLamTryingEta
606 else mkValLam) (binders' ++ extra_binders') body'
610 (binders,body) = collectValBinders expr
611 (potential_extra_binder_tys, res_ty)
612 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
613 -- Note: it's possible that simplValLam will be applied to something
614 -- with a forall type. Eg when being applied to the rhs of
616 -- where wurble has a forall-type, but no big lambdas at the top.
617 -- We could be clever an insert new big lambdas, but we don't bother.
619 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
621 no_of_extra_binders = -- First, use the info about how many args it's
622 -- always applied to in its scope
623 (min_no_of_args - length binders)
625 -- Next, try seeing if there's a lambda hidden inside
630 -- Finally, see if it's a state transformer, in which
631 -- case we eta-expand on principle! This can waste work,
632 -- but usually doesn't
634 case potential_extra_binder_tys of
635 [ty] | ty `eqTy` realWorldStateTy -> 1
642 %************************************************************************
644 \subsection[Simplify-coerce]{Coerce expressions}
646 %************************************************************************
649 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
650 simplCoerce env coercion ty expr@(Case scrut alts) args
651 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
652 (computeResultType env expr args)
654 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
655 simplCoerce env coercion ty (Let bind body) args
656 = simplBind env bind (\env -> simplCoerce env coercion ty body args)
657 (computeResultType env body args)
660 simplCoerce env coercion ty expr args
661 = simplExpr env expr [] `thenSmpl` \ expr' ->
662 returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
665 -- Try cancellation; we do this "on the way up" because
666 -- I think that's where it'll bite best
667 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
668 mkCoerce coercion ty body = Coerce coercion ty body
672 %************************************************************************
674 \subsection[Simplify-let]{Let-expressions}
676 %************************************************************************
679 simplBind :: SimplEnv
681 -> (SimplEnv -> SmplM OutExpr)
686 When floating cases out of lets, remember this:
688 let x* = case e of alts
691 where x* is sure to be demanded or e is a cheap operation that cannot
692 fail, e.g. unboxed addition. Here we should be prepared to duplicate
693 <small expr>. A good example:
702 p1 -> foldr c n (build e1)
703 p2 -> foldr c n (build e2)
705 NEW: We use the same machinery that we use for case-of-case to
706 *always* do case floating from let, that is we let bind and abstract
707 the original let body, and let the occurrence analyser later decide
708 whether the new let should be inlined or not. The example above
712 let join_body x' = foldr c n x'
714 p1 -> let x* = build e1
716 p2 -> let x* = build e2
719 note that join_body is a let-no-escape.
720 In this particular example join_body will later be inlined,
721 achieving the same effect.
722 ToDo: check this is OK with andy
727 -- Dead code is now discarded by the occurrence analyser,
729 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
732 -- Try let-to-case; see notes below about let-to-case
733 simpl_bind env rhs | will_be_demanded &&
735 type_ok_for_let_to_case rhs_ty &&
736 not rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
737 = tick Let2Case `thenSmpl_`
738 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
739 simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty
740 -- NB: it's tidier to call complete_bind not simpl_bind, else
741 -- we nearly end up in a loop. Consider:
743 -- ==> case rhs of (p,q) -> let x=(p,q) in b
744 -- This effectively what the above simplCase call does.
745 -- Now, the inner let is a let-to-case target again! Actually, since
746 -- the RHS is in WHNF it won't happen, but it's a close thing!
749 simpl_bind env (Let bind rhs) | let_floating_ok
750 = tick LetFloatFromLet `thenSmpl_`
751 simplBind env (fix_up_demandedness will_be_demanded bind)
752 (\env -> simpl_bind env rhs) body_ty
754 -- Try case-from-let; this deals with a strict let of error too
755 simpl_bind env (Case scrut alts) | will_be_demanded ||
756 (float_primops && is_cheap_prim_app scrut)
757 = tick CaseFloatFromLet `thenSmpl_`
759 -- First, bind large let-body if necessary
760 if ok_to_dup || isSingleton (nonErrorRHSs alts)
762 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
764 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
766 body_c' = \env -> simplExpr env new_body []
767 case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
769 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
770 returnSmpl (Let extra_binding case_expr)
772 -- None of the above; simplify rhs and tidy up
773 simpl_bind env rhs = complete_bind env rhs
775 complete_bind env rhs
776 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
777 completeNonRec False env binder rhs' `thenSmpl` \ (new_env, binds) ->
778 body_c new_env `thenSmpl` \ body' ->
779 returnSmpl (mkCoLetsAny binds body')
782 -- All this stuff is computed at the start of the simpl_bind loop
783 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
784 float_primops = switchIsSet env SimplOkToFloatPrimOps
785 ok_to_dup = switchIsSet env SimplOkToDupCode
786 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
787 try_let_to_case = switchIsSet env SimplLetToCase
788 no_float = switchIsSet env SimplNoLetFromStrictLet
790 will_be_demanded = willBeDemanded (getIdDemandInfo id)
793 rhs_is_whnf = case mkFormSummary rhs of
798 let_floating_ok = (will_be_demanded && not no_float) ||
799 always_float_let_from_let ||
800 floatExposesHNF float_lets float_primops ok_to_dup rhs
805 It's important to try let-to-case before floating. Consider
807 let a*::Int = case v of {p1->e1; p2->e2}
810 (The * means that a is sure to be demanded.)
811 If we do case-floating first we get this:
815 p1-> let a*=e1 in k a
816 p2-> let a*=e2 in k a
818 Now watch what happens if we do let-to-case first:
820 case (case v of {p1->e1; p2->e2}) of
821 Int a# -> let a*=I# a# in b
823 let k = \a# -> let a*=I# a# in b
825 p1 -> case e1 of I# a# -> k a#
826 p1 -> case e1 of I# a# -> k a#
828 The latter is clearly better. (Remember the reboxing let-decl for a
829 is likely to go away, because after all b is strict in a.)
831 We do not do let to case for WHNFs, e.g.
837 as this is less efficient. but we don't mind doing let-to-case for
838 "bottom", as that will allow us to remove more dead code, if anything:
842 case error of x -> ...
846 Notice that let to case occurs only if x is used strictly in its body
853 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
854 on and it'll expose a HNF), and bang the whole resulting mess together
857 1. Any "macros" should be expanded. The main application of this
866 Here we would like the single call to g to be inlined.
868 We can spot this easily, because g will be tagged as having just one
869 occurrence. The "inlineUnconditionally" predicate is just what we want.
871 A worry: could this lead to non-termination? For example:
880 Here, f and g call each other (just once) and neither is used elsewhere.
883 * the occurrence analyser will drop any (sub)-group that isn't used at
886 * If the group is used outside itself (ie in the "in" part), then there
889 ** IMPORTANT: check that NewOccAnal has the property that a group of
890 bindings like the above has f&g dropped.! ***
893 2. We'd also like to pull out any top-level let(rec)s from the
897 f = let h = ... in \x -> ....h...f...h...
903 f = \x -> ....h...f...h...
907 But floating cases is less easy? (Don't for now; ToDo?)
910 3. We'd like to arrange that the RHSs "know" about members of the
911 group that are bound to constructors. For example:
915 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
916 /= a b = unpack tuple a, unpack tuple b, call f
919 here, by knowing about d.Eq in f's rhs, one could get rid of
920 the case (and break out the recursion completely).
921 [This occurred with more aggressive inlining threshold (4),
922 nofib/spectral/knights]
925 1: we simplify constructor rhss first.
926 2: we record the "known constructors" in the environment
927 3: we simplify the other rhss, with the knowledge about the constructors
932 simplBind env (Rec pairs) body_c body_ty
933 = -- Do floating, if necessary
935 floated_pairs | do_floating = float_pairs pairs
938 ticks | do_floating = length floated_pairs - length pairs
941 binders = map fst floated_pairs
943 tickN LetFloatFromLet ticks `thenSmpl_`
944 -- It's important to increment the tick counts if we
945 -- do any floating. A situation where this turns out
946 -- to be important is this:
947 -- Float in produces:
948 -- letrec x = let y = Ey in Ex
950 -- Now floating gives this:
954 --- We now want to iterate once more in case Ey doesn't
955 -- mention x, in which case the y binding can be pulled
956 -- out as an enclosing let(rec), which in turn gives
957 -- the strictness analyser more chance.
959 cloneIds env binders `thenSmpl` \ ids' ->
961 env_w_clones = extendIdEnvWithClones env binders ids'
963 simplRecursiveGroup env_w_clones ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
965 body_c new_env `thenSmpl` \ body' ->
967 returnSmpl (Let binding body')
970 ------------ Floating stuff -------------------
972 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
973 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
974 do_floating = float_lets || always_float_let_from_let
976 float_pairs pairs = concat (map float_pair pairs)
978 float_pair (binder, rhs)
979 | always_float_let_from_let ||
980 floatExposesHNF True False False rhs
981 = (binder,rhs') : pairs'
986 (pairs', rhs') = do_float rhs
988 -- Float just pulls out any top-level let(rec) bindings
989 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
990 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
992 (pairs', body') = do_float body
993 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
995 (pairs', body') = do_float body
996 do_float other = ([], other)
998 simplRecursiveGroup env new_ids pairs
999 = -- Add unfoldings to the new_ids corresponding to their RHS
1001 binders = map fst pairs
1002 occs = map snd binders
1003 new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
1004 rhs_env = foldl extendEnvForRecBinding
1008 mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss ->
1011 new_pairs = zipEqual "simplRecGp" new_ids new_rhss
1012 occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
1013 new_env = foldl add_binding env occs_w_new_pairs
1015 add_binding env (occ_info,(new_id,new_rhs))
1016 = extendEnvGivenBinding env occ_info new_id new_rhs
1018 returnSmpl (Rec new_pairs, new_env)
1022 @completeLet@ looks at the simplified post-floating RHS of the
1023 let-expression, and decides what to do. There's one interesting
1024 aspect to this, namely constructor reuse. Consider
1030 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1031 bit on the compiler technology, but in general I believe not. For
1032 example, here's some code from a real program:
1034 const.Int.max.wrk{-s2516-} =
1035 \ upk.s3297# upk.s3298# ->
1039 a.s3299 = I#! upk.s3297#
1041 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1042 _LT -> I#! upk.s3298#
1047 The a.s3299 really isn't doing much good. We'd be better off inlining
1048 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1050 So the current strategy is to inline all known-form constructors, and
1051 only do the reverse (turn a constructor application back into a
1052 variable) when we find a let-expression:
1056 ... (let y = C a1 .. an in ...) ...
1058 where it is always good to ditch the binding for y, and replace y by
1059 x. That's just what completeLetBinding does.
1063 -- Sigh: rather disgusting case for coercions. We want to
1064 -- ensure that all let-bound Coerces have atomic bodies, so
1065 -- they can freely be inlined.
1066 completeNonRec top_level env binder@(_,occ_info) (Coerce coercion ty rhs)
1068 Var v -> returnSmpl (env, [], rhs)
1069 Lit l -> returnSmpl (env, [], rhs)
1070 other -> newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1071 completeNonRec top_level env
1072 (inner_id, dangerousArgOcc) rhs `thenSmpl` \ (env1, extra_bind) ->
1073 -- Dangerous occ because, like constructor args,
1074 -- it can be duplicated easily
1076 atomic_rhs = case lookupId env1 inner_id of
1080 returnSmpl (env1, extra_bind, atomic_rhs)
1081 ) `thenSmpl` \ (env1, extra_bind, atomic_rhs) ->
1082 -- Tiresome to do all this, but we must treat the lit/var cases specially
1083 -- or we get a tick for atomic rhs when effectively it's a no-op.
1085 cloneId env1 binder `thenSmpl` \ new_id ->
1087 new_rhs = Coerce coercion ty atomic_rhs
1088 env2 = extendIdEnvWithClone env1 binder new_id
1089 new_env = extendEnvGivenBinding env2 occ_info new_id new_rhs
1091 returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs])
1093 completeNonRec top_level env binder@(id,_) new_rhs
1094 -- See if RHS is an atom, or a reusable constructor
1095 | maybeToBool maybe_atomic_rhs
1097 new_env = extendIdEnvWithAtom env binder rhs_atom
1098 result_binds | top_level = [NonRec id new_rhs] -- Don't discard top-level bindings
1099 -- (they'll be dropped later if not
1100 -- exported and dead)
1103 tick atom_tick_type `thenSmpl_`
1104 returnSmpl (new_env, result_binds)
1106 maybe_atomic_rhs = exprToAtom env new_rhs
1107 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1109 completeNonRec top_level env binder@(old_id,occ_info) new_rhs
1110 = (if top_level then
1111 returnSmpl old_id -- Only clone local binders
1114 ) `thenSmpl` \ new_id ->
1116 env1 = extendIdEnvWithClone env binder new_id
1117 new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs
1119 returnSmpl (new_env, [NonRec new_id new_rhs])
1122 %************************************************************************
1124 \subsection[Simplify-atoms]{Simplifying atoms}
1126 %************************************************************************
1129 simplArg :: SimplEnv -> InArg -> OutArg
1131 simplArg env (LitArg lit) = LitArg lit
1132 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1133 simplArg env (VarArg id) = lookupId env id
1138 exprToAtom env (Var var)
1139 = Just (VarArg var, AtomicRhs)
1141 exprToAtom env (Lit lit)
1142 | not (isNoRepLit lit)
1143 = Just (LitArg lit, AtomicRhs)
1145 exprToAtom env (Con con con_args)
1146 | switchIsSet env SimplReuseCon
1150 --- ...(let w = C same-args in ...)...
1151 -- Then use v instead of w. This may save
1152 -- re-constructing an existing constructor.
1153 = case (lookForConstructor env con con_args) of
1155 Just var -> Just (VarArg var, ConReused)
1157 exprToAtom env other
1161 %************************************************************************
1163 \subsection[Simplify-quickies]{Some local help functions}
1165 %************************************************************************
1169 -- fix_up_demandedness switches off the willBeDemanded Info field
1170 -- for bindings floated out of a non-demanded let
1171 fix_up_demandedness True {- Will be demanded -} bind
1172 = bind -- Simple; no change to demand info needed
1173 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1174 = NonRec (un_demandify binder) rhs
1175 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1176 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1178 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1180 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1181 is_cheap_prim_app other = False
1183 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1184 computeResultType env expr args
1187 expr_ty = coreExprType (unTagBinders expr)
1188 expr_ty' = simplTy env expr_ty
1191 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1192 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1193 Just (_, res_ty) -> go res_ty args
1194 Nothing -> panic "computeResultType"