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 PprStyle ( PprStyle(..) )
30 import PprType ( GenType{-instance Outputable-} )
31 import PrelInfo ( realWorldStateTy )
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 Util ( isSingleton, panic, pprPanic, assertPanic )
45 The controlling flags, and what they do
46 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
50 -fsimplify = run the simplifier
51 -ffloat-inwards = runs the float lets inwards pass
52 -ffloat = runs the full laziness pass
53 (ToDo: rename to -ffull-laziness)
54 -fupdate-analysis = runs update analyser
55 -fstrictness = runs strictness analyser
56 -fsaturate-apps = saturates applications (eta expansion)
60 -ffloat-past-lambda = OK to do full laziness.
61 (ToDo: remove, as the full laziness pass is
62 useless without this flag, therefore
63 it is unnecessary. Just -ffull-laziness
66 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
67 let is strict or if the floating will expose
70 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
71 is a primop that cannot fail [simplifier].
73 -fcode-duplication-ok = allows the previous option to work on cases with
74 multiple branches [simplifier].
76 -flet-to-case = does let-to-case transformation [simplifier].
78 -fcase-of-case = does case of case transformation [simplifier].
80 -fpedantic-bottoms = does not allow:
81 case x of y -> e ===> e[x/y]
82 (which may turn bottom into non-bottom)
88 Inlining is one of the delicate aspects of the simplifier. By
89 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
90 the RHS of x's definition. Thus
92 let x = e in ...x... ===> let x = e in ...e...
94 We have two mechanisms for inlining:
96 1. Unconditional. The occurrence analyser has pinned an (OneOcc
97 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
98 certainly safe to inline this variable, and to drop its binding''.
99 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
100 happy to be duplicating code...) When it encounters such a beast, the
101 simplifer binds the variable to its RHS (in the id_env) and continues.
102 It doesn't even look at the RHS at that stage. It also drops the
105 2. Conditional. In all other situations, the simplifer simplifies
106 the RHS anyway, and keeps the new binding. It also binds the new
107 (cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
109 Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
110 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
111 the variable has an INLINE pragma on it). The idea is that anything
112 in the UnfoldEnv is safe to use, but also has an enclosing binding if
113 you decide not to use it.
117 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
120 At one time I thought it would be OK to put non-HNF unfoldings in for
121 variables which occur only once [if they got inlined at that
122 occurrence the RHS of the binding would become dead, so no duplication
123 would occur]. But consider:
126 f = \y -> ...y...y...y...
129 Now, it seems that @x@ appears only once, but even so it is NOT safe
130 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
131 duplicate the references to @x@.
133 Because of this, the "unconditional-inline" mechanism above is the
134 only way in which non-HNFs can get inlined.
139 When a variable has an INLINE pragma on it --- which includes wrappers
140 produced by the strictness analyser --- we treat it rather carefully.
142 For a start, we are careful not to substitute into its RHS, because
143 that might make it BIG, and the user said "inline exactly this", not
144 "inline whatever you get after inlining other stuff inside me". For
148 in {-# INLINE y #-} y = f 3
151 Here we don't want to substitute BIG for the (single) occurrence of f,
152 because then we'd duplicate BIG when we inline'd y. (Exception:
153 things in the UnfoldEnv with UnfoldAlways flags, which originated in
154 other INLINE pragmas.)
156 So, we clean out the UnfoldEnv of all GenForm inlinings before
157 going into such an RHS.
159 What about imports? They don't really matter much because we only
160 inline relatively small things via imports.
162 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
163 INLINE pragma. We also do this for the RHSs of recursive decls,
164 before looking at the recursive decls. That way we achieve the effect
165 of inlining a wrapper in the body of its worker, in the case of a
166 mutually-recursive worker/wrapper split.
169 %************************************************************************
171 \subsection[Simplify-simplExpr]{The main function: simplExpr}
173 %************************************************************************
175 At the top level things are a little different.
177 * No cloning (not allowed for exported Ids, unnecessary for the others)
179 * No floating. Case floating is obviously out. Let floating is
180 theoretically OK, but dangerous because of space leaks.
181 The long-distance let-floater lifts these lets.
184 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
186 simplTopBinds env [] = returnSmpl []
188 -- Dead code is now discarded by the occurrence analyser,
190 simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
191 | inlineUnconditionally ok_to_dup_code occ_info
193 new_env = extendIdEnvWithInlining env env binder rhs
195 simplTopBinds new_env binds
197 ok_to_dup_code = switchIsSet env SimplOkToDupCode
199 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
200 = -- No cloning necessary at top level
201 -- Process the binding
202 simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
204 new_env = case rhs' of
205 Var v -> extendIdEnvWithAtom env binder (VarArg v)
206 Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
207 other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
209 -- Process the other bindings
210 simplTopBinds new_env binds `thenSmpl` \ binds' ->
212 -- Glue together and return ...
213 -- We leave it to susequent occurrence analysis to throw away
214 -- an unused atom binding. This localises the decision about
215 -- discarding top-level bindings.
216 returnSmpl (NonRec in_id rhs' : binds')
218 simplTopBinds env (Rec pairs : binds)
219 = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
221 -- Process the other bindings
222 simplTopBinds new_env binds `thenSmpl` \ binds' ->
224 -- Glue together and return
225 returnSmpl (bind' : binds')
227 triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
228 -- No cloning necessary at top level
231 %************************************************************************
233 \subsection[Simplify-simplExpr]{The main function: simplExpr}
235 %************************************************************************
239 simplExpr :: SimplEnv
240 -> InExpr -> [OutArg]
244 The expression returned has the same meaning as the input expression
245 applied to the specified arguments.
250 Check if there's a macro-expansion, and if so rattle on. Otherwise do
251 the more sophisticated stuff.
254 simplExpr env (Var v) args
255 = case (lookupId env v) of
257 new_v = simplTyInId env v
259 completeVar env new_v args
263 ItsAnAtom (LitArg lit) -- A boring old literal
264 -- Paranoia check for args empty
266 [] -> returnSmpl (Lit lit)
267 other -> panic "simplExpr:coVar"
269 ItsAnAtom (VarArg var) -- More interesting! An id!
270 -- No need to substitute the type env here,
271 -- because we already have!
272 -> completeVar env var args
274 InlineIt id_env ty_env in_expr -- A macro-expansion
275 -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
282 simplExpr env (Lit l) [] = returnSmpl (Lit l)
284 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
288 Primitive applications are simple.
289 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
291 NB: Prim expects an empty argument list! (Because it should be
292 saturated and not higher-order. ADR)
295 simplExpr env (Prim op prim_args) args
298 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
301 completePrim env op' prim_args'
303 -- PrimOps just need any types in them renamed.
305 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
307 arg_tys' = map (simplTy env) arg_tys
308 result_ty' = simplTy env result_ty
310 CCallOp label is_asm may_gc arg_tys' result_ty'
312 simpl_op other_op = other_op
315 Constructor applications
316 ~~~~~~~~~~~~~~~~~~~~~~~~
317 Nothing to try here. We only reuse constructors when they appear as the
318 rhs of a let binding (see completeLetBinding).
321 simplExpr env (Con con con_args) args
322 = ASSERT( null args )
323 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
327 Applications are easy too:
328 ~~~~~~~~~~~~~~~~~~~~~~~~~~
329 Just stuff 'em in the arg stack
332 simplExpr env (App fun arg) args
333 = simplExpr env fun (simplArg env arg : args)
339 We only eta-reduce a type lambda if all type arguments in the body can
340 be eta-reduced. This requires us to collect up all tyvar parameters so
341 we can pass them all to @mkTyLamTryingEta@.
344 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
345 = -- ASSERT(not (isPrimType ty))
347 new_env = extendTyEnv env tyvar ty
349 tick TyBetaReduction `thenSmpl_`
350 simplExpr new_env body args
352 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
353 = do_tylambdas env [] tylam
355 do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
356 = -- Clone the type variable
357 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
359 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
361 do_tylambdas new_env (tyvar':tyvars') body
363 do_tylambdas env tyvars' body
364 = simplExpr env body [] `thenSmpl` \ body' ->
366 (if switchIsSet env SimplDoEtaReduction
367 then mkTyLamTryingEta
368 else mkTyLam) (reverse tyvars') body'
372 simplExpr env (Lam (TyBinder _) _) (_ : _)
373 = panic "simplExpr:TyLam with non-TyArg"
382 simplExpr env (Lam (ValBinder binder) body) args
383 | null leftover_binders
384 = -- The lambda is saturated (or over-saturated)
385 tick BetaReduction `thenSmpl_`
386 simplExpr env_for_enough_args body leftover_args
389 = -- Too few args to saturate the lambda
390 ASSERT( null leftover_args )
392 (if not (null args) -- ah, we must've gotten rid of some...
393 then tick BetaReduction
394 else returnSmpl (panic "BetaReduction")
397 simplLam env_for_too_few_args leftover_binders body
398 0 {- Guaranteed applied to at least 0 args! -}
401 (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
403 env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
405 env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
407 -- Since there aren't enough args the binders we are cancelling with
408 -- the args supplied are, in effect, ocurring inside a lambda.
409 -- So we modify their occurrence info to reflect this fact.
410 -- Example: (\ x y z -> e) p q
411 -- ==> (\z -> e[p/x, q/y])
412 -- but we should behave as if x and y are marked "inside lambda".
413 -- The occurrence analyser does not mark them so itself because then we
414 -- do badly on the very common case of saturated lambdas applications:
415 -- (\ x y z -> e) p q r
416 -- ==> e[p/x, q/y, r/z]
418 zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
419 | ((id, occ_info), arg) <- binder_args_pairs ]
421 collect_val_args :: InBinder -- Binder
422 -> [OutArg] -- Arguments
423 -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
424 [InBinder], -- Leftover binders (ToDo: a maybe)
425 [OutArg]) -- Leftover args
427 -- collect_val_args strips off the leading ValArgs from
428 -- the current arg list, returning them along with the
430 collect_val_args binder [] = ([], [binder], [])
431 collect_val_args binder (arg : args) | isValArg arg
432 = ([(binder,arg)], [], args)
435 collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
436 -- TyArg should never meet a Lam
445 simplExpr env (Let bind body) args
446 | not (switchIsSet env SimplNoLetFromApp) -- The common case
447 = simplBind env bind (\env -> simplExpr env body args)
448 (computeResultType env body args)
450 | otherwise -- No float from application
451 = simplBind env bind (\env -> simplExpr env body [])
452 (computeResultType env body []) `thenSmpl` \ let_expr' ->
453 returnSmpl (mkGenApp let_expr' args)
460 simplExpr env expr@(Case scrut alts) args
461 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
462 (computeResultType env expr args)
469 A special case we do:
471 scc "foo" (\x -> e) ===> \x -> scc "foo" e
473 Simon thinks it's OK, at least for lexical scoping; and it makes
474 interfaces change less (arities).
477 simplExpr env (SCC cc (Lam binder body)) args
478 = simplExpr env (Lam binder (SCC cc body)) args
481 Some other slightly turgid SCC tidying-up cases:
483 simplExpr env (SCC cc1 expr@(SCC _ _)) args
484 = simplExpr env expr args
485 -- the outer _scc_ serves no purpose
487 simplExpr env (SCC cc expr) args
488 | squashableDictishCcExpr cc expr
489 = simplExpr env expr args
490 -- the DICT-ish CC is no longer serving any purpose
493 NB: for other set-cost-centre we move arguments inside the body.
494 ToDo: check with Patrick that this is ok.
497 simplExpr env (SCC cost_centre body) args
499 new_env = setEnclosingCC env (EnclosingCC cost_centre)
501 simplExpr new_env body args `thenSmpl` \ body' ->
502 returnSmpl (SCC cost_centre body')
505 %************************************************************************
507 \subsection{Simplify RHS of a Let/Letrec}
509 %************************************************************************
511 simplRhsExpr does arity-expansion. That is, given:
513 * a right hand side /\ tyvars -> \a1 ... an -> e
514 * the information (stored in BinderInfo) that the function will always
515 be applied to at least k arguments
517 it transforms the rhs to
519 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
521 This is a Very Good Thing!
530 simplRhsExpr env binder@(id,occ_info) rhs
531 | dont_eta_expand rhs
532 = simplExpr rhs_env rhs []
534 | otherwise -- Have a go at eta expansion
535 = -- Deal with the big lambda part
536 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
538 lam_env = extendTyEnvList rhs_env (tyvars `zip` (mkTyVarTys tyvars'))
540 -- Deal with the little lambda part
541 -- Note that we call simplLam even if there are no binders, in case
542 -- it can do arity expansion.
543 simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
545 -- Put it back together
547 (if switchIsSet env SimplDoEtaReduction
548 then mkTyLamTryingEta
549 else mkTyLam) tyvars' lambda'
553 -- If you say {-# INLINE #-} then you get what's coming to you;
554 -- you are saying inline the rhs, please.
555 -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
556 rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
559 (uvars, tyvars, binders, body) = collectBinders rhs
561 min_no_of_args | not (null binders) && -- It's not a thunk
562 switchIsSet env SimplDoArityExpand -- Arity expansion on
563 = getBinderInfoArity occ_info - length binders
565 | otherwise -- Not a thunk
568 -- dont_eta_expand prevents eta expansion in silly situations.
569 -- For example, consider the defn
571 -- It would be silly to eta expand the "y", because it would just
572 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
573 -- and x was exported, then the defn won't be eliminated, so this
574 -- silly expand/reduce cycle will happen every time, which makes the
576 -- The solution is to not even try eta expansion unless the rhs looks
578 dont_eta_expand (Lit _) = True
579 dont_eta_expand (Var _) = True
580 dont_eta_expand (Con _ _) = True
581 dont_eta_expand (App f a)
582 | notValArg a = dont_eta_expand f
583 dont_eta_expand (Lam x b)
584 | notValBinder x = dont_eta_expand b
585 dont_eta_expand _ = False
589 %************************************************************************
591 \subsection{Simplify a lambda abstraction}
593 %************************************************************************
595 Simplify (\binders -> body) trying eta expansion and reduction, given that
596 the abstraction will always be applied to at least min_no_of_args.
599 simplLam env binders body min_no_of_args
600 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
601 null potential_extra_binder_tys || -- or ain't a function
602 no_of_extra_binders == 0 -- or no extra binders needed
603 = cloneIds env binders `thenSmpl` \ binders' ->
605 new_env = extendIdEnvWithClones env binders binders'
607 simplExpr new_env body [] `thenSmpl` \ body' ->
609 (if switchIsSet new_env SimplDoEtaReduction
610 then mkValLamTryingEta
611 else mkValLam) binders' body'
614 | otherwise -- Eta expansion possible
615 = tick EtaExpansion `thenSmpl_`
616 cloneIds env binders `thenSmpl` \ binders' ->
618 new_env = extendIdEnvWithClones env binders binders'
620 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
621 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
623 (if switchIsSet new_env SimplDoEtaReduction
624 then mkValLamTryingEta
625 else mkValLam) (binders' ++ extra_binders') body'
629 (potential_extra_binder_tys, res_ty)
630 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
631 -- Note: it's possible that simplLam will be applied to something
632 -- with a forall type. Eg when being applied to the rhs of
634 -- where wurble has a forall-type, but no big lambdas at the top.
635 -- We could be clever an insert new big lambdas, but we don't bother.
637 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
639 no_of_extra_binders = -- First, use the info about how many args it's
640 -- always applied to in its scope
643 -- Next, try seeing if there's a lambda hidden inside
648 -- Finally, see if it's a state transformer, in which
649 -- case we eta-expand on principle! This can waste work,
650 -- but usually doesn't
652 case potential_extra_binder_tys of
653 [ty] | ty `eqTy` realWorldStateTy -> 1
659 %************************************************************************
661 \subsection[Simplify-let]{Let-expressions}
663 %************************************************************************
666 simplBind :: SimplEnv
668 -> (SimplEnv -> SmplM OutExpr)
673 When floating cases out of lets, remember this:
675 let x* = case e of alts
678 where x* is sure to be demanded or e is a cheap operation that cannot
679 fail, e.g. unboxed addition. Here we should be prepared to duplicate
680 <small expr>. A good example:
689 p1 -> foldr c n (build e1)
690 p2 -> foldr c n (build e2)
692 NEW: We use the same machinery that we use for case-of-case to
693 *always* do case floating from let, that is we let bind and abstract
694 the original let body, and let the occurrence analyser later decide
695 whether the new let should be inlined or not. The example above
699 let join_body x' = foldr c n x'
701 p1 -> let x* = build e1
703 p2 -> let x* = build e2
706 note that join_body is a let-no-escape.
707 In this particular example join_body will later be inlined,
708 achieving the same effect.
709 ToDo: check this is OK with andy
714 -- Dead code is now discarded by the occurrence analyser,
716 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
717 | inlineUnconditionally ok_to_dup occ_info
718 = body_c (extendIdEnvWithInlining env env binder rhs)
721 -- It's important to try let-to-case before floating. Consider
723 -- let a*::Int = case v of {p1->e1; p2->e2}
726 -- (The * means that a is sure to be demanded.)
727 -- If we do case-floating first we get this:
731 -- p1-> let a*=e1 in k a
732 -- p2-> let a*=e2 in k a
734 -- Now watch what happens if we do let-to-case first:
736 -- case (case v of {p1->e1; p2->e2}) of
737 -- Int a# -> let a*=I# a# in b
739 -- let k = \a# -> let a*=I# a# in b
741 -- p1 -> case e1 of I# a# -> k a#
742 -- p1 -> case e1 of I# a# -> k a#
744 -- The latter is clearly better. (Remember the reboxing let-decl
745 -- for a is likely to go away, because after all b is strict in a.)
747 | will_be_demanded &&
749 type_ok_for_let_to_case rhs_ty &&
750 not (manifestlyWHNF rhs)
751 -- note: no "manifestlyBottom rhs" in there... (comment below)
752 = tick Let2Case `thenSmpl_`
753 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
754 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
756 We do not do let to case for WHNFs, e.g.
762 as this is less efficient.
763 but we don't mind doing let-to-case for "bottom", as that
765 allow us to remove more dead code, if anything:
768 case error of x -> ...
772 Notice that let to case occurs only if x is used strictly in
773 its body (obviously).
776 | (will_be_demanded && not no_float) ||
777 always_float_let_from_let ||
778 floatExposesHNF float_lets float_primops ok_to_dup rhs
779 = try_float env rhs body_c
782 = done_float env rhs body_c
785 will_be_demanded = willBeDemanded (getIdDemandInfo id)
788 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
789 float_primops = switchIsSet env SimplOkToFloatPrimOps
790 ok_to_dup = switchIsSet env SimplOkToDupCode
791 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
792 try_let_to_case = switchIsSet env SimplLetToCase
793 no_float = switchIsSet env SimplNoLetFromStrictLet
795 -------------------------------------------
796 done_float env rhs body_c
797 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
798 completeLet env binder rhs rhs' body_c body_ty
800 ---------------------------------------
801 try_float env (Let bind rhs) body_c
802 = tick LetFloatFromLet `thenSmpl_`
803 simplBind env (fix_up_demandedness will_be_demanded bind)
804 (\env -> try_float env rhs body_c) body_ty
806 try_float env (Case scrut alts) body_c
807 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
808 = tick CaseFloatFromLet `thenSmpl_`
810 -- First, bind large let-body if necessary
811 if no_need_to_bind_large_body then
812 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
814 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
816 body_c' = \env -> simplExpr env new_body []
818 simplCase env scrut alts
819 (\env rhs -> try_float env rhs body_c')
820 body_ty `thenSmpl` \ case_expr ->
822 returnSmpl (Let extra_binding case_expr)
824 no_need_to_bind_large_body
825 = ok_to_dup || isSingleton (nonErrorRHSs alts)
827 try_float env other_rhs body_c = done_float env other_rhs body_c
833 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
834 on and it'll expose a HNF), and bang the whole resulting mess together
837 1. Any "macros" should be expanded. The main application of this
846 Here we would like the single call to g to be inlined.
848 We can spot this easily, because g will be tagged as having just one
849 occurrence. The "inlineUnconditionally" predicate is just what we want.
851 A worry: could this lead to non-termination? For example:
860 Here, f and g call each other (just once) and neither is used elsewhere.
863 * the occurrence analyser will drop any (sub)-group that isn't used at
866 * If the group is used outside itself (ie in the "in" part), then there
869 ** IMPORTANT: check that NewOccAnal has the property that a group of
870 bindings like the above has f&g dropped.! ***
873 2. We'd also like to pull out any top-level let(rec)s from the
877 f = let h = ... in \x -> ....h...f...h...
883 f = \x -> ....h...f...h...
887 But floating cases is less easy? (Don't for now; ToDo?)
890 3. We'd like to arrange that the RHSs "know" about members of the
891 group that are bound to constructors. For example:
895 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
896 /= a b = unpack tuple a, unpack tuple b, call f
899 here, by knowing about d.Eq in f's rhs, one could get rid of
900 the case (and break out the recursion completely).
901 [This occurred with more aggressive inlining threshold (4),
902 nofib/spectral/knights]
905 1: we simplify constructor rhss first.
906 2: we record the "known constructors" in the environment
907 3: we simplify the other rhss, with the knowledge about the constructors
912 simplBind env (Rec pairs) body_c body_ty
913 = -- Do floating, if necessary
914 (if float_lets || always_float_let_from_let
916 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
917 returnSmpl (concat floated_pairs_s)
920 ) `thenSmpl` \ floated_pairs ->
922 binders = map fst floated_pairs
924 cloneIds env binders `thenSmpl` \ ids' ->
926 env_w_clones = extendIdEnvWithClones env binders ids'
927 triples = ids' `zip` floated_pairs
930 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
932 body_c new_env `thenSmpl` \ body' ->
934 returnSmpl (Let binding body')
937 ------------ Floating stuff -------------------
939 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
940 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
944 pairs_s = float_pair (binder,rhs)
947 [_] -> returnSmpl pairs_s
949 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
950 -- It's important to increment the tick counts if we
951 -- do any floating. A situation where this turns out
952 -- to be important is this:
953 -- Float in produces:
954 -- letrec x = let y = Ey in Ex
956 -- Now floating gives this:
960 --- We now want to iterate once more in case Ey doesn't
961 -- mention x, in which case the y binding can be pulled
962 -- out as an enclosing let(rec), which in turn gives
963 -- the strictness analyser more chance.
966 float_pairs pairs = concat (map float_pair pairs)
968 float_pair (binder, rhs)
969 | always_float_let_from_let ||
970 floatExposesHNF True False False rhs
971 = (binder,rhs') : pairs'
976 (pairs', rhs') = do_float rhs
978 -- Float just pulls out any top-level let(rec) bindings
979 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
980 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
982 (pairs', body') = do_float body
983 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
985 (pairs', body') = do_float body
986 do_float other = ([], other)
988 simplRecursiveGroup env triples
989 = -- Toss out all the dead pairs? No, there shouldn't be any!
990 -- Dead code is discarded by the occurrence analyser
992 -- Separate the live triples into "inline"able and
993 -- "ordinary" We're paranoid about duplication!
994 (inline_triples, ordinary_triples)
995 = partition is_inline_triple triples
997 is_inline_triple (_, ((_,occ_info),_))
998 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1000 -- Now add in the inline_pairs info (using "env_w_clones"),
1001 -- so that we will save away suitably-clone-laden envs
1002 -- inside the InlineIts...).
1004 -- NOTE ALSO that we tie a knot here, because the
1005 -- saved-away envs must also include these very inlinings
1006 -- (they aren't stored anywhere else, and a late one might
1007 -- be used in an early one).
1009 env_w_inlinings = foldl add_inline env inline_triples
1011 add_inline env (id', (binder,rhs))
1012 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1014 -- Separate the remaining bindings into the ones which
1015 -- need to be dealt with first (the "early" ones)
1016 -- and the others (the "late" ones)
1017 (early_triples, late_triples)
1018 = partition is_early_triple ordinary_triples
1020 is_early_triple (_, (_, Con _ _)) = True
1021 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1023 -- Process the early bindings first
1024 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1026 -- Now further extend the environment to record our knowledge
1027 -- about the form of the binders bound in the constructor bindings
1029 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1030 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1032 -- Now process the non-constructor bindings
1033 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1037 binding = Rec (map snd early_triples' ++ map snd late_triples')
1039 returnSmpl (binding, env_w_early_info)
1042 do_one_binding env (id', (binder,rhs))
1043 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1044 returnSmpl (binder, (id', rhs'))
1048 @completeLet@ looks at the simplified post-floating RHS of the
1049 let-expression, and decides what to do. There's one interesting
1050 aspect to this, namely constructor reuse. Consider
1056 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1057 bit on the compiler technology, but in general I believe not. For
1058 example, here's some code from a real program:
1060 const.Int.max.wrk{-s2516-} =
1061 \ upk.s3297# upk.s3298# ->
1065 a.s3299 = I#! upk.s3297#
1067 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1068 _LT -> I#! upk.s3298#
1073 The a.s3299 really isn't doing much good. We'd be better off inlining
1074 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1076 So the current strategy is to inline all known-form constructors, and
1077 only do the reverse (turn a constructor application back into a
1078 variable) when we find a let-expression:
1082 ... (let y = C a1 .. an in ...) ...
1084 where it is always good to ditch the binding for y, and replace y by
1085 x. That's just what completeLetBinding does.
1091 -> InExpr -- Original RHS
1092 -> OutExpr -- The simplified RHS
1093 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1094 -> OutType -- Type of body
1097 completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
1099 -- See if RHS is an atom, or a reusable constructor
1100 | maybeToBool maybe_atomic_rhs
1102 new_env = extendIdEnvWithAtom env binder rhs_atom
1104 tick atom_tick_type `thenSmpl_`
1107 -- Maybe the rhs is an application of error, and sure to be demanded
1108 | will_be_demanded &&
1109 maybeToBool maybe_error_app
1110 = tick CaseOfError `thenSmpl_`
1111 returnSmpl retyped_error_app
1115 = cloneId env binder `thenSmpl` \ id' ->
1117 env1 = extendIdEnvWithClone env binder id'
1118 new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
1120 body_c new_env `thenSmpl` \ body' ->
1121 returnSmpl (Let (NonRec id' new_rhs) body')
1124 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1125 try_to_reuse_constr = switchIsSet env SimplReuseCon
1127 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1129 maybe_atomic_rhs :: Maybe (OutArg, TickType)
1130 -- If the RHS is atomic, we return Just (atom, tick type)
1131 -- otherwise Nothing
1135 Var var -> Just (VarArg var, AtomicRhs)
1137 Lit lit | not (isNoRepLit lit)
1138 -> Just (LitArg lit, AtomicRhs)
1141 | try_to_reuse_constr
1145 --- ...(let w = C same-args in ...)...
1146 -- Then use v instead of w. This may save
1147 -- re-constructing an existing constructor.
1148 -> case (lookForConstructor env con con_args) of
1150 Just var -> Just (VarArg var, ConReused)
1154 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1155 Just retyped_error_app = maybe_error_app
1158 %************************************************************************
1160 \subsection[Simplify-atoms]{Simplifying atoms}
1162 %************************************************************************
1165 simplArg :: SimplEnv -> InArg -> OutArg
1167 simplArg env (LitArg lit) = LitArg lit
1168 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1170 simplArg env (VarArg id)
1171 | isLocallyDefined id
1172 = case lookupId env id of
1173 Just (ItsAnAtom atom) -> atom
1174 Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1175 Nothing -> VarArg id -- Must be an uncloned thing
1178 = -- Not locally defined, so no change
1183 %************************************************************************
1185 \subsection[Simplify-quickies]{Some local help functions}
1187 %************************************************************************
1191 -- fix_up_demandedness switches off the willBeDemanded Info field
1192 -- for bindings floated out of a non-demanded let
1193 fix_up_demandedness True {- Will be demanded -} bind
1194 = bind -- Simple; no change to demand info needed
1195 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1196 = NonRec (un_demandify binder) rhs
1197 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1198 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1200 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1202 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1203 is_cheap_prim_app other = False
1205 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1206 computeResultType env expr args
1209 expr_ty = coreExprType (unTagBinders expr)
1210 expr_ty' = simplTy env expr_ty
1213 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1214 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1215 Just (_, res_ty) -> go res_ty args
1216 Nothing -> panic "computeResultType"