2 % (c) The AQUA Project, Glasgow University, 1993-1995
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
19 import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..),
20 primOpOkForSpeculation, PrimOp(..), PrimKind,
22 IF_ATTACK_PRAGMAS(COMMA realWorldTy)
23 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
24 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
26 import AbsUniType ( getUniDataTyCon_maybe, mkTyVarTy, applyTy,
27 splitTyArgs, splitTypeWithDictsAsArgs,
28 maybeUnpackFunTy, isPrimType
30 import BasicLit ( isNoRepLit, BasicLit(..) )
32 import CmdLineOpts ( SimplifierSwitch(..) )
33 import ConFold ( completePrim )
36 import Maybes ( Maybe(..), catMaybes, maybeToBool )
39 import SimplVar ( completeVar )
43 The controlling flags, and what they do
44 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
48 -fsimplify = run the simplifier
49 -ffloat-inwards = runs the float lets inwards pass
50 -ffloat = runs the full laziness pass
51 (ToDo: rename to -ffull-laziness)
52 -fupdate-analysis = runs update analyser
53 -fstrictness = runs strictness analyser
54 -fsaturate-apps = saturates applications (eta expansion)
58 -ffloat-past-lambda = OK to do full laziness.
59 (ToDo: remove, as the full laziness pass is
60 useless without this flag, therefore
61 it is unnecessary. Just -ffull-laziness
64 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
65 let is strict or if the floating will expose
68 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
69 is a primop that cannot fail [simplifier].
71 -fcode-duplication-ok = allows the previous option to work on cases with
72 multiple branches [simplifier].
74 -flet-to-case = does let-to-case transformation [simplifier].
76 -fcase-of-case = does case of case transformation [simplifier].
78 -fpedantic-bottoms = does not allow:
79 case x of y -> e ===> e[x/y]
80 (which may turn bottom into non-bottom)
86 Inlining is one of the delicate aspects of the simplifier. By
87 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
88 the RHS of x's definition. Thus
90 let x = e in ...x... ===> let x = e in ...e...
92 We have two mechanisms for inlining:
94 1. Unconditional. The occurrence analyser has pinned an (OneOcc
95 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
96 certainly safe to inline this variable, and to drop its binding''.
97 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
98 happy to be duplicating code...) When it encounters such a beast, the
99 simplifer binds the variable to its RHS (in the id_env) and continues.
100 It doesn't even look at the RHS at that stage. It also drops the
103 2. Conditional. In all other situations, the simplifer simplifies
104 the RHS anyway, and keeps the new binding. It also binds the new
105 (cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
107 Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
108 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
109 the variable has an INLINE pragma on it). The idea is that anything
110 in the UnfoldEnv is safe to use, but also has an enclosing binding if
111 you decide not to use it.
115 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
118 At one time I thought it would be OK to put non-HNF unfoldings in for
119 variables which occur only once [if they got inlined at that
120 occurrence the RHS of the binding would become dead, so no duplication
121 would occur]. But consider:
124 f = \y -> ...y...y...y...
127 Now, it seems that @x@ appears only once, but even so it is NOT safe to put @x@
128 in the UnfoldEnv, because @f@ will be inlined, and will duplicate the references to
131 Becuase of this, the "unconditional-inline" mechanism above is the only way
132 in which non-HNFs can get inlined.
137 When a variable has an INLINE pragma on it --- which includes wrappers
138 produced by the strictness analyser --- we treat it rather carefully.
140 For a start, we are careful not to substitute into its RHS, because
141 that might make it BIG, and the user said "inline exactly this", not
142 "inline whatever you get after inlining other stuff inside me". For
146 in {-# INLINE y #-} y = f 3
149 Here we don't want to substitute BIG for the (single) occurrence of f,
150 because then we'd duplicate BIG when we inline'd y. (Exception:
151 things in the UnfoldEnv with UnfoldAlways flags, which originated in
152 other INLINE pragmas.)
154 So, we clean out the UnfoldEnv of all GeneralForm inlinings before
155 going into such an RHS.
157 What about imports? They don't really matter much because we only
158 inline relatively small things via imports.
160 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
161 INLINE pragma. We also do this for the RHSs of recursive decls,
162 before looking at the recursive decls. That way we achieve the effect
163 of inlining a wrapper in the body of its worker, in the case of a
164 mutually-recursive worker/wrapper split.
167 %************************************************************************
169 \subsection[Simplify-simplExpr]{The main function: simplExpr}
171 %************************************************************************
173 At the top level things are a little different.
175 * No cloning (not allowed for exported Ids, unnecessary for the others)
177 * No floating. Case floating is obviously out. Let floating is
178 theoretically OK, but dangerous because of space leaks.
179 The long-distance let-floater lifts these lets.
182 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
184 simplTopBinds env [] = returnSmpl []
186 -- Dead code is now discarded by the occurrence analyser,
188 simplTopBinds env (CoNonRec binder@(in_id, occ_info) rhs : binds)
189 | inlineUnconditionally ok_to_dup_code occ_info
190 = --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) (
192 new_env = extendIdEnvWithInlining env env binder rhs
194 simplTopBinds new_env binds
197 ok_to_dup_code = switchIsSet env SimplOkToDupCode
199 simplTopBinds env (CoNonRec 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 CoVar var -> extendIdEnvWithAtom env binder (CoVarAtom var)
206 CoLit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (CoLitAtom lit)
207 other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
209 --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) (
211 -- Process the other bindings
212 simplTopBinds new_env binds `thenSmpl` \ binds' ->
214 -- Glue together and return ...
215 -- We leave it to susequent occurrence analysis to throw away
216 -- an unused atom binding. This localises the decision about
217 -- discarding top-level bindings.
218 returnSmpl (CoNonRec in_id rhs' : binds')
221 simplTopBinds env (CoRec pairs : binds)
222 = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
224 --pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) (
226 -- Process the other bindings
227 simplTopBinds new_env binds `thenSmpl` \ binds' ->
229 -- Glue together and return
230 returnSmpl (bind' : binds')
233 triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
234 -- No cloning necessary at top level
237 %************************************************************************
239 \subsection[Simplify-simplExpr]{The main function: simplExpr}
241 %************************************************************************
245 simplExpr :: SimplEnv
246 -> InExpr -> [OutArg]
250 The expression returned has the same meaning as the input expression
251 applied to the specified arguments.
256 Check if there's a macro-expansion, and if so rattle on. Otherwise
257 do the more sophisticated stuff.
260 simplExpr env (CoVar v) args
261 = --pprTrace "simplExpr:Var:" (ppr PprDebug v) (
262 case lookupId env v of
264 new_v = simplTyInId env v
266 completeVar env new_v args
270 ItsAnAtom (CoLitAtom lit) -- A boring old literal
271 -- Paranoia check for args empty
273 [] -> returnSmpl (CoLit lit)
274 other -> panic "simplExpr:coVar"
276 ItsAnAtom (CoVarAtom var) -- More interesting! An id!
277 -- No need to substitute the type env here,
278 -- because we already have!
279 -> completeVar env var args
281 InlineIt id_env ty_env in_expr -- A macro-expansion
282 -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
290 simplExpr env (CoLit l) [] = returnSmpl (CoLit l)
291 simplExpr env (CoLit l) _ = panic "simplExpr:CoLit with argument"
294 Primitive applications are simple.
295 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
297 NB: CoPrim expects an empty argument list! (Because it should be
298 saturated and not higher-order. ADR)
301 simplExpr env (CoPrim op tys prim_args) args
304 tys' = [simplTy env ty | ty <- tys]
305 prim_args' = [simplAtom env prim_arg | prim_arg <- prim_args]
308 completePrim env op' tys' prim_args'
310 -- PrimOps just need any types in them renamed.
312 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
314 arg_tys' = map (simplTy env) arg_tys
315 result_ty' = simplTy env result_ty
317 CCallOp label is_asm may_gc arg_tys' result_ty'
319 simpl_op other_op = other_op
322 Constructor applications
323 ~~~~~~~~~~~~~~~~~~~~~~~~
324 Nothing to try here. We only reuse constructors when they appear as the
325 rhs of a let binding (see completeLetBinding).
328 simplExpr env (CoCon con tys con_args) args
329 = ASSERT( null args )
330 returnSmpl (CoCon con tys' con_args')
332 con_args' = [simplAtom env con_arg | con_arg <- con_args]
333 tys' = [simplTy env ty | ty <- tys]
337 Applications are easy too:
338 ~~~~~~~~~~~~~~~~~~~~~~~~~~
339 Just stuff 'em in the arg stack
342 simplExpr env (CoApp fun arg) args
343 = simplExpr env fun (ValArg (simplAtom env arg) : args)
345 simplExpr env (CoTyApp fun ty) args
346 = simplExpr env fun (TypeArg (simplTy env ty) : args)
352 We only eta-reduce a type lambda if all type arguments in the body can
353 be eta-reduced. This requires us to collect up all tyvar parameters so
354 we can pass them all to @mkCoTyLamTryingEta@.
357 simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
358 = ASSERT(not (isPrimType ty))
360 new_env = extendTyEnv env tyvar ty
362 tick TyBetaReduction `thenSmpl_`
363 simplExpr new_env body args
365 simplExpr env tylam@(CoTyLam tyvar body) []
366 = do_tylambdas env [] tylam
368 do_tylambdas env tyvars' (CoTyLam tyvar body)
369 = -- Clone the type variable
370 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
372 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
374 do_tylambdas new_env (tyvar':tyvars') body
376 do_tylambdas env tyvars' body
377 = simplExpr env body [] `thenSmpl` \ body' ->
379 (if switchIsSet env SimplDoEtaReduction
380 then mkCoTyLamTryingEta
381 else mkCoTyLam) (reverse tyvars') body'
384 simplExpr env (CoTyLam tyvar body) (ValArg _ : _)
385 = panic "simplExpr:CoTyLam ValArg"
393 simplExpr env (CoLam binders body) args
394 | null leftover_binders
395 = -- The lambda is saturated (or over-saturated)
396 tick BetaReduction `thenSmpl_`
397 simplExpr env_for_enough_args body leftover_args
400 = -- Too few args to saturate the lambda
401 ASSERT( null leftover_args )
403 (if not (null args) -- ah, we must've gotten rid of some...
404 then tick BetaReduction
405 else returnSmpl (panic "BetaReduction")
408 simplLam env_for_too_few_args leftover_binders body
409 0 {- Guaranteed applied to at least 0 args! -}
412 (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binders args
414 env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
416 env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
418 -- Since there aren't enough args the binders we are cancelling with
419 -- the args supplied are, in effect, ocurring inside a lambda.
420 -- So we modify their occurrence info to reflect this fact.
421 -- Example: (\ x y z -> e) p q
422 -- ==> (\z -> e[p/x, q/y])
423 -- but we should behave as if x and y are marked "inside lambda".
424 -- The occurrence analyser does not mark them so itself because then we
425 -- do badly on the very common case of saturated lambdas applications:
426 -- (\ x y z -> e) p q r
427 -- ==> e[p/x, q/y, r/z]
429 zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
430 | ((id, occ_info), arg) <- binder_args_pairs ]
432 collect_val_args :: [InBinder] -- Binders
433 -> [OutArg] -- Arguments
434 -> ([(InBinder,OutAtom)], -- Binder,arg pairs
435 [InBinder], -- Leftover binders
436 [OutArg]) -- Leftover args
438 -- collect_val_args strips off the leading ValArgs from
439 -- the current arg list, returning them along with the
441 collect_val_args [] args = ([], [], args)
442 collect_val_args binders [] = ([], binders, [])
443 collect_val_args (binder:binders) (ValArg val_arg : args)
444 = ((binder,val_arg):rest_pairs, leftover_binders, leftover_args)
446 (rest_pairs, leftover_binders, leftover_args) = collect_val_args binders args
448 collect_val_args (binder:binders) (other_val_arg : args) = panic "collect_val_args"
449 -- TypeArg should never meet a CoLam
457 simplExpr env (CoLet bind body) args
458 | not (switchIsSet env SimplNoLetFromApp) -- The common case
459 = simplBind env bind (\env -> simplExpr env body args)
460 (computeResultType env body args)
462 | otherwise -- No float from application
463 = simplBind env bind (\env -> simplExpr env body [])
464 (computeResultType env body []) `thenSmpl` \ let_expr' ->
465 returnSmpl (applyToArgs let_expr' args)
472 simplExpr env expr@(CoCase scrut alts) args
473 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
474 (computeResultType env expr args)
481 A special case we do:
483 scc "foo" (\x -> e) ===> \x -> scc "foo" e
485 Simon thinks it's OK, at least for lexical scoping; and it makes
486 interfaces change less (arities).
489 simplExpr env (CoSCC cc (CoLam binders body)) args
490 = simplExpr env (CoLam binders (CoSCC cc body)) args
492 simplExpr env (CoSCC cc (CoTyLam tyvar body)) args
493 = simplExpr env (CoTyLam tyvar (CoSCC cc body)) args
496 Some other slightly turgid SCC tidying-up cases:
498 simplExpr env (CoSCC cc1 expr@(CoSCC _ _)) args
499 = simplExpr env expr args
500 -- the outer _scc_ serves no purpose
502 simplExpr env (CoSCC cc expr) args
503 | squashableDictishCcExpr cc expr
504 = simplExpr env expr args
505 -- the DICT-ish CC is no longer serving any purpose
508 NB: for other set-cost-centre we move arguments inside the body.
509 ToDo: check with Patrick that this is ok.
512 simplExpr env (CoSCC cost_centre body) args
514 new_env = setEnclosingCC env (EnclosingCC cost_centre)
516 simplExpr new_env body args `thenSmpl` \ body' ->
517 returnSmpl (CoSCC cost_centre body')
520 %************************************************************************
522 \subsection{Simplify RHS of a Let/Letrec}
524 %************************************************************************
526 simplRhsExpr does arity-expansion. That is, given:
528 * a right hand side /\ tyvars -> \a1 ... an -> e
529 * the information (stored in BinderInfo) that the function will always
530 be applied to at least k arguments
532 it transforms the rhs to
534 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
536 This is a Very Good Thing!
545 simplRhsExpr env binder@(id,occ_info) rhs
546 | dont_eta_expand rhs
547 = simplExpr rhs_env rhs []
549 | otherwise -- Have a go at eta expansion
550 = -- Deal with the big lambda part
551 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
553 lam_env = extendTyEnvList rhs_env (tyvars `zip` (map mkTyVarTy tyvars'))
555 -- Deal with the little lambda part
556 -- Note that we call simplLam even if there are no binders, in case
557 -- it can do arity expansion.
558 simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
560 -- Put it back together
562 (if switchIsSet env SimplDoEtaReduction
563 then mkCoTyLamTryingEta
564 else mkCoTyLam) tyvars' lambda'
568 -- If you say {-# INLINE #-} then you get what's coming to you;
569 -- you are saying inline the rhs, please.
570 -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
571 rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
574 (tyvars, binders, body) = digForLambdas rhs
576 min_no_of_args | not (null binders) && -- It's not a thunk
577 switchIsSet env SimplDoArityExpand -- Arity expansion on
578 = getBinderInfoArity occ_info - length binders
580 | otherwise -- Not a thunk
583 -- dont_eta_expand prevents eta expansion in silly situations.
584 -- For example, consider the defn
586 -- It would be silly to eta expand the "y", because it would just
587 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
588 -- and x was exported, then the defn won't be eliminated, so this
589 -- silly expand/reduce cycle will happen every time, which makes the
591 -- The solution is to not even try eta expansion unless the rhs looks
593 dont_eta_expand (CoLit _) = True
594 dont_eta_expand (CoVar _) = True
595 dont_eta_expand (CoTyApp f _) = dont_eta_expand f
596 dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
597 dont_eta_expand (CoCon _ _ _) = True
598 dont_eta_expand _ = False
602 %************************************************************************
604 \subsection{Simplify a lambda abstraction}
606 %************************************************************************
608 Simplify (\binders -> body) trying eta expansion and reduction, given that
609 the abstraction will always be applied to at least min_no_of_args.
612 simplLam env binders body min_no_of_args
613 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
614 null potential_extra_binder_tys || -- or ain't a function
615 no_of_extra_binders == 0 -- or no extra binders needed
616 = cloneIds env binders `thenSmpl` \ binders' ->
618 new_env = extendIdEnvWithClones env binders binders'
620 simplExpr new_env body [] `thenSmpl` \ body' ->
622 (if switchIsSet new_env SimplDoEtaReduction
623 then mkCoLamTryingEta
624 else mkCoLam) binders' body'
627 | otherwise -- Eta expansion possible
628 = tick EtaExpansion `thenSmpl_`
629 cloneIds env binders `thenSmpl` \ binders' ->
631 new_env = extendIdEnvWithClones env binders binders'
633 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
634 simplExpr new_env body (map (ValArg.CoVarAtom) extra_binders') `thenSmpl` \ body' ->
636 (if switchIsSet new_env SimplDoEtaReduction
637 then mkCoLamTryingEta
638 else mkCoLam) (binders' ++ extra_binders') body'
642 (potential_extra_binder_tys, res_ty)
643 = splitTyArgs (simplTy env (typeOfCoreExpr (unTagBinders body)))
644 -- Note: it's possible that simplLam will be applied to something
645 -- with a forall type. Eg when being applied to the rhs of
647 -- where wurble has a forall-type, but no big lambdas at the top.
648 -- We could be clever an insert new big lambdas, but we don't bother.
650 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
652 no_of_extra_binders = -- First, use the info about how many args it's
653 -- always applied to in its scope
656 -- Next, try seeing if there's a lambda hidden inside
661 -- Finally, see if it's a state transformer, in which
662 -- case we eta-expand on principle! This can waste work,
663 -- but usually doesn't
665 case potential_extra_binder_tys of
666 [ty] | ty == realWorldStateTy -> 1
672 %************************************************************************
674 \subsection[Simplify-let]{Let-expressions}
676 %************************************************************************
679 simplBind :: SimplEnv
681 -> (SimplEnv -> SmplM OutExpr)
686 When floating cases out of lets, remember this:
688 let x* = case e of alts
691 where x* is sure to be demanded or e is a cheap operation that cannot
692 fail, e.g. unboxed addition. Here we should be prepared to duplicate
693 <small expr>. A good example:
702 p1 -> foldr c n (build e1)
703 p2 -> foldr c n (build e2)
705 NEW: We use the same machinery that we use for case-of-case to
706 *always* do case floating from let, that is we let bind and abstract
707 the original let body, and let the occurrence analyser later decide
708 whether the new let should be inlined or not. The example above
712 let join_body x' = foldr c n x'
714 p1 -> let x* = build e1
716 p2 -> let x* = build e2
719 note that join_body is a let-no-escape.
720 In this particular example join_body will later be inlined,
721 achieving the same effect.
722 ToDo: check this is OK with andy
727 -- Dead code is now discarded by the occurrence analyser,
729 simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
730 | inlineUnconditionally ok_to_dup occ_info
731 = body_c (extendIdEnvWithInlining env env binder rhs)
734 -- It's important to try let-to-case before floating. Consider
736 -- let a*::Int = case v of {p1->e1; p2->e2}
739 -- (The * means that a is sure to be demanded.)
740 -- If we do case-floating first we get this:
744 -- p1-> let a*=e1 in k a
745 -- p2-> let a*=e2 in k a
747 -- Now watch what happens if we do let-to-case first:
749 -- case (case v of {p1->e1; p2->e2}) of
750 -- Int a# -> let a*=I# a# in b
752 -- let k = \a# -> let a*=I# a# in b
754 -- p1 -> case e1 of I# a# -> k a#
755 -- p1 -> case e1 of I# a# -> k a#
757 -- The latter is clearly better. (Remember the reboxing let-decl
758 -- for a is likely to go away, because after all b is strict in a.)
760 | will_be_demanded &&
762 type_ok_for_let_to_case rhs_ty &&
763 not (manifestlyWHNF rhs)
764 -- note: no "manifestlyBottom rhs" in there... (comment below)
765 = tick Let2Case `thenSmpl_`
766 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
767 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
769 We do not do let to case for WHNFs, e.g.
775 as this is less efficient.
776 but we don't mind doing let-to-case for "bottom", as that
778 allow us to remove more dead code, if anything:
781 case error of x -> ...
785 Notice that let to case occurs only if x is used strictly in
786 its body (obviously).
789 | (will_be_demanded && not no_float) ||
790 always_float_let_from_let ||
791 floatExposesHNF float_lets float_primops ok_to_dup rhs
792 = try_float env rhs body_c
795 = done_float env rhs body_c
798 will_be_demanded = willBeDemanded (getIdDemandInfo id)
799 rhs_ty = getIdUniType id
801 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
802 float_primops = switchIsSet env SimplOkToFloatPrimOps
803 ok_to_dup = switchIsSet env SimplOkToDupCode
804 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
805 try_let_to_case = switchIsSet env SimplLetToCase
806 no_float = switchIsSet env SimplNoLetFromStrictLet
808 -------------------------------------------
809 done_float env rhs body_c
810 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
811 completeLet env binder rhs rhs' body_c body_ty
813 ---------------------------------------
814 try_float env (CoLet bind rhs) body_c
815 = tick LetFloatFromLet `thenSmpl_`
816 simplBind env (fix_up_demandedness will_be_demanded bind)
817 (\env -> try_float env rhs body_c) body_ty
819 try_float env (CoCase scrut alts) body_c
820 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
821 = tick CaseFloatFromLet `thenSmpl_`
823 -- First, bind large let-body if necessary
824 if no_need_to_bind_large_body then
825 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
827 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
829 body_c' = \env -> simplExpr env new_body []
831 simplCase env scrut alts
832 (\env rhs -> try_float env rhs body_c')
833 body_ty `thenSmpl` \ case_expr ->
835 returnSmpl (CoLet extra_binding case_expr)
837 no_need_to_bind_large_body
838 = ok_to_dup || isSingleton (nonErrorRHSs alts)
840 try_float env other_rhs body_c = done_float env other_rhs body_c
846 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
847 on and it'll expose a HNF), and bang the whole resulting mess together
850 1. Any "macros" should be expanded. The main application of this
859 Here we would like the single call to g to be inlined.
861 We can spot this easily, because g will be tagged as having just one
862 occurrence. The "inlineUnconditionally" predicate is just what we want.
864 A worry: could this lead to non-termination? For example:
873 Here, f and g call each other (just once) and neither is used elsewhere.
876 * the occurrence analyser will drop any (sub)-group that isn't used at
879 * If the group is used outside itself (ie in the "in" part), then there
882 ** IMPORTANT: check that NewOccAnal has the property that a group of
883 bindings like the above has f&g dropped.! ***
886 2. We'd also like to pull out any top-level let(rec)s from the
890 f = let h = ... in \x -> ....h...f...h...
896 f = \x -> ....h...f...h...
900 But floating cases is less easy? (Don't for now; ToDo?)
903 3. We'd like to arrange that the RHSs "know" about members of the
904 group that are bound to constructors. For example:
908 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
909 /= a b = unpack tuple a, unpack tuple b, call f
912 here, by knowing about d.Eq in f's rhs, one could get rid of
913 the case (and break out the recursion completely).
914 [This occurred with more aggressive inlining threshold (4),
915 nofib/spectral/knights]
918 1: we simplify constructor rhss first.
919 2: we record the "known constructors" in the environment
920 3: we simplify the other rhss, with the knowledge about the constructors
925 simplBind env (CoRec pairs) body_c body_ty
926 = -- Do floating, if necessary
927 (if float_lets || always_float_let_from_let
929 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
930 returnSmpl (concat floated_pairs_s)
933 ) `thenSmpl` \ floated_pairs ->
935 binders = map fst floated_pairs
937 cloneIds env binders `thenSmpl` \ ids' ->
939 env_w_clones = extendIdEnvWithClones env binders ids'
940 triples = ids' `zip` floated_pairs
943 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
945 body_c new_env `thenSmpl` \ body' ->
947 returnSmpl (CoLet binding body')
950 ------------ Floating stuff -------------------
952 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
953 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
957 pairs_s = float_pair (binder,rhs)
960 [_] -> returnSmpl pairs_s
962 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
963 -- It's important to increment the tick counts if we
964 -- do any floating. A situation where this turns out
965 -- to be important is this:
966 -- Float in produces:
967 -- letrec x = let y = Ey in Ex
969 -- Now floating gives this:
973 --- We now want to iterate once more in case Ey doesn't
974 -- mention x, in which case the y binding can be pulled
975 -- out as an enclosing let(rec), which in turn gives
976 -- the strictness analyser more chance.
979 float_pairs pairs = concat (map float_pair pairs)
981 float_pair (binder, rhs)
982 | always_float_let_from_let ||
983 floatExposesHNF True False False rhs
984 = (binder,rhs') : pairs'
989 (pairs', rhs') = do_float rhs
991 -- Float just pulls out any top-level let(rec) bindings
992 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
993 do_float (CoLet (CoRec pairs) body) = (float_pairs pairs ++ pairs', body')
995 (pairs', body') = do_float body
996 do_float (CoLet (CoNonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
998 (pairs', body') = do_float body
999 do_float other = ([], other)
1001 simplRecursiveGroup env triples
1002 = -- Toss out all the dead pairs? No, there shouldn't be any!
1003 -- Dead code is discarded by the occurrence analyser
1005 -- Separate the live triples into "inline"able and
1006 -- "ordinary" We're paranoid about duplication!
1007 (inline_triples, ordinary_triples)
1008 = partition is_inline_triple triples
1010 is_inline_triple (_, ((_,occ_info),_))
1011 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1013 -- Now add in the inline_pairs info (using "env_w_clones"),
1014 -- so that we will save away suitably-clone-laden envs
1015 -- inside the InlineIts...).
1017 -- NOTE ALSO that we tie a knot here, because the
1018 -- saved-away envs must also include these very inlinings
1019 -- (they aren't stored anywhere else, and a late one might
1020 -- be used in an early one).
1022 env_w_inlinings = foldl add_inline env inline_triples
1024 add_inline env (id', (binder,rhs))
1025 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1027 -- Separate the remaining bindings into the ones which
1028 -- need to be dealt with first (the "early" ones)
1029 -- and the others (the "late" ones)
1030 (early_triples, late_triples)
1031 = partition is_early_triple ordinary_triples
1033 is_early_triple (_, (_, CoCon _ _ _)) = True
1034 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1036 -- Process the early bindings first
1037 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1039 -- Now further extend the environment to record our knowledge
1040 -- about the form of the binders bound in the constructor bindings
1042 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1043 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1045 -- Now process the non-constructor bindings
1046 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1050 binding = CoRec (map snd early_triples' ++ map snd late_triples')
1052 returnSmpl (binding, env_w_early_info)
1055 do_one_binding env (id', (binder,rhs))
1056 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1057 returnSmpl (binder, (id', rhs'))
1061 @completeLet@ looks at the simplified post-floating RHS of the
1062 let-expression, and decides what to do. There's one interesting
1063 aspect to this, namely constructor reuse. Consider
1069 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1070 bit on the compiler technology, but in general I believe not. For
1071 example, here's some code from a real program:
1073 const.Int.max.wrk{-s2516-} =
1074 \ upk.s3297# upk.s3298# ->
1078 a.s3299 = I#! upk.s3297#
1080 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1081 _LT -> I#! upk.s3298#
1086 The a.s3299 really isn't doing much good. We'd be better off inlining
1087 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1089 So the current strategy is to inline all known-form constructors, and
1090 only do the reverse (turn a constructor application back into a
1091 variable) when we find a let-expression:
1095 ... (let y = C a1 .. an in ...) ...
1097 where it is always good to ditch the binding for y, and replace y by
1098 x. That's just what completeLetBinding does.
1104 -> InExpr -- Original RHS
1105 -> OutExpr -- The simplified RHS
1106 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1107 -> OutUniType -- Type of body
1110 completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
1112 -- See if RHS is an atom, or a reusable constructor
1113 | maybeToBool maybe_atomic_rhs
1115 new_env = extendIdEnvWithAtom env binder rhs_atom
1117 tick atom_tick_type `thenSmpl_`
1120 -- Maybe the rhs is an application of error, and sure to be demanded
1121 | will_be_demanded &&
1122 maybeToBool maybe_error_app
1123 = tick CaseOfError `thenSmpl_`
1124 returnSmpl retyped_error_app
1128 = cloneId env binder `thenSmpl` \ id' ->
1130 env1 = extendIdEnvWithClone env binder id'
1131 new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
1133 body_c new_env `thenSmpl` \ body' ->
1134 returnSmpl (CoLet (CoNonRec id' new_rhs) body')
1137 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1138 try_to_reuse_constr = switchIsSet env SimplReuseCon
1140 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1142 maybe_atomic_rhs :: Maybe (OutAtom, TickType)
1143 -- If the RHS is atomic, we return Just (atom, tick type)
1144 -- otherwise Nothing
1148 CoVar var -> Just (CoVarAtom var, AtomicRhs)
1150 CoLit lit | not (isNoRepLit lit)
1151 -> Just (CoLitAtom lit, AtomicRhs)
1153 CoCon con tys con_args
1154 | try_to_reuse_constr
1158 --- ...(let w = C same-args in ...)...
1159 -- Then use v instead of w. This may save
1160 -- re-constructing an existing constructor.
1161 -> case lookForConstructor env con tys con_args of
1163 Just var -> Just (CoVarAtom var, ConReused)
1167 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1168 Just retyped_error_app = maybe_error_app
1171 %************************************************************************
1173 \subsection[Simplify-atoms]{Simplifying atoms}
1175 %************************************************************************
1178 simplAtom :: SimplEnv -> InAtom -> OutAtom
1180 simplAtom env (CoLitAtom lit) = CoLitAtom lit
1182 simplAtom env (CoVarAtom id)
1183 | isLocallyDefined id
1184 = case lookupId env id of
1185 Just (ItsAnAtom atom) -> atom
1186 Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1187 Nothing -> CoVarAtom id -- Must be an uncloned thing
1190 = -- Not locally defined, so no change
1195 %************************************************************************
1197 \subsection[Simplify-quickies]{Some local help functions}
1199 %************************************************************************
1203 -- fix_up_demandedness switches off the willBeDemanded Info field
1204 -- for bindings floated out of a non-demanded let
1205 fix_up_demandedness True {- Will be demanded -} bind
1206 = bind -- Simple; no change to demand info needed
1207 fix_up_demandedness False {- May not be demanded -} (CoNonRec binder rhs)
1208 = CoNonRec (un_demandify binder) rhs
1209 fix_up_demandedness False {- May not be demanded -} (CoRec pairs)
1210 = CoRec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1212 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1214 is_cheap_prim_app (CoPrim op tys args) = primOpOkForSpeculation op
1215 is_cheap_prim_app other = False
1217 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
1218 computeResultType env expr args
1221 expr_ty = typeOfCoreExpr (unTagBinders expr)
1222 expr_ty' = simplTy env expr_ty
1225 do ty (TypeArg ty_arg : args) = do (applyTy ty ty_arg) args
1226 do ty (ValArg a : args) = case maybeUnpackFunTy ty of
1227 Just (_, res_ty) -> do res_ty args
1228 Nothing -> panic "computeResultType"