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
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 Pretty ( ppAbove )
33 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
34 import SimplCase ( simplCase, bindLargeRhs )
37 import SimplVar ( completeVar )
39 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
40 splitFunTy, getFunTy_maybe, eqTy
42 import TysWiredIn ( realWorldStateTy )
43 import Util ( isSingleton, zipEqual, 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 (zipEqual "simplRhsExpr" tyvars (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 coercion ty expr args
695 = simplExpr env expr [] `thenSmpl` \ expr' ->
696 returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
699 -- Try cancellation; we do this "on the way up" because
700 -- I think that's where it'll bite best
701 mkCoerce (CoerceIn con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body
702 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
703 mkCoerce coercion ty body = Coerce coercion ty body
707 %************************************************************************
709 \subsection[Simplify-let]{Let-expressions}
711 %************************************************************************
714 simplBind :: SimplEnv
716 -> (SimplEnv -> SmplM OutExpr)
721 When floating cases out of lets, remember this:
723 let x* = case e of alts
726 where x* is sure to be demanded or e is a cheap operation that cannot
727 fail, e.g. unboxed addition. Here we should be prepared to duplicate
728 <small expr>. A good example:
737 p1 -> foldr c n (build e1)
738 p2 -> foldr c n (build e2)
740 NEW: We use the same machinery that we use for case-of-case to
741 *always* do case floating from let, that is we let bind and abstract
742 the original let body, and let the occurrence analyser later decide
743 whether the new let should be inlined or not. The example above
747 let join_body x' = foldr c n x'
749 p1 -> let x* = build e1
751 p2 -> let x* = build e2
754 note that join_body is a let-no-escape.
755 In this particular example join_body will later be inlined,
756 achieving the same effect.
757 ToDo: check this is OK with andy
762 -- Dead code is now discarded by the occurrence analyser,
764 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
765 | inlineUnconditionally ok_to_dup occ_info
766 = body_c (extendIdEnvWithInlining env env binder rhs)
769 -- It's important to try let-to-case before floating. Consider
771 -- let a*::Int = case v of {p1->e1; p2->e2}
774 -- (The * means that a is sure to be demanded.)
775 -- If we do case-floating first we get this:
779 -- p1-> let a*=e1 in k a
780 -- p2-> let a*=e2 in k a
782 -- Now watch what happens if we do let-to-case first:
784 -- case (case v of {p1->e1; p2->e2}) of
785 -- Int a# -> let a*=I# a# in b
787 -- let k = \a# -> let a*=I# a# in b
789 -- p1 -> case e1 of I# a# -> k a#
790 -- p1 -> case e1 of I# a# -> k a#
792 -- The latter is clearly better. (Remember the reboxing let-decl
793 -- for a is likely to go away, because after all b is strict in a.)
795 | will_be_demanded &&
797 type_ok_for_let_to_case rhs_ty &&
798 not (manifestlyWHNF rhs)
799 -- note: no "manifestlyBottom rhs" in there... (comment below)
800 = tick Let2Case `thenSmpl_`
801 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
802 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
804 We do not do let to case for WHNFs, e.g.
810 as this is less efficient.
811 but we don't mind doing let-to-case for "bottom", as that
813 allow us to remove more dead code, if anything:
816 case error of x -> ...
820 Notice that let to case occurs only if x is used strictly in
821 its body (obviously).
824 | (will_be_demanded && not no_float) ||
825 always_float_let_from_let ||
826 floatExposesHNF float_lets float_primops ok_to_dup rhs
827 = try_float env rhs body_c
830 = done_float env rhs body_c
833 will_be_demanded = willBeDemanded (getIdDemandInfo id)
836 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
837 float_primops = switchIsSet env SimplOkToFloatPrimOps
838 ok_to_dup = switchIsSet env SimplOkToDupCode
839 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
840 try_let_to_case = switchIsSet env SimplLetToCase
841 no_float = switchIsSet env SimplNoLetFromStrictLet
843 -------------------------------------------
844 done_float env rhs body_c
845 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
846 completeLet env binder rhs' body_c body_ty
848 ---------------------------------------
849 try_float env (Let bind rhs) body_c
850 = tick LetFloatFromLet `thenSmpl_`
851 simplBind env (fix_up_demandedness will_be_demanded bind)
852 (\env -> try_float env rhs body_c) body_ty
854 try_float env (Case scrut alts) body_c
855 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
856 = tick CaseFloatFromLet `thenSmpl_`
858 -- First, bind large let-body if necessary
859 if no_need_to_bind_large_body then
860 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
862 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
864 body_c' = \env -> simplExpr env new_body []
866 simplCase env scrut alts
867 (\env rhs -> try_float env rhs body_c')
868 body_ty `thenSmpl` \ case_expr ->
870 returnSmpl (Let extra_binding case_expr)
872 no_need_to_bind_large_body
873 = ok_to_dup || isSingleton (nonErrorRHSs alts)
875 try_float env other_rhs body_c = done_float env other_rhs body_c
881 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
882 on and it'll expose a HNF), and bang the whole resulting mess together
885 1. Any "macros" should be expanded. The main application of this
894 Here we would like the single call to g to be inlined.
896 We can spot this easily, because g will be tagged as having just one
897 occurrence. The "inlineUnconditionally" predicate is just what we want.
899 A worry: could this lead to non-termination? For example:
908 Here, f and g call each other (just once) and neither is used elsewhere.
911 * the occurrence analyser will drop any (sub)-group that isn't used at
914 * If the group is used outside itself (ie in the "in" part), then there
917 ** IMPORTANT: check that NewOccAnal has the property that a group of
918 bindings like the above has f&g dropped.! ***
921 2. We'd also like to pull out any top-level let(rec)s from the
925 f = let h = ... in \x -> ....h...f...h...
931 f = \x -> ....h...f...h...
935 But floating cases is less easy? (Don't for now; ToDo?)
938 3. We'd like to arrange that the RHSs "know" about members of the
939 group that are bound to constructors. For example:
943 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
944 /= a b = unpack tuple a, unpack tuple b, call f
947 here, by knowing about d.Eq in f's rhs, one could get rid of
948 the case (and break out the recursion completely).
949 [This occurred with more aggressive inlining threshold (4),
950 nofib/spectral/knights]
953 1: we simplify constructor rhss first.
954 2: we record the "known constructors" in the environment
955 3: we simplify the other rhss, with the knowledge about the constructors
960 simplBind env (Rec pairs) body_c body_ty
961 = -- Do floating, if necessary
962 (if float_lets || always_float_let_from_let
964 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
965 returnSmpl (concat floated_pairs_s)
968 ) `thenSmpl` \ floated_pairs ->
970 binders = map fst floated_pairs
972 cloneIds env binders `thenSmpl` \ ids' ->
974 env_w_clones = extendIdEnvWithClones env binders ids'
975 triples = zipEqual "simplBind" ids' floated_pairs
978 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
980 body_c new_env `thenSmpl` \ body' ->
982 returnSmpl (Let binding body')
985 ------------ Floating stuff -------------------
987 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
988 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
992 pairs_s = float_pair (binder,rhs)
995 [_] -> returnSmpl pairs_s
997 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
998 -- It's important to increment the tick counts if we
999 -- do any floating. A situation where this turns out
1000 -- to be important is this:
1001 -- Float in produces:
1002 -- letrec x = let y = Ey in Ex
1004 -- Now floating gives this:
1008 --- We now want to iterate once more in case Ey doesn't
1009 -- mention x, in which case the y binding can be pulled
1010 -- out as an enclosing let(rec), which in turn gives
1011 -- the strictness analyser more chance.
1014 float_pairs pairs = concat (map float_pair pairs)
1016 float_pair (binder, rhs)
1017 | always_float_let_from_let ||
1018 floatExposesHNF True False False rhs
1019 = (binder,rhs') : pairs'
1024 (pairs', rhs') = do_float rhs
1026 -- Float just pulls out any top-level let(rec) bindings
1027 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
1028 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
1030 (pairs', body') = do_float body
1031 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
1033 (pairs', body') = do_float body
1034 do_float other = ([], other)
1036 simplRecursiveGroup env triples
1037 = -- Toss out all the dead pairs? No, there shouldn't be any!
1038 -- Dead code is discarded by the occurrence analyser
1040 -- Separate the live triples into "inline"able and
1041 -- "ordinary" We're paranoid about duplication!
1042 (inline_triples, ordinary_triples)
1043 = partition is_inline_triple triples
1045 is_inline_triple (_, ((_,occ_info),_))
1046 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1048 -- Now add in the inline_pairs info (using "env_w_clones"),
1049 -- so that we will save away suitably-clone-laden envs
1050 -- inside the InlineIts...).
1052 -- NOTE ALSO that we tie a knot here, because the
1053 -- saved-away envs must also include these very inlinings
1054 -- (they aren't stored anywhere else, and a late one might
1055 -- be used in an early one).
1057 env_w_inlinings = foldl add_inline env inline_triples
1059 add_inline env (id', (binder,rhs))
1060 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1062 -- Separate the remaining bindings into the ones which
1063 -- need to be dealt with first (the "early" ones)
1064 -- and the others (the "late" ones)
1065 (early_triples, late_triples)
1066 = partition is_early_triple ordinary_triples
1068 is_early_triple (_, (_, Con _ _)) = True
1069 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1071 -- Process the early bindings first
1072 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1074 -- Now further extend the environment to record our knowledge
1075 -- about the form of the binders bound in the constructor bindings
1077 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1078 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1080 -- Now process the non-constructor bindings
1081 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1085 binding = Rec (map snd early_triples' ++ map snd late_triples')
1087 returnSmpl (binding, env_w_early_info)
1090 do_one_binding env (id', (binder,rhs))
1091 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1092 returnSmpl (binder, (id', rhs'))
1096 @completeLet@ looks at the simplified post-floating RHS of the
1097 let-expression, and decides what to do. There's one interesting
1098 aspect to this, namely constructor reuse. Consider
1104 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1105 bit on the compiler technology, but in general I believe not. For
1106 example, here's some code from a real program:
1108 const.Int.max.wrk{-s2516-} =
1109 \ upk.s3297# upk.s3298# ->
1113 a.s3299 = I#! upk.s3297#
1115 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1116 _LT -> I#! upk.s3298#
1121 The a.s3299 really isn't doing much good. We'd be better off inlining
1122 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1124 So the current strategy is to inline all known-form constructors, and
1125 only do the reverse (turn a constructor application back into a
1126 variable) when we find a let-expression:
1130 ... (let y = C a1 .. an in ...) ...
1132 where it is always good to ditch the binding for y, and replace y by
1133 x. That's just what completeLetBinding does.
1139 -> OutExpr -- The simplified RHS
1140 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1141 -> OutType -- Type of body
1144 completeLet env binder new_rhs body_c body_ty
1145 -- See if RHS is an atom, or a reusable constructor
1146 | maybeToBool maybe_atomic_rhs
1148 new_env = extendIdEnvWithAtom env binder rhs_atom
1150 tick atom_tick_type `thenSmpl_`
1153 maybe_atomic_rhs :: Maybe (OutArg, TickType)
1154 maybe_atomic_rhs = exprToAtom env new_rhs
1155 -- If the RHS is atomic, we return Just (atom, tick type)
1156 -- otherwise Nothing
1157 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1159 completeLet env binder@(id,_) new_rhs body_c body_ty
1160 -- Maybe the rhs is an application of error, and sure to be demanded
1161 | will_be_demanded &&
1162 maybeToBool maybe_error_app
1163 = tick CaseOfError `thenSmpl_`
1164 returnSmpl retyped_error_app
1166 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1167 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1168 Just retyped_error_app = maybe_error_app
1171 completeLet env binder (Coerce coercion ty rhs) body_c body_ty
1172 -- Rhs is a coercion
1173 | maybeToBool maybe_atomic_coerce_rhs
1174 = tick tick_type `thenSmpl_`
1175 complete_coerce env rhs_atom rhs
1177 maybe_atomic_coerce_rhs = exprToAtom env rhs
1178 Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
1180 returnSmpl (CoerceForm coercion rhs_atom, env)
1182 newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1184 complete_coerce env atom rhs
1185 = cloneId env binder `thenSmpl` \ id' ->
1187 env1 = extendIdEnvWithClone env binder id'
1188 new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
1190 body_c new_env `thenSmpl` \ body' ->
1191 returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
1194 completeLet env binder new_rhs body_c body_ty
1196 = cloneId env binder `thenSmpl` \ id' ->
1198 env1 = extendIdEnvWithClone env binder id'
1199 new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
1201 body_c new_env `thenSmpl` \ body' ->
1202 returnSmpl (Let (NonRec id' new_rhs) body')
1205 %************************************************************************
1207 \subsection[Simplify-atoms]{Simplifying atoms}
1209 %************************************************************************
1212 simplArg :: SimplEnv -> InArg -> OutArg
1214 simplArg env (LitArg lit) = LitArg lit
1215 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1217 simplArg env (VarArg id)
1218 | isLocallyDefined id
1219 = case lookupId env id of
1220 Just (ItsAnAtom atom) -> atom
1221 Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1222 Nothing -> VarArg id -- Must be an uncloned thing
1225 = -- Not locally defined, so no change
1231 exprToAtom env (Var var)
1232 = Just (VarArg var, AtomicRhs)
1234 exprToAtom env (Lit lit)
1235 | not (isNoRepLit lit)
1236 = Just (LitArg lit, AtomicRhs)
1238 exprToAtom env (Con con con_args)
1239 | switchIsSet env SimplReuseCon
1243 --- ...(let w = C same-args in ...)...
1244 -- Then use v instead of w. This may save
1245 -- re-constructing an existing constructor.
1246 = case (lookForConstructor env con con_args) of
1248 Just var -> Just (VarArg var, ConReused)
1250 exprToAtom env other
1254 %************************************************************************
1256 \subsection[Simplify-quickies]{Some local help functions}
1258 %************************************************************************
1262 -- fix_up_demandedness switches off the willBeDemanded Info field
1263 -- for bindings floated out of a non-demanded let
1264 fix_up_demandedness True {- Will be demanded -} bind
1265 = bind -- Simple; no change to demand info needed
1266 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1267 = NonRec (un_demandify binder) rhs
1268 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1269 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1271 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1273 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1274 is_cheap_prim_app other = False
1276 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1277 computeResultType env expr args
1280 expr_ty = coreExprType (unTagBinders expr)
1281 expr_ty' = simplTy env expr_ty
1284 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1285 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1286 Just (_, res_ty) -> go res_ty args
1287 Nothing -> panic "computeResultType"