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 SmplLoop -- paranoia checking
15 import CmdLineOpts ( SimplifierSwitch(..) )
16 import ConFold ( completePrim )
18 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
19 unTagBinders, squashableDictishCcExpr,
22 import Id ( idType, idWantsToBeINLINEd,
23 getIdDemandInfo, addIdDemandInfo,
24 GenId{-instance NamedThing-}
26 import IdInfo ( willBeDemanded, DemandInfo )
27 import Literal ( isNoRepLit )
28 import Maybes ( maybeToBool )
29 import Name ( isLocallyDefined )
30 import PprStyle ( PprStyle(..) )
31 import PprType ( GenType{-instance Outputable-} )
32 import PrelInfo ( realWorldStateTy )
33 import Pretty ( ppAbove )
34 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
35 import SimplCase ( simplCase, bindLargeRhs )
38 import SimplVar ( completeVar )
40 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
41 splitFunTy, getFunTy_maybe, eqTy
43 import Util ( isSingleton, panic, pprPanic, assertPanic )
46 The controlling flags, and what they do
47 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
51 -fsimplify = run the simplifier
52 -ffloat-inwards = runs the float lets inwards pass
53 -ffloat = runs the full laziness pass
54 (ToDo: rename to -ffull-laziness)
55 -fupdate-analysis = runs update analyser
56 -fstrictness = runs strictness analyser
57 -fsaturate-apps = saturates applications (eta expansion)
61 -ffloat-past-lambda = OK to do full laziness.
62 (ToDo: remove, as the full laziness pass is
63 useless without this flag, therefore
64 it is unnecessary. Just -ffull-laziness
67 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
68 let is strict or if the floating will expose
71 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
72 is a primop that cannot fail [simplifier].
74 -fcode-duplication-ok = allows the previous option to work on cases with
75 multiple branches [simplifier].
77 -flet-to-case = does let-to-case transformation [simplifier].
79 -fcase-of-case = does case of case transformation [simplifier].
81 -fpedantic-bottoms = does not allow:
82 case x of y -> e ===> e[x/y]
83 (which may turn bottom into non-bottom)
89 Inlining is one of the delicate aspects of the simplifier. By
90 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
91 the RHS of x's definition. Thus
93 let x = e in ...x... ===> let x = e in ...e...
95 We have two mechanisms for inlining:
97 1. Unconditional. The occurrence analyser has pinned an (OneOcc
98 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
99 certainly safe to inline this variable, and to drop its binding''.
100 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
101 happy to be duplicating code...) When it encounters such a beast, the
102 simplifer binds the variable to its RHS (in the id_env) and continues.
103 It doesn't even look at the RHS at that stage. It also drops the
106 2. Conditional. In all other situations, the simplifer simplifies
107 the RHS anyway, and keeps the new binding. It also binds the new
108 (cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
110 Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
111 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
112 the variable has an INLINE pragma on it). The idea is that anything
113 in the UnfoldEnv is safe to use, but also has an enclosing binding if
114 you decide not to use it.
118 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
121 At one time I thought it would be OK to put non-HNF unfoldings in for
122 variables which occur only once [if they got inlined at that
123 occurrence the RHS of the binding would become dead, so no duplication
124 would occur]. But consider:
127 f = \y -> ...y...y...y...
130 Now, it seems that @x@ appears only once, but even so it is NOT safe
131 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
132 duplicate the references to @x@.
134 Because of this, the "unconditional-inline" mechanism above is the
135 only way in which non-HNFs can get inlined.
140 When a variable has an INLINE pragma on it --- which includes wrappers
141 produced by the strictness analyser --- we treat it rather carefully.
143 For a start, we are careful not to substitute into its RHS, because
144 that might make it BIG, and the user said "inline exactly this", not
145 "inline whatever you get after inlining other stuff inside me". For
149 in {-# INLINE y #-} y = f 3
152 Here we don't want to substitute BIG for the (single) occurrence of f,
153 because then we'd duplicate BIG when we inline'd y. (Exception:
154 things in the UnfoldEnv with UnfoldAlways flags, which originated in
155 other INLINE pragmas.)
157 So, we clean out the UnfoldEnv of all GenForm inlinings before
158 going into such an RHS.
160 What about imports? They don't really matter much because we only
161 inline relatively small things via imports.
163 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
164 INLINE pragma. We also do this for the RHSs of recursive decls,
165 before looking at the recursive decls. That way we achieve the effect
166 of inlining a wrapper in the body of its worker, in the case of a
167 mutually-recursive worker/wrapper split.
170 %************************************************************************
172 \subsection[Simplify-simplExpr]{The main function: simplExpr}
174 %************************************************************************
176 At the top level things are a little different.
178 * No cloning (not allowed for exported Ids, unnecessary for the others)
180 * No floating. Case floating is obviously out. Let floating is
181 theoretically OK, but dangerous because of space leaks.
182 The long-distance let-floater lifts these lets.
185 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
187 simplTopBinds env [] = returnSmpl []
189 -- Dead code is now discarded by the occurrence analyser,
191 simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
192 | inlineUnconditionally ok_to_dup_code occ_info
194 new_env = extendIdEnvWithInlining env env binder rhs
196 simplTopBinds new_env binds
198 ok_to_dup_code = switchIsSet env SimplOkToDupCode
200 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
201 = -- No cloning necessary at top level
202 -- Process the binding
203 simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
205 new_env = case rhs' of
206 Var v -> extendIdEnvWithAtom env binder (VarArg v)
207 Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
208 other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
210 -- Process the other bindings
211 simplTopBinds new_env binds `thenSmpl` \ binds' ->
213 -- Glue together and return ...
214 -- We leave it to susequent occurrence analysis to throw away
215 -- an unused atom binding. This localises the decision about
216 -- discarding top-level bindings.
217 returnSmpl (NonRec in_id rhs' : binds')
219 simplTopBinds env (Rec pairs : binds)
220 = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
222 -- Process the other bindings
223 simplTopBinds new_env binds `thenSmpl` \ binds' ->
225 -- Glue together and return
226 returnSmpl (bind' : binds')
228 triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
229 -- No cloning necessary at top level
232 %************************************************************************
234 \subsection[Simplify-simplExpr]{The main function: simplExpr}
236 %************************************************************************
240 simplExpr :: SimplEnv
241 -> InExpr -> [OutArg]
245 The expression returned has the same meaning as the input expression
246 applied to the specified arguments.
251 Check if there's a macro-expansion, and if so rattle on. Otherwise do
252 the more sophisticated stuff.
255 simplExpr env (Var v) args
256 = case (lookupId env v) of
258 new_v = simplTyInId env v
260 completeVar env new_v args
264 ItsAnAtom (LitArg lit) -- A boring old literal
265 -- Paranoia check for args empty
267 [] -> returnSmpl (Lit lit)
268 other -> panic "simplExpr:coVar"
270 ItsAnAtom (VarArg var) -- More interesting! An id!
271 -- No need to substitute the type env here,
272 -- because we already have!
273 -> completeVar env var args
275 InlineIt id_env ty_env in_expr -- A macro-expansion
276 -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
283 simplExpr env (Lit l) [] = returnSmpl (Lit l)
285 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
289 Primitive applications are simple.
290 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
292 NB: Prim expects an empty argument list! (Because it should be
293 saturated and not higher-order. ADR)
296 simplExpr env (Prim op prim_args) args
299 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
302 completePrim env op' prim_args'
304 -- PrimOps just need any types in them renamed.
306 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
308 arg_tys' = map (simplTy env) arg_tys
309 result_ty' = simplTy env result_ty
311 CCallOp label is_asm may_gc arg_tys' result_ty'
313 simpl_op other_op = other_op
316 Constructor applications
317 ~~~~~~~~~~~~~~~~~~~~~~~~
318 Nothing to try here. We only reuse constructors when they appear as the
319 rhs of a let binding (see completeLetBinding).
322 simplExpr env (Con con con_args) args
323 = ASSERT( null args )
324 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
328 Applications are easy too:
329 ~~~~~~~~~~~~~~~~~~~~~~~~~~
330 Just stuff 'em in the arg stack
333 simplExpr env (App fun arg) args
334 = simplExpr env fun (simplArg env arg : args)
340 We only eta-reduce a type lambda if all type arguments in the body can
341 be eta-reduced. This requires us to collect up all tyvar parameters so
342 we can pass them all to @mkTyLamTryingEta@.
345 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
346 = -- ASSERT(not (isPrimType ty))
348 new_env = extendTyEnv env tyvar ty
350 tick TyBetaReduction `thenSmpl_`
351 simplExpr new_env body args
353 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
354 = do_tylambdas env [] tylam
356 do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
357 = -- Clone the type variable
358 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
360 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
362 do_tylambdas new_env (tyvar':tyvars') body
364 do_tylambdas env tyvars' body
365 = simplExpr env body [] `thenSmpl` \ body' ->
367 (if switchIsSet env SimplDoEtaReduction
368 then mkTyLamTryingEta
369 else mkTyLam) (reverse tyvars') body'
373 simplExpr env (Lam (TyBinder _) _) (_ : _)
374 = panic "simplExpr:TyLam with non-TyArg"
383 simplExpr env (Lam (ValBinder binder) body) args
384 | null leftover_binders
385 = -- The lambda is saturated (or over-saturated)
386 tick BetaReduction `thenSmpl_`
387 simplExpr env_for_enough_args body leftover_args
390 = -- Too few args to saturate the lambda
391 ASSERT( null leftover_args )
393 (if not (null args) -- ah, we must've gotten rid of some...
394 then tick BetaReduction
395 else returnSmpl (panic "BetaReduction")
398 simplLam env_for_too_few_args leftover_binders body
399 0 {- Guaranteed applied to at least 0 args! -}
402 (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
404 env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
406 env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
408 -- Since there aren't enough args the binders we are cancelling with
409 -- the args supplied are, in effect, ocurring inside a lambda.
410 -- So we modify their occurrence info to reflect this fact.
411 -- Example: (\ x y z -> e) p q
412 -- ==> (\z -> e[p/x, q/y])
413 -- but we should behave as if x and y are marked "inside lambda".
414 -- The occurrence analyser does not mark them so itself because then we
415 -- do badly on the very common case of saturated lambdas applications:
416 -- (\ x y z -> e) p q r
417 -- ==> e[p/x, q/y, r/z]
419 zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
420 | ((id, occ_info), arg) <- binder_args_pairs ]
422 collect_val_args :: InBinder -- Binder
423 -> [OutArg] -- Arguments
424 -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
425 [InBinder], -- Leftover binders (ToDo: a maybe)
426 [OutArg]) -- Leftover args
428 -- collect_val_args strips off the leading ValArgs from
429 -- the current arg list, returning them along with the
431 collect_val_args binder [] = ([], [binder], [])
432 collect_val_args binder (arg : args) | isValArg arg
433 = ([(binder,arg)], [], args)
436 collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
437 -- TyArg should never meet a Lam
446 simplExpr env (Let bind body) args
448 {- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
449 and it doesn't seem worth retaining the ability to not float applications
452 | switchIsSet env SimplNoLetFromApp
453 = simplBind env bind (\env -> simplExpr env body [])
454 (computeResultType env body []) `thenSmpl` \ let_expr' ->
455 returnSmpl (mkGenApp let_expr' args)
457 | otherwise -- No float from application
460 = simplBind env bind (\env -> simplExpr env body args)
461 (computeResultType env body args)
468 simplExpr env expr@(Case scrut alts) args
469 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
470 (computeResultType env expr args)
477 simplExpr env (Coerce coercion ty body) args
478 = simplCoerce env coercion ty body args
485 A special case we do:
487 scc "foo" (\x -> e) ===> \x -> scc "foo" e
489 Simon thinks it's OK, at least for lexical scoping; and it makes
490 interfaces change less (arities).
493 simplExpr env (SCC cc (Lam binder body)) args
494 = simplExpr env (Lam binder (SCC cc body)) args
497 Some other slightly turgid SCC tidying-up cases:
499 simplExpr env (SCC cc1 expr@(SCC _ _)) args
500 = simplExpr env expr args
501 -- the outer _scc_ serves no purpose
503 simplExpr env (SCC cc expr) args
504 | squashableDictishCcExpr cc expr
505 = simplExpr env expr args
506 -- the DICT-ish CC is no longer serving any purpose
509 NB: for other set-cost-centre we move arguments inside the body.
510 ToDo: check with Patrick that this is ok.
513 simplExpr env (SCC cost_centre body) args
515 new_env = setEnclosingCC env (EnclosingCC cost_centre)
517 simplExpr new_env body args `thenSmpl` \ body' ->
518 returnSmpl (SCC cost_centre body')
521 %************************************************************************
523 \subsection{Simplify RHS of a Let/Letrec}
525 %************************************************************************
527 simplRhsExpr does arity-expansion. That is, given:
529 * a right hand side /\ tyvars -> \a1 ... an -> e
530 * the information (stored in BinderInfo) that the function will always
531 be applied to at least k arguments
533 it transforms the rhs to
535 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
537 This is a Very Good Thing!
546 simplRhsExpr env binder@(id,occ_info) rhs
547 | dont_eta_expand rhs
548 = simplExpr rhs_env rhs []
550 | otherwise -- Have a go at eta expansion
551 = -- Deal with the big lambda part
552 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
554 lam_env = extendTyEnvList rhs_env (tyvars `zip` (mkTyVarTys tyvars'))
556 -- Deal with the little lambda part
557 -- Note that we call simplLam even if there are no binders, in case
558 -- it can do arity expansion.
559 simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
561 -- Put it back together
563 (if switchIsSet env SimplDoEtaReduction
564 then mkTyLamTryingEta
565 else mkTyLam) tyvars' lambda'
569 -- If you say {-# INLINE #-} then you get what's coming to you;
570 -- you are saying inline the rhs, please.
571 -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
572 rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
575 (uvars, tyvars, binders, body) = collectBinders rhs
577 min_no_of_args | not (null binders) && -- It's not a thunk
578 switchIsSet env SimplDoArityExpand -- Arity expansion on
579 = getBinderInfoArity occ_info - length binders
581 | otherwise -- Not a thunk
584 -- dont_eta_expand prevents eta expansion in silly situations.
585 -- For example, consider the defn
587 -- It would be silly to eta expand the "y", because it would just
588 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
589 -- and x was exported, then the defn won't be eliminated, so this
590 -- silly expand/reduce cycle will happen every time, which makes the
592 -- The solution is to not even try eta expansion unless the rhs looks
594 dont_eta_expand (Lit _) = True
595 dont_eta_expand (Var _) = True
596 dont_eta_expand (Con _ _) = True
597 dont_eta_expand (App f a)
598 | notValArg a = dont_eta_expand f
599 dont_eta_expand (Lam x b)
600 | notValBinder x = dont_eta_expand b
601 dont_eta_expand _ = False
605 %************************************************************************
607 \subsection{Simplify a lambda abstraction}
609 %************************************************************************
611 Simplify (\binders -> body) trying eta expansion and reduction, given that
612 the abstraction will always be applied to at least min_no_of_args.
615 simplLam env binders body min_no_of_args
616 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
617 null potential_extra_binder_tys || -- or ain't a function
618 no_of_extra_binders == 0 -- or no extra binders needed
619 = cloneIds env binders `thenSmpl` \ binders' ->
621 new_env = extendIdEnvWithClones env binders binders'
623 simplExpr new_env body [] `thenSmpl` \ body' ->
625 (if switchIsSet new_env SimplDoEtaReduction
626 then mkValLamTryingEta
627 else mkValLam) binders' body'
630 | otherwise -- Eta expansion possible
631 = tick EtaExpansion `thenSmpl_`
632 cloneIds env binders `thenSmpl` \ binders' ->
634 new_env = extendIdEnvWithClones env binders binders'
636 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
637 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
639 (if switchIsSet new_env SimplDoEtaReduction
640 then mkValLamTryingEta
641 else mkValLam) (binders' ++ extra_binders') body'
645 (potential_extra_binder_tys, res_ty)
646 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
647 -- Note: it's possible that simplLam will be applied to something
648 -- with a forall type. Eg when being applied to the rhs of
650 -- where wurble has a forall-type, but no big lambdas at the top.
651 -- We could be clever an insert new big lambdas, but we don't bother.
653 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
655 no_of_extra_binders = -- First, use the info about how many args it's
656 -- always applied to in its scope
659 -- Next, try seeing if there's a lambda hidden inside
664 -- Finally, see if it's a state transformer, in which
665 -- case we eta-expand on principle! This can waste work,
666 -- but usually doesn't
668 case potential_extra_binder_tys of
669 [ty] | ty `eqTy` realWorldStateTy -> 1
676 %************************************************************************
678 \subsection[Simplify-coerce]{Coerce expressions}
680 %************************************************************************
683 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
684 simplCoerce env coercion ty expr@(Case scrut alts) args
685 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
686 (computeResultType env expr args)
688 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
689 simplCoerce env coercion ty (Let bind body) args
690 = simplBind env bind (\env -> simplCoerce env coercion ty body args)
691 (computeResultType env body args)
694 simplCoerce env (CoerceIn con1) ty (Coerce (CoerceOut con2) ty2 expr) args
696 = simplExpr env expr args
697 simplCoerce env (CoerceOut con1) ty (Coerce (CoerceIn con2) ty2 expr) args
699 = simplExpr env expr args
702 simplCoerce env coercion ty expr args
703 = simplExpr env expr [] `thenSmpl` \ expr' ->
704 returnSmpl (mkGenApp (Coerce coercion (simplTy env ty) expr') args)
708 %************************************************************************
710 \subsection[Simplify-let]{Let-expressions}
712 %************************************************************************
715 simplBind :: SimplEnv
717 -> (SimplEnv -> SmplM OutExpr)
722 When floating cases out of lets, remember this:
724 let x* = case e of alts
727 where x* is sure to be demanded or e is a cheap operation that cannot
728 fail, e.g. unboxed addition. Here we should be prepared to duplicate
729 <small expr>. A good example:
738 p1 -> foldr c n (build e1)
739 p2 -> foldr c n (build e2)
741 NEW: We use the same machinery that we use for case-of-case to
742 *always* do case floating from let, that is we let bind and abstract
743 the original let body, and let the occurrence analyser later decide
744 whether the new let should be inlined or not. The example above
748 let join_body x' = foldr c n x'
750 p1 -> let x* = build e1
752 p2 -> let x* = build e2
755 note that join_body is a let-no-escape.
756 In this particular example join_body will later be inlined,
757 achieving the same effect.
758 ToDo: check this is OK with andy
763 -- Dead code is now discarded by the occurrence analyser,
765 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
766 | inlineUnconditionally ok_to_dup occ_info
767 = body_c (extendIdEnvWithInlining env env binder rhs)
770 -- It's important to try let-to-case before floating. Consider
772 -- let a*::Int = case v of {p1->e1; p2->e2}
775 -- (The * means that a is sure to be demanded.)
776 -- If we do case-floating first we get this:
780 -- p1-> let a*=e1 in k a
781 -- p2-> let a*=e2 in k a
783 -- Now watch what happens if we do let-to-case first:
785 -- case (case v of {p1->e1; p2->e2}) of
786 -- Int a# -> let a*=I# a# in b
788 -- let k = \a# -> let a*=I# a# in b
790 -- p1 -> case e1 of I# a# -> k a#
791 -- p1 -> case e1 of I# a# -> k a#
793 -- The latter is clearly better. (Remember the reboxing let-decl
794 -- for a is likely to go away, because after all b is strict in a.)
796 | will_be_demanded &&
798 type_ok_for_let_to_case rhs_ty &&
799 not (manifestlyWHNF rhs)
800 -- note: no "manifestlyBottom rhs" in there... (comment below)
801 = tick Let2Case `thenSmpl_`
802 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
803 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
805 We do not do let to case for WHNFs, e.g.
811 as this is less efficient.
812 but we don't mind doing let-to-case for "bottom", as that
814 allow us to remove more dead code, if anything:
817 case error of x -> ...
821 Notice that let to case occurs only if x is used strictly in
822 its body (obviously).
825 | (will_be_demanded && not no_float) ||
826 always_float_let_from_let ||
827 floatExposesHNF float_lets float_primops ok_to_dup rhs
828 = try_float env rhs body_c
831 = done_float env rhs body_c
834 will_be_demanded = willBeDemanded (getIdDemandInfo id)
837 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
838 float_primops = switchIsSet env SimplOkToFloatPrimOps
839 ok_to_dup = switchIsSet env SimplOkToDupCode
840 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
841 try_let_to_case = switchIsSet env SimplLetToCase
842 no_float = switchIsSet env SimplNoLetFromStrictLet
844 -------------------------------------------
845 done_float env rhs body_c
846 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
847 completeLet env binder rhs rhs' body_c body_ty
849 ---------------------------------------
850 try_float env (Let bind rhs) body_c
851 = tick LetFloatFromLet `thenSmpl_`
852 simplBind env (fix_up_demandedness will_be_demanded bind)
853 (\env -> try_float env rhs body_c) body_ty
855 try_float env (Case scrut alts) body_c
856 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
857 = tick CaseFloatFromLet `thenSmpl_`
859 -- First, bind large let-body if necessary
860 if no_need_to_bind_large_body then
861 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
863 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
865 body_c' = \env -> simplExpr env new_body []
867 simplCase env scrut alts
868 (\env rhs -> try_float env rhs body_c')
869 body_ty `thenSmpl` \ case_expr ->
871 returnSmpl (Let extra_binding case_expr)
873 no_need_to_bind_large_body
874 = ok_to_dup || isSingleton (nonErrorRHSs alts)
876 try_float env other_rhs body_c = done_float env other_rhs body_c
882 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
883 on and it'll expose a HNF), and bang the whole resulting mess together
886 1. Any "macros" should be expanded. The main application of this
895 Here we would like the single call to g to be inlined.
897 We can spot this easily, because g will be tagged as having just one
898 occurrence. The "inlineUnconditionally" predicate is just what we want.
900 A worry: could this lead to non-termination? For example:
909 Here, f and g call each other (just once) and neither is used elsewhere.
912 * the occurrence analyser will drop any (sub)-group that isn't used at
915 * If the group is used outside itself (ie in the "in" part), then there
918 ** IMPORTANT: check that NewOccAnal has the property that a group of
919 bindings like the above has f&g dropped.! ***
922 2. We'd also like to pull out any top-level let(rec)s from the
926 f = let h = ... in \x -> ....h...f...h...
932 f = \x -> ....h...f...h...
936 But floating cases is less easy? (Don't for now; ToDo?)
939 3. We'd like to arrange that the RHSs "know" about members of the
940 group that are bound to constructors. For example:
944 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
945 /= a b = unpack tuple a, unpack tuple b, call f
948 here, by knowing about d.Eq in f's rhs, one could get rid of
949 the case (and break out the recursion completely).
950 [This occurred with more aggressive inlining threshold (4),
951 nofib/spectral/knights]
954 1: we simplify constructor rhss first.
955 2: we record the "known constructors" in the environment
956 3: we simplify the other rhss, with the knowledge about the constructors
961 simplBind env (Rec pairs) body_c body_ty
962 = -- Do floating, if necessary
963 (if float_lets || always_float_let_from_let
965 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
966 returnSmpl (concat floated_pairs_s)
969 ) `thenSmpl` \ floated_pairs ->
971 binders = map fst floated_pairs
973 cloneIds env binders `thenSmpl` \ ids' ->
975 env_w_clones = extendIdEnvWithClones env binders ids'
976 triples = ids' `zip` floated_pairs
979 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
981 body_c new_env `thenSmpl` \ body' ->
983 returnSmpl (Let binding body')
986 ------------ Floating stuff -------------------
988 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
989 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
993 pairs_s = float_pair (binder,rhs)
996 [_] -> returnSmpl pairs_s
998 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
999 -- It's important to increment the tick counts if we
1000 -- do any floating. A situation where this turns out
1001 -- to be important is this:
1002 -- Float in produces:
1003 -- letrec x = let y = Ey in Ex
1005 -- Now floating gives this:
1009 --- We now want to iterate once more in case Ey doesn't
1010 -- mention x, in which case the y binding can be pulled
1011 -- out as an enclosing let(rec), which in turn gives
1012 -- the strictness analyser more chance.
1015 float_pairs pairs = concat (map float_pair pairs)
1017 float_pair (binder, rhs)
1018 | always_float_let_from_let ||
1019 floatExposesHNF True False False rhs
1020 = (binder,rhs') : pairs'
1025 (pairs', rhs') = do_float rhs
1027 -- Float just pulls out any top-level let(rec) bindings
1028 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
1029 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
1031 (pairs', body') = do_float body
1032 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
1034 (pairs', body') = do_float body
1035 do_float other = ([], other)
1037 simplRecursiveGroup env triples
1038 = -- Toss out all the dead pairs? No, there shouldn't be any!
1039 -- Dead code is discarded by the occurrence analyser
1041 -- Separate the live triples into "inline"able and
1042 -- "ordinary" We're paranoid about duplication!
1043 (inline_triples, ordinary_triples)
1044 = partition is_inline_triple triples
1046 is_inline_triple (_, ((_,occ_info),_))
1047 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1049 -- Now add in the inline_pairs info (using "env_w_clones"),
1050 -- so that we will save away suitably-clone-laden envs
1051 -- inside the InlineIts...).
1053 -- NOTE ALSO that we tie a knot here, because the
1054 -- saved-away envs must also include these very inlinings
1055 -- (they aren't stored anywhere else, and a late one might
1056 -- be used in an early one).
1058 env_w_inlinings = foldl add_inline env inline_triples
1060 add_inline env (id', (binder,rhs))
1061 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1063 -- Separate the remaining bindings into the ones which
1064 -- need to be dealt with first (the "early" ones)
1065 -- and the others (the "late" ones)
1066 (early_triples, late_triples)
1067 = partition is_early_triple ordinary_triples
1069 is_early_triple (_, (_, Con _ _)) = True
1070 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1072 -- Process the early bindings first
1073 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1075 -- Now further extend the environment to record our knowledge
1076 -- about the form of the binders bound in the constructor bindings
1078 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1079 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1081 -- Now process the non-constructor bindings
1082 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1086 binding = Rec (map snd early_triples' ++ map snd late_triples')
1088 returnSmpl (binding, env_w_early_info)
1091 do_one_binding env (id', (binder,rhs))
1092 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1093 returnSmpl (binder, (id', rhs'))
1097 @completeLet@ looks at the simplified post-floating RHS of the
1098 let-expression, and decides what to do. There's one interesting
1099 aspect to this, namely constructor reuse. Consider
1105 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1106 bit on the compiler technology, but in general I believe not. For
1107 example, here's some code from a real program:
1109 const.Int.max.wrk{-s2516-} =
1110 \ upk.s3297# upk.s3298# ->
1114 a.s3299 = I#! upk.s3297#
1116 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1117 _LT -> I#! upk.s3298#
1122 The a.s3299 really isn't doing much good. We'd be better off inlining
1123 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1125 So the current strategy is to inline all known-form constructors, and
1126 only do the reverse (turn a constructor application back into a
1127 variable) when we find a let-expression:
1131 ... (let y = C a1 .. an in ...) ...
1133 where it is always good to ditch the binding for y, and replace y by
1134 x. That's just what completeLetBinding does.
1140 -> InExpr -- Original RHS
1141 -> OutExpr -- The simplified RHS
1142 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1143 -> OutType -- Type of body
1146 completeLet env binder old_rhs new_rhs body_c body_ty
1147 -- See if RHS is an atom, or a reusable constructor
1148 | maybeToBool maybe_atomic_rhs
1150 new_env = extendIdEnvWithAtom env binder rhs_atom
1152 tick atom_tick_type `thenSmpl_`
1155 maybe_atomic_rhs :: Maybe (OutArg, TickType)
1156 maybe_atomic_rhs = exprToAtom env new_rhs
1157 -- If the RHS is atomic, we return Just (atom, tick type)
1158 -- otherwise Nothing
1159 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1161 completeLet env binder@(id,_) old_rhs new_rhs body_c body_ty
1162 -- Maybe the rhs is an application of error, and sure to be demanded
1163 | will_be_demanded &&
1164 maybeToBool maybe_error_app
1165 = tick CaseOfError `thenSmpl_`
1166 returnSmpl retyped_error_app
1168 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1169 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1170 Just retyped_error_app = maybe_error_app
1173 completeLet env binder old_rhs (Coerce coercion ty rhs) body_c body_ty
1174 -- Rhs is a coercion
1175 | maybeToBool maybe_atomic_coerce_rhs
1176 = tick tick_type `thenSmpl_`
1177 complete_coerce env rhs_atom rhs
1179 maybe_atomic_coerce_rhs = exprToAtom env rhs
1180 Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
1182 returnSmpl (CoerceForm coercion rhs_atom, env)
1184 newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1186 complete_coerce env atom rhs
1187 = cloneId env binder `thenSmpl` \ id' ->
1189 env1 = extendIdEnvWithClone env binder id'
1190 new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
1192 body_c new_env `thenSmpl` \ body' ->
1193 returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
1196 completeLet env binder old_rhs new_rhs body_c body_ty
1198 = cloneId env binder `thenSmpl` \ id' ->
1200 env1 = extendIdEnvWithClone env binder id'
1201 new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
1203 body_c new_env `thenSmpl` \ body' ->
1204 returnSmpl (Let (NonRec id' new_rhs) body')
1207 %************************************************************************
1209 \subsection[Simplify-atoms]{Simplifying atoms}
1211 %************************************************************************
1214 simplArg :: SimplEnv -> InArg -> OutArg
1216 simplArg env (LitArg lit) = LitArg lit
1217 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1219 simplArg env (VarArg id)
1220 | isLocallyDefined id
1221 = case lookupId env id of
1222 Just (ItsAnAtom atom) -> atom
1223 Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1224 Nothing -> VarArg id -- Must be an uncloned thing
1227 = -- Not locally defined, so no change
1233 exprToAtom env (Var var)
1234 = Just (VarArg var, AtomicRhs)
1236 exprToAtom env (Lit lit)
1237 | not (isNoRepLit lit)
1238 = Just (LitArg lit, AtomicRhs)
1240 exprToAtom env (Con con con_args)
1241 | switchIsSet env SimplReuseCon
1245 --- ...(let w = C same-args in ...)...
1246 -- Then use v instead of w. This may save
1247 -- re-constructing an existing constructor.
1248 = case (lookForConstructor env con con_args) of
1250 Just var -> Just (VarArg var, ConReused)
1252 exprToAtom env other
1256 %************************************************************************
1258 \subsection[Simplify-quickies]{Some local help functions}
1260 %************************************************************************
1264 -- fix_up_demandedness switches off the willBeDemanded Info field
1265 -- for bindings floated out of a non-demanded let
1266 fix_up_demandedness True {- Will be demanded -} bind
1267 = bind -- Simple; no change to demand info needed
1268 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1269 = NonRec (un_demandify binder) rhs
1270 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1271 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1273 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1275 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1276 is_cheap_prim_app other = False
1278 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1279 computeResultType env expr args
1282 expr_ty = coreExprType (unTagBinders expr)
1283 expr_ty' = simplTy env expr_ty
1286 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1287 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1288 Just (_, res_ty) -> go res_ty args
1289 Nothing -> panic "computeResultType"