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
11 import Pretty -- these are for debugging only
17 import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..),
18 primOpOkForSpeculation, PrimOp(..), PrimRep,
20 IF_ATTACK_PRAGMAS(COMMA realWorldTy)
21 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
22 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
24 import Type ( maybeDataTyCon, mkTyVarTy, applyTy,
25 splitTyArgs, splitTypeWithDictsAsArgs,
26 maybeUnpackFunTy, isPrimType
28 import Literal ( isNoRepLit, Literal(..) )
30 import CmdLineOpts ( SimplifierSwitch(..) )
31 import ConFold ( completePrim )
34 import Maybes ( Maybe(..), catMaybes, maybeToBool )
37 import SimplVar ( completeVar )
41 The controlling flags, and what they do
42 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
46 -fsimplify = run the simplifier
47 -ffloat-inwards = runs the float lets inwards pass
48 -ffloat = runs the full laziness pass
49 (ToDo: rename to -ffull-laziness)
50 -fupdate-analysis = runs update analyser
51 -fstrictness = runs strictness analyser
52 -fsaturate-apps = saturates applications (eta expansion)
56 -ffloat-past-lambda = OK to do full laziness.
57 (ToDo: remove, as the full laziness pass is
58 useless without this flag, therefore
59 it is unnecessary. Just -ffull-laziness
62 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
63 let is strict or if the floating will expose
66 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
67 is a primop that cannot fail [simplifier].
69 -fcode-duplication-ok = allows the previous option to work on cases with
70 multiple branches [simplifier].
72 -flet-to-case = does let-to-case transformation [simplifier].
74 -fcase-of-case = does case of case transformation [simplifier].
76 -fpedantic-bottoms = does not allow:
77 case x of y -> e ===> e[x/y]
78 (which may turn bottom into non-bottom)
84 Inlining is one of the delicate aspects of the simplifier. By
85 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
86 the RHS of x's definition. Thus
88 let x = e in ...x... ===> let x = e in ...e...
90 We have two mechanisms for inlining:
92 1. Unconditional. The occurrence analyser has pinned an (OneOcc
93 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
94 certainly safe to inline this variable, and to drop its binding''.
95 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
96 happy to be duplicating code...) When it encounters such a beast, the
97 simplifer binds the variable to its RHS (in the id_env) and continues.
98 It doesn't even look at the RHS at that stage. It also drops the
101 2. Conditional. In all other situations, the simplifer simplifies
102 the RHS anyway, and keeps the new binding. It also binds the new
103 (cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
105 Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
106 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
107 the variable has an INLINE pragma on it). The idea is that anything
108 in the UnfoldEnv is safe to use, but also has an enclosing binding if
109 you decide not to use it.
113 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
116 At one time I thought it would be OK to put non-HNF unfoldings in for
117 variables which occur only once [if they got inlined at that
118 occurrence the RHS of the binding would become dead, so no duplication
119 would occur]. But consider:
122 f = \y -> ...y...y...y...
125 Now, it seems that @x@ appears only once, but even so it is NOT safe to put @x@
126 in the UnfoldEnv, because @f@ will be inlined, and will duplicate the references to
129 Becuase of this, the "unconditional-inline" mechanism above is the only way
130 in which non-HNFs can get inlined.
135 When a variable has an INLINE pragma on it --- which includes wrappers
136 produced by the strictness analyser --- we treat it rather carefully.
138 For a start, we are careful not to substitute into its RHS, because
139 that might make it BIG, and the user said "inline exactly this", not
140 "inline whatever you get after inlining other stuff inside me". For
144 in {-# INLINE y #-} y = f 3
147 Here we don't want to substitute BIG for the (single) occurrence of f,
148 because then we'd duplicate BIG when we inline'd y. (Exception:
149 things in the UnfoldEnv with UnfoldAlways flags, which originated in
150 other INLINE pragmas.)
152 So, we clean out the UnfoldEnv of all GenForm inlinings before
153 going into such an RHS.
155 What about imports? They don't really matter much because we only
156 inline relatively small things via imports.
158 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
159 INLINE pragma. We also do this for the RHSs of recursive decls,
160 before looking at the recursive decls. That way we achieve the effect
161 of inlining a wrapper in the body of its worker, in the case of a
162 mutually-recursive worker/wrapper split.
165 %************************************************************************
167 \subsection[Simplify-simplExpr]{The main function: simplExpr}
169 %************************************************************************
171 At the top level things are a little different.
173 * No cloning (not allowed for exported Ids, unnecessary for the others)
175 * No floating. Case floating is obviously out. Let floating is
176 theoretically OK, but dangerous because of space leaks.
177 The long-distance let-floater lifts these lets.
180 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
182 simplTopBinds env [] = returnSmpl []
184 -- Dead code is now discarded by the occurrence analyser,
186 simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
187 | inlineUnconditionally ok_to_dup_code occ_info
188 = --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) (
190 new_env = extendIdEnvWithInlining env env binder rhs
192 simplTopBinds new_env binds
195 ok_to_dup_code = switchIsSet env SimplOkToDupCode
197 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
198 = -- No cloning necessary at top level
199 -- Process the binding
200 simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
202 new_env = case rhs' of
203 Var var -> extendIdEnvWithAtom env binder (VarArg var)
204 Lit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (LitArg lit)
205 other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
207 --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug 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')
219 simplTopBinds env (Rec pairs : binds)
220 = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
222 --pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) (
224 -- Process the other bindings
225 simplTopBinds new_env binds `thenSmpl` \ binds' ->
227 -- Glue together and return
228 returnSmpl (bind' : binds')
231 triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
232 -- No cloning necessary at top level
235 %************************************************************************
237 \subsection[Simplify-simplExpr]{The main function: simplExpr}
239 %************************************************************************
243 simplExpr :: SimplEnv
244 -> InExpr -> [OutArg]
248 The expression returned has the same meaning as the input expression
249 applied to the specified arguments.
254 Check if there's a macro-expansion, and if so rattle on. Otherwise
255 do the more sophisticated stuff.
258 simplExpr env (Var v) args
259 = --pprTrace "simplExpr:Var:" (ppr PprDebug v) (
260 case lookupId env v of
262 new_v = simplTyInId env v
264 completeVar env new_v args
268 ItsAnAtom (LitArg lit) -- A boring old literal
269 -- Paranoia check for args empty
271 [] -> returnSmpl (Lit lit)
272 other -> panic "simplExpr:coVar"
274 ItsAnAtom (VarArg var) -- More interesting! An id!
275 -- No need to substitute the type env here,
276 -- because we already have!
277 -> completeVar env var args
279 InlineIt id_env ty_env in_expr -- A macro-expansion
280 -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
288 simplExpr env (Lit l) [] = returnSmpl (Lit l)
289 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
292 Primitive applications are simple.
293 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
295 NB: Prim expects an empty argument list! (Because it should be
296 saturated and not higher-order. ADR)
299 simplExpr env (Prim op tys prim_args) args
302 tys' = [simplTy env ty | ty <- tys]
303 prim_args' = [simplAtom env prim_arg | prim_arg <- prim_args]
306 completePrim env op' tys' prim_args'
308 -- PrimOps just need any types in them renamed.
310 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
312 arg_tys' = map (simplTy env) arg_tys
313 result_ty' = simplTy env result_ty
315 CCallOp label is_asm may_gc arg_tys' result_ty'
317 simpl_op other_op = other_op
320 Constructor applications
321 ~~~~~~~~~~~~~~~~~~~~~~~~
322 Nothing to try here. We only reuse constructors when they appear as the
323 rhs of a let binding (see completeLetBinding).
326 simplExpr env (Con con tys con_args) args
327 = ASSERT( null args )
328 returnSmpl (Con con tys' con_args')
330 con_args' = [simplAtom env con_arg | con_arg <- con_args]
331 tys' = [simplTy env ty | ty <- tys]
335 Applications are easy too:
336 ~~~~~~~~~~~~~~~~~~~~~~~~~~
337 Just stuff 'em in the arg stack
340 simplExpr env (App fun arg) args
341 = simplExpr env fun (ValArg (simplAtom env arg) : args)
343 simplExpr env (CoTyApp fun ty) args
344 = simplExpr env fun (TypeArg (simplTy env ty) : args)
350 We only eta-reduce a type lambda if all type arguments in the body can
351 be eta-reduced. This requires us to collect up all tyvar parameters so
352 we can pass them all to @mkCoTyLamTryingEta@.
355 simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
356 = -- ASSERT(not (isPrimType ty))
358 new_env = extendTyEnv env tyvar ty
360 tick TyBetaReduction `thenSmpl_`
361 simplExpr new_env body args
363 simplExpr env tylam@(CoTyLam tyvar body) []
364 = do_tylambdas env [] tylam
366 do_tylambdas env tyvars' (CoTyLam tyvar body)
367 = -- Clone the type variable
368 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
370 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
372 do_tylambdas new_env (tyvar':tyvars') body
374 do_tylambdas env tyvars' body
375 = simplExpr env body [] `thenSmpl` \ body' ->
377 (if switchIsSet env SimplDoEtaReduction
378 then mkCoTyLamTryingEta
379 else mkCoTyLam) (reverse tyvars') body'
382 simplExpr env (CoTyLam tyvar body) (ValArg _ : _)
383 = panic "simplExpr:CoTyLam ValArg"
391 simplExpr env (Lam binder body) args
392 | null leftover_binders
393 = -- The lambda is saturated (or over-saturated)
394 tick BetaReduction `thenSmpl_`
395 simplExpr env_for_enough_args body leftover_args
398 = -- Too few args to saturate the lambda
399 ASSERT( null leftover_args )
401 (if not (null args) -- ah, we must've gotten rid of some...
402 then tick BetaReduction
403 else returnSmpl (panic "BetaReduction")
406 simplLam env_for_too_few_args leftover_binders body
407 0 {- Guaranteed applied to at least 0 args! -}
410 (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args [binder] args
412 env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
414 env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
416 -- Since there aren't enough args the binders we are cancelling with
417 -- the args supplied are, in effect, ocurring inside a lambda.
418 -- So we modify their occurrence info to reflect this fact.
419 -- Example: (\ x y z -> e) p q
420 -- ==> (\z -> e[p/x, q/y])
421 -- but we should behave as if x and y are marked "inside lambda".
422 -- The occurrence analyser does not mark them so itself because then we
423 -- do badly on the very common case of saturated lambdas applications:
424 -- (\ x y z -> e) p q r
425 -- ==> e[p/x, q/y, r/z]
427 zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
428 | ((id, occ_info), arg) <- binder_args_pairs ]
430 collect_val_args :: [InBinder] -- Binders
431 -> [OutArg] -- Arguments
432 -> ([(InBinder,OutAtom)], -- Binder,arg pairs
433 [InBinder], -- Leftover binders
434 [OutArg]) -- Leftover args
436 -- collect_val_args strips off the leading ValArgs from
437 -- the current arg list, returning them along with the
439 collect_val_args [] args = ([], [], args)
440 collect_val_args binders [] = ([], binders, [])
441 collect_val_args (binder:binders) (ValArg val_arg : args)
442 = ((binder,val_arg):rest_pairs, leftover_binders, leftover_args)
444 (rest_pairs, leftover_binders, leftover_args) = collect_val_args binders args
446 collect_val_args (binder:binders) (other_val_arg : args) = panic "collect_val_args"
447 -- TypeArg should never meet a Lam
455 simplExpr env (Let bind body) args
456 | not (switchIsSet env SimplNoLetFromApp) -- The common case
457 = simplBind env bind (\env -> simplExpr env body args)
458 (computeResultType env body args)
460 | otherwise -- No float from application
461 = simplBind env bind (\env -> simplExpr env body [])
462 (computeResultType env body []) `thenSmpl` \ let_expr' ->
463 returnSmpl (mkGenApp let_expr' args)
470 simplExpr env expr@(Case scrut alts) args
471 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
472 (computeResultType env expr args)
479 A special case we do:
481 scc "foo" (\x -> e) ===> \x -> scc "foo" e
483 Simon thinks it's OK, at least for lexical scoping; and it makes
484 interfaces change less (arities).
487 simplExpr env (SCC cc (Lam binder body)) args
488 = simplExpr env (Lam binder (SCC cc body)) args
490 simplExpr env (SCC cc (CoTyLam tyvar body)) args
491 = simplExpr env (CoTyLam tyvar (SCC cc body)) args
494 Some other slightly turgid SCC tidying-up cases:
496 simplExpr env (SCC cc1 expr@(SCC _ _)) args
497 = simplExpr env expr args
498 -- the outer _scc_ serves no purpose
500 simplExpr env (SCC cc expr) args
501 | squashableDictishCcExpr cc expr
502 = simplExpr env expr args
503 -- the DICT-ish CC is no longer serving any purpose
506 NB: for other set-cost-centre we move arguments inside the body.
507 ToDo: check with Patrick that this is ok.
510 simplExpr env (SCC cost_centre body) args
512 new_env = setEnclosingCC env (EnclosingCC cost_centre)
514 simplExpr new_env body args `thenSmpl` \ body' ->
515 returnSmpl (SCC cost_centre body')
518 %************************************************************************
520 \subsection{Simplify RHS of a Let/Letrec}
522 %************************************************************************
524 simplRhsExpr does arity-expansion. That is, given:
526 * a right hand side /\ tyvars -> \a1 ... an -> e
527 * the information (stored in BinderInfo) that the function will always
528 be applied to at least k arguments
530 it transforms the rhs to
532 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
534 This is a Very Good Thing!
543 simplRhsExpr env binder@(id,occ_info) rhs
544 | dont_eta_expand rhs
545 = simplExpr rhs_env rhs []
547 | otherwise -- Have a go at eta expansion
548 = -- Deal with the big lambda part
549 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
551 lam_env = extendTyEnvList rhs_env (tyvars `zip` (map mkTyVarTy tyvars'))
553 -- Deal with the little lambda part
554 -- Note that we call simplLam even if there are no binders, in case
555 -- it can do arity expansion.
556 simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
558 -- Put it back together
560 (if switchIsSet env SimplDoEtaReduction
561 then mkCoTyLamTryingEta
562 else mkCoTyLam) tyvars' lambda'
566 -- If you say {-# INLINE #-} then you get what's coming to you;
567 -- you are saying inline the rhs, please.
568 -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
569 rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
572 (uvars, tyvars, binders, body) = digForLambdas rhs
574 min_no_of_args | not (null binders) && -- It's not a thunk
575 switchIsSet env SimplDoArityExpand -- Arity expansion on
576 = getBinderInfoArity occ_info - length binders
578 | otherwise -- Not a thunk
581 -- dont_eta_expand prevents eta expansion in silly situations.
582 -- For example, consider the defn
584 -- It would be silly to eta expand the "y", because it would just
585 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
586 -- and x was exported, then the defn won't be eliminated, so this
587 -- silly expand/reduce cycle will happen every time, which makes the
589 -- The solution is to not even try eta expansion unless the rhs looks
591 dont_eta_expand (Lit _) = True
592 dont_eta_expand (Var _) = True
593 dont_eta_expand (CoTyApp f _) = dont_eta_expand f
594 dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
595 dont_eta_expand (Con _ _ _) = True
596 dont_eta_expand _ = False
600 %************************************************************************
602 \subsection{Simplify a lambda abstraction}
604 %************************************************************************
606 Simplify (\binders -> body) trying eta expansion and reduction, given that
607 the abstraction will always be applied to at least min_no_of_args.
610 simplLam env binders body min_no_of_args
611 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
612 null potential_extra_binder_tys || -- or ain't a function
613 no_of_extra_binders == 0 -- or no extra binders needed
614 = cloneIds env binders `thenSmpl` \ binders' ->
616 new_env = extendIdEnvWithClones env binders binders'
618 simplExpr new_env body [] `thenSmpl` \ body' ->
620 (if switchIsSet new_env SimplDoEtaReduction
621 then mkCoLamTryingEta
622 else mkValLam) binders' body'
625 | otherwise -- Eta expansion possible
626 = tick EtaExpansion `thenSmpl_`
627 cloneIds env binders `thenSmpl` \ binders' ->
629 new_env = extendIdEnvWithClones env binders binders'
631 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
632 simplExpr new_env body (map (ValArg.VarArg) extra_binders') `thenSmpl` \ body' ->
634 (if switchIsSet new_env SimplDoEtaReduction
635 then mkCoLamTryingEta
636 else mkValLam) (binders' ++ extra_binders') body'
640 (potential_extra_binder_tys, res_ty)
641 = splitTyArgs (simplTy env (coreExprType (unTagBinders body)))
642 -- Note: it's possible that simplLam will be applied to something
643 -- with a forall type. Eg when being applied to the rhs of
645 -- where wurble has a forall-type, but no big lambdas at the top.
646 -- We could be clever an insert new big lambdas, but we don't bother.
648 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
650 no_of_extra_binders = -- First, use the info about how many args it's
651 -- always applied to in its scope
654 -- Next, try seeing if there's a lambda hidden inside
659 -- Finally, see if it's a state transformer, in which
660 -- case we eta-expand on principle! This can waste work,
661 -- but usually doesn't
663 case potential_extra_binder_tys of
664 [ty] | ty == realWorldStateTy -> 1
670 %************************************************************************
672 \subsection[Simplify-let]{Let-expressions}
674 %************************************************************************
677 simplBind :: SimplEnv
679 -> (SimplEnv -> SmplM OutExpr)
684 When floating cases out of lets, remember this:
686 let x* = case e of alts
689 where x* is sure to be demanded or e is a cheap operation that cannot
690 fail, e.g. unboxed addition. Here we should be prepared to duplicate
691 <small expr>. A good example:
700 p1 -> foldr c n (build e1)
701 p2 -> foldr c n (build e2)
703 NEW: We use the same machinery that we use for case-of-case to
704 *always* do case floating from let, that is we let bind and abstract
705 the original let body, and let the occurrence analyser later decide
706 whether the new let should be inlined or not. The example above
710 let join_body x' = foldr c n x'
712 p1 -> let x* = build e1
714 p2 -> let x* = build e2
717 note that join_body is a let-no-escape.
718 In this particular example join_body will later be inlined,
719 achieving the same effect.
720 ToDo: check this is OK with andy
725 -- Dead code is now discarded by the occurrence analyser,
727 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
728 | inlineUnconditionally ok_to_dup occ_info
729 = body_c (extendIdEnvWithInlining env env binder rhs)
732 -- It's important to try let-to-case before floating. Consider
734 -- let a*::Int = case v of {p1->e1; p2->e2}
737 -- (The * means that a is sure to be demanded.)
738 -- If we do case-floating first we get this:
742 -- p1-> let a*=e1 in k a
743 -- p2-> let a*=e2 in k a
745 -- Now watch what happens if we do let-to-case first:
747 -- case (case v of {p1->e1; p2->e2}) of
748 -- Int a# -> let a*=I# a# in b
750 -- let k = \a# -> let a*=I# a# in b
752 -- p1 -> case e1 of I# a# -> k a#
753 -- p1 -> case e1 of I# a# -> k a#
755 -- The latter is clearly better. (Remember the reboxing let-decl
756 -- for a is likely to go away, because after all b is strict in a.)
758 | will_be_demanded &&
760 type_ok_for_let_to_case rhs_ty &&
761 not (manifestlyWHNF rhs)
762 -- note: no "manifestlyBottom rhs" in there... (comment below)
763 = tick Let2Case `thenSmpl_`
764 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
765 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
767 We do not do let to case for WHNFs, e.g.
773 as this is less efficient.
774 but we don't mind doing let-to-case for "bottom", as that
776 allow us to remove more dead code, if anything:
779 case error of x -> ...
783 Notice that let to case occurs only if x is used strictly in
784 its body (obviously).
787 | (will_be_demanded && not no_float) ||
788 always_float_let_from_let ||
789 floatExposesHNF float_lets float_primops ok_to_dup rhs
790 = try_float env rhs body_c
793 = done_float env rhs body_c
796 will_be_demanded = willBeDemanded (getIdDemandInfo id)
799 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
800 float_primops = switchIsSet env SimplOkToFloatPrimOps
801 ok_to_dup = switchIsSet env SimplOkToDupCode
802 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
803 try_let_to_case = switchIsSet env SimplLetToCase
804 no_float = switchIsSet env SimplNoLetFromStrictLet
806 -------------------------------------------
807 done_float env rhs body_c
808 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
809 completeLet env binder rhs rhs' body_c body_ty
811 ---------------------------------------
812 try_float env (Let bind rhs) body_c
813 = tick LetFloatFromLet `thenSmpl_`
814 simplBind env (fix_up_demandedness will_be_demanded bind)
815 (\env -> try_float env rhs body_c) body_ty
817 try_float env (Case scrut alts) body_c
818 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
819 = tick CaseFloatFromLet `thenSmpl_`
821 -- First, bind large let-body if necessary
822 if no_need_to_bind_large_body then
823 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
825 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
827 body_c' = \env -> simplExpr env new_body []
829 simplCase env scrut alts
830 (\env rhs -> try_float env rhs body_c')
831 body_ty `thenSmpl` \ case_expr ->
833 returnSmpl (Let extra_binding case_expr)
835 no_need_to_bind_large_body
836 = ok_to_dup || isSingleton (nonErrorRHSs alts)
838 try_float env other_rhs body_c = done_float env other_rhs body_c
844 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
845 on and it'll expose a HNF), and bang the whole resulting mess together
848 1. Any "macros" should be expanded. The main application of this
857 Here we would like the single call to g to be inlined.
859 We can spot this easily, because g will be tagged as having just one
860 occurrence. The "inlineUnconditionally" predicate is just what we want.
862 A worry: could this lead to non-termination? For example:
871 Here, f and g call each other (just once) and neither is used elsewhere.
874 * the occurrence analyser will drop any (sub)-group that isn't used at
877 * If the group is used outside itself (ie in the "in" part), then there
880 ** IMPORTANT: check that NewOccAnal has the property that a group of
881 bindings like the above has f&g dropped.! ***
884 2. We'd also like to pull out any top-level let(rec)s from the
888 f = let h = ... in \x -> ....h...f...h...
894 f = \x -> ....h...f...h...
898 But floating cases is less easy? (Don't for now; ToDo?)
901 3. We'd like to arrange that the RHSs "know" about members of the
902 group that are bound to constructors. For example:
906 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
907 /= a b = unpack tuple a, unpack tuple b, call f
910 here, by knowing about d.Eq in f's rhs, one could get rid of
911 the case (and break out the recursion completely).
912 [This occurred with more aggressive inlining threshold (4),
913 nofib/spectral/knights]
916 1: we simplify constructor rhss first.
917 2: we record the "known constructors" in the environment
918 3: we simplify the other rhss, with the knowledge about the constructors
923 simplBind env (Rec pairs) body_c body_ty
924 = -- Do floating, if necessary
925 (if float_lets || always_float_let_from_let
927 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
928 returnSmpl (concat floated_pairs_s)
931 ) `thenSmpl` \ floated_pairs ->
933 binders = map fst floated_pairs
935 cloneIds env binders `thenSmpl` \ ids' ->
937 env_w_clones = extendIdEnvWithClones env binders ids'
938 triples = ids' `zip` floated_pairs
941 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
943 body_c new_env `thenSmpl` \ body' ->
945 returnSmpl (Let binding body')
948 ------------ Floating stuff -------------------
950 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
951 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
955 pairs_s = float_pair (binder,rhs)
958 [_] -> returnSmpl pairs_s
960 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
961 -- It's important to increment the tick counts if we
962 -- do any floating. A situation where this turns out
963 -- to be important is this:
964 -- Float in produces:
965 -- letrec x = let y = Ey in Ex
967 -- Now floating gives this:
971 --- We now want to iterate once more in case Ey doesn't
972 -- mention x, in which case the y binding can be pulled
973 -- out as an enclosing let(rec), which in turn gives
974 -- the strictness analyser more chance.
977 float_pairs pairs = concat (map float_pair pairs)
979 float_pair (binder, rhs)
980 | always_float_let_from_let ||
981 floatExposesHNF True False False rhs
982 = (binder,rhs') : pairs'
987 (pairs', rhs') = do_float rhs
989 -- Float just pulls out any top-level let(rec) bindings
990 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
991 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
993 (pairs', body') = do_float body
994 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
996 (pairs', body') = do_float body
997 do_float other = ([], other)
999 simplRecursiveGroup env triples
1000 = -- Toss out all the dead pairs? No, there shouldn't be any!
1001 -- Dead code is discarded by the occurrence analyser
1003 -- Separate the live triples into "inline"able and
1004 -- "ordinary" We're paranoid about duplication!
1005 (inline_triples, ordinary_triples)
1006 = partition is_inline_triple triples
1008 is_inline_triple (_, ((_,occ_info),_))
1009 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1011 -- Now add in the inline_pairs info (using "env_w_clones"),
1012 -- so that we will save away suitably-clone-laden envs
1013 -- inside the InlineIts...).
1015 -- NOTE ALSO that we tie a knot here, because the
1016 -- saved-away envs must also include these very inlinings
1017 -- (they aren't stored anywhere else, and a late one might
1018 -- be used in an early one).
1020 env_w_inlinings = foldl add_inline env inline_triples
1022 add_inline env (id', (binder,rhs))
1023 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1025 -- Separate the remaining bindings into the ones which
1026 -- need to be dealt with first (the "early" ones)
1027 -- and the others (the "late" ones)
1028 (early_triples, late_triples)
1029 = partition is_early_triple ordinary_triples
1031 is_early_triple (_, (_, Con _ _ _)) = True
1032 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1034 -- Process the early bindings first
1035 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1037 -- Now further extend the environment to record our knowledge
1038 -- about the form of the binders bound in the constructor bindings
1040 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1041 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1043 -- Now process the non-constructor bindings
1044 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1048 binding = Rec (map snd early_triples' ++ map snd late_triples')
1050 returnSmpl (binding, env_w_early_info)
1053 do_one_binding env (id', (binder,rhs))
1054 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1055 returnSmpl (binder, (id', rhs'))
1059 @completeLet@ looks at the simplified post-floating RHS of the
1060 let-expression, and decides what to do. There's one interesting
1061 aspect to this, namely constructor reuse. Consider
1067 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1068 bit on the compiler technology, but in general I believe not. For
1069 example, here's some code from a real program:
1071 const.Int.max.wrk{-s2516-} =
1072 \ upk.s3297# upk.s3298# ->
1076 a.s3299 = I#! upk.s3297#
1078 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1079 _LT -> I#! upk.s3298#
1084 The a.s3299 really isn't doing much good. We'd be better off inlining
1085 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1087 So the current strategy is to inline all known-form constructors, and
1088 only do the reverse (turn a constructor application back into a
1089 variable) when we find a let-expression:
1093 ... (let y = C a1 .. an in ...) ...
1095 where it is always good to ditch the binding for y, and replace y by
1096 x. That's just what completeLetBinding does.
1102 -> InExpr -- Original RHS
1103 -> OutExpr -- The simplified RHS
1104 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1105 -> OutUniType -- Type of body
1108 completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
1110 -- See if RHS is an atom, or a reusable constructor
1111 | maybeToBool maybe_atomic_rhs
1113 new_env = extendIdEnvWithAtom env binder rhs_atom
1115 tick atom_tick_type `thenSmpl_`
1118 -- Maybe the rhs is an application of error, and sure to be demanded
1119 | will_be_demanded &&
1120 maybeToBool maybe_error_app
1121 = tick CaseOfError `thenSmpl_`
1122 returnSmpl retyped_error_app
1126 = cloneId env binder `thenSmpl` \ id' ->
1128 env1 = extendIdEnvWithClone env binder id'
1129 new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
1131 body_c new_env `thenSmpl` \ body' ->
1132 returnSmpl (Let (NonRec id' new_rhs) body')
1135 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1136 try_to_reuse_constr = switchIsSet env SimplReuseCon
1138 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1140 maybe_atomic_rhs :: Maybe (OutAtom, TickType)
1141 -- If the RHS is atomic, we return Just (atom, tick type)
1142 -- otherwise Nothing
1146 Var var -> Just (VarArg var, AtomicRhs)
1148 Lit lit | not (isNoRepLit lit)
1149 -> Just (LitArg lit, AtomicRhs)
1151 Con con tys con_args
1152 | try_to_reuse_constr
1156 --- ...(let w = C same-args in ...)...
1157 -- Then use v instead of w. This may save
1158 -- re-constructing an existing constructor.
1159 -> case lookForConstructor env con tys con_args of
1161 Just var -> Just (VarArg var, ConReused)
1165 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1166 Just retyped_error_app = maybe_error_app
1169 %************************************************************************
1171 \subsection[Simplify-atoms]{Simplifying atoms}
1173 %************************************************************************
1176 simplAtom :: SimplEnv -> InAtom -> OutAtom
1178 simplAtom env (LitArg lit) = LitArg lit
1180 simplAtom env (VarArg id)
1181 | isLocallyDefined id
1182 = case lookupId env id of
1183 Just (ItsAnAtom atom) -> atom
1184 Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1185 Nothing -> VarArg id -- Must be an uncloned thing
1188 = -- Not locally defined, so no change
1193 %************************************************************************
1195 \subsection[Simplify-quickies]{Some local help functions}
1197 %************************************************************************
1201 -- fix_up_demandedness switches off the willBeDemanded Info field
1202 -- for bindings floated out of a non-demanded let
1203 fix_up_demandedness True {- Will be demanded -} bind
1204 = bind -- Simple; no change to demand info needed
1205 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1206 = NonRec (un_demandify binder) rhs
1207 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1208 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1210 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1212 is_cheap_prim_app (Prim op tys args) = primOpOkForSpeculation op
1213 is_cheap_prim_app other = False
1215 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
1216 computeResultType env expr args
1219 expr_ty = coreExprType (unTagBinders expr)
1220 expr_ty' = simplTy env expr_ty
1223 do ty (TypeArg ty_arg : args) = do (applyTy ty ty_arg) args
1224 do ty (ValArg a : args) = case maybeUnpackFunTy ty of
1225 Just (_, res_ty) -> do res_ty args
1226 Nothing -> panic "computeResultType"