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 = simplBind env bind (\env -> simplExpr env body args) (computeResultType env body args)
465 simplExpr env expr@(CoCase scrut alts) args
466 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
467 (computeResultType env expr args)
474 A special case we do:
476 scc "foo" (\x -> e) ===> \x -> scc "foo" e
478 Simon thinks it's OK, at least for lexical scoping; and it makes
479 interfaces change less (arities).
482 simplExpr env (CoSCC cc (CoLam binders body)) args
483 = simplExpr env (CoLam binders (CoSCC cc body)) args
485 simplExpr env (CoSCC cc (CoTyLam tyvar body)) args
486 = simplExpr env (CoTyLam tyvar (CoSCC cc body)) args
489 Some other slightly turgid SCC tidying-up cases:
491 simplExpr env (CoSCC cc1 expr@(CoSCC _ _)) args
492 = simplExpr env expr args
493 -- the outer _scc_ serves no purpose
495 simplExpr env (CoSCC cc expr) args
496 | squashableDictishCcExpr cc expr
497 = simplExpr env expr args
498 -- the DICT-ish CC is no longer serving any purpose
501 NB: for other set-cost-centre we move arguments inside the body.
502 ToDo: check with Patrick that this is ok.
505 simplExpr env (CoSCC cost_centre body) args
507 new_env = setEnclosingCC env (EnclosingCC cost_centre)
509 simplExpr new_env body args `thenSmpl` \ body' ->
510 returnSmpl (CoSCC cost_centre body')
513 %************************************************************************
515 \subsection{Simplify RHS of a Let/Letrec}
517 %************************************************************************
519 simplRhsExpr does arity-expansion. That is, given:
521 * a right hand side /\ tyvars -> \a1 ... an -> e
522 * the information (stored in BinderInfo) that the function will always
523 be applied to at least k arguments
525 it transforms the rhs to
527 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
529 This is a Very Good Thing!
538 simplRhsExpr env binder@(id,occ_info) rhs
539 | dont_eta_expand rhs
540 = simplExpr rhs_env rhs []
542 | otherwise -- Have a go at eta expansion
543 = -- Deal with the big lambda part
544 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
546 lam_env = extendTyEnvList rhs_env (tyvars `zip` (map mkTyVarTy tyvars'))
548 -- Deal with the little lambda part
549 -- Note that we call simplLam even if there are no binders, in case
550 -- it can do arity expansion.
551 simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
553 -- Put it back together
555 (if switchIsSet env SimplDoEtaReduction
556 then mkCoTyLamTryingEta
557 else mkCoTyLam) tyvars' lambda'
561 -- If you say {-# INLINE #-} then you get what's coming to you;
562 -- you are saying inline the rhs, please.
563 -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
564 rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
567 (tyvars, binders, body) = digForLambdas rhs
569 min_no_of_args | not (null binders) && -- It's not a thunk
570 switchIsSet env SimplDoArityExpand -- Arity expansion on
571 = getBinderInfoArity occ_info - length binders
573 | otherwise -- Not a thunk
576 -- dont_eta_expand prevents eta expansion in silly situations.
577 -- For example, consider the defn
579 -- It would be silly to eta expand the "y", because it would just
580 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
581 -- and x was exported, then the defn won't be eliminated, so this
582 -- silly expand/reduce cycle will happen every time, which makes the
584 -- The solution is to not even try eta expansion unless the rhs looks
586 dont_eta_expand (CoLit _) = True
587 dont_eta_expand (CoVar _) = True
588 dont_eta_expand (CoTyApp f _) = dont_eta_expand f
589 dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
590 dont_eta_expand (CoCon _ _ _) = True
591 dont_eta_expand _ = False
595 %************************************************************************
597 \subsection{Simplify a lambda abstraction}
599 %************************************************************************
601 Simplify (\binders -> body) trying eta expansion and reduction, given that
602 the abstraction will always be applied to at least min_no_of_args.
605 simplLam env binders body min_no_of_args
606 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
607 null potential_extra_binder_tys || -- or ain't a function
608 no_of_extra_binders == 0 -- or no extra binders needed
609 = cloneIds env binders `thenSmpl` \ binders' ->
611 new_env = extendIdEnvWithClones env binders binders'
613 simplExpr new_env body [] `thenSmpl` \ body' ->
615 (if switchIsSet new_env SimplDoEtaReduction
616 then mkCoLamTryingEta
617 else mkCoLam) binders' body'
620 | otherwise -- Eta expansion possible
621 = tick EtaExpansion `thenSmpl_`
622 cloneIds env binders `thenSmpl` \ binders' ->
624 new_env = extendIdEnvWithClones env binders binders'
626 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
627 simplExpr new_env body (map (ValArg.CoVarAtom) extra_binders') `thenSmpl` \ body' ->
629 (if switchIsSet new_env SimplDoEtaReduction
630 then mkCoLamTryingEta
631 else mkCoLam) (binders' ++ extra_binders') body'
635 (potential_extra_binder_tys, res_ty)
636 = splitTyArgs (simplTy env (typeOfCoreExpr (unTagBinders body)))
637 -- Note: it's possible that simplLam will be applied to something
638 -- with a forall type. Eg when being applied to the rhs of
640 -- where wurble has a forall-type, but no big lambdas at the top.
641 -- We could be clever an insert new big lambdas, but we don't bother.
643 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
645 no_of_extra_binders = -- First, use the info about how many args it's
646 -- always applied to in its scope
649 -- Next, try seeing if there's a lambda hidden inside
654 -- Finally, see if it's a state transformer, in which
655 -- case we eta-expand on principle! This can waste work,
656 -- but usually doesn't
658 case potential_extra_binder_tys of
659 [ty] | ty == realWorldStateTy -> 1
665 %************************************************************************
667 \subsection[Simplify-let]{Let-expressions}
669 %************************************************************************
672 simplBind :: SimplEnv
674 -> (SimplEnv -> SmplM OutExpr)
679 When floating cases out of lets, remember this:
681 let x* = case e of alts
684 where x* is sure to be demanded or e is a cheap operation that cannot
685 fail, e.g. unboxed addition. Here we should be prepared to duplicate
686 <small expr>. A good example:
695 p1 -> foldr c n (build e1)
696 p2 -> foldr c n (build e2)
698 NEW: We use the same machinery that we use for case-of-case to
699 *always* do case floating from let, that is we let bind and abstract
700 the original let body, and let the occurrence analyser later decide
701 whether the new let should be inlined or not. The example above
705 let join_body x' = foldr c n x'
707 p1 -> let x* = build e1
709 p2 -> let x* = build e2
712 note that join_body is a let-no-escape.
713 In this particular example join_body will later be inlined,
714 achieving the same effect.
715 ToDo: check this is OK with andy
720 -- Dead code is now discarded by the occurrence analyser,
722 simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
723 | inlineUnconditionally ok_to_dup occ_info
724 = body_c (extendIdEnvWithInlining env env binder rhs)
727 -- It's important to try let-to-case before floating. Consider
729 -- let a*::Int = case v of {p1->e1; p2->e2}
732 -- (The * means that a is sure to be demanded.)
733 -- If we do case-floating first we get this:
737 -- p1-> let a*=e1 in k a
738 -- p2-> let a*=e2 in k a
740 -- Now watch what happens if we do let-to-case first:
742 -- case (case v of {p1->e1; p2->e2}) of
743 -- Int a# -> let a*=I# a# in b
745 -- let k = \a# -> let a*=I# a# in b
747 -- p1 -> case e1 of I# a# -> k a#
748 -- p1 -> case e1 of I# a# -> k a#
750 -- The latter is clearly better. (Remember the reboxing let-decl
751 -- for a is likely to go away, because after all b is strict in a.)
753 | will_be_demanded &&
755 type_ok_for_let_to_case rhs_ty &&
756 not (manifestlyWHNF rhs)
757 -- note: no "manifestlyBottom rhs" in there... (comment below)
758 = tick Let2Case `thenSmpl_`
759 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
760 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
762 We do not do let to case for WHNFs, e.g.
768 as this is less efficient.
769 but we don't mind doing let-to-case for "bottom", as that
771 allow us to remove more dead code, if anything:
774 case error of x -> ...
778 Notice that let to case occurs only if x is used strictly in
779 its body (obviously).
782 | will_be_demanded ||
783 always_float_let_from_let ||
784 floatExposesHNF float_lets float_primops ok_to_dup rhs
785 = try_float env rhs body_c
788 = done_float env rhs body_c
791 will_be_demanded = willBeDemanded (getIdDemandInfo id)
792 rhs_ty = getIdUniType id
794 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
795 float_primops = switchIsSet env SimplOkToFloatPrimOps
796 ok_to_dup = switchIsSet env SimplOkToDupCode
797 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
798 try_let_to_case = switchIsSet env SimplLetToCase
800 -------------------------------------------
801 done_float env rhs body_c
802 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
803 completeLet env binder rhs rhs' body_c body_ty
805 ---------------------------------------
806 try_float env (CoLet bind rhs) body_c
807 = tick LetFloatFromLet `thenSmpl_`
808 simplBind env (fix_up_demandedness will_be_demanded bind)
809 (\env -> try_float env rhs body_c) body_ty
811 try_float env (CoCase scrut alts) body_c
812 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
813 = tick CaseFloatFromLet `thenSmpl_`
815 -- First, bind large let-body if necessary
816 if no_need_to_bind_large_body then
817 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
819 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
821 body_c' = \env -> simplExpr env new_body []
823 simplCase env scrut alts
824 (\env rhs -> try_float env rhs body_c')
825 body_ty `thenSmpl` \ case_expr ->
827 returnSmpl (CoLet extra_binding case_expr)
829 no_need_to_bind_large_body
830 = ok_to_dup || isSingleton (nonErrorRHSs alts)
832 try_float env other_rhs body_c = done_float env other_rhs body_c
838 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
839 on and it'll expose a HNF), and bang the whole resulting mess together
842 1. Any "macros" should be expanded. The main application of this
851 Here we would like the single call to g to be inlined.
853 We can spot this easily, because g will be tagged as having just one
854 occurrence. The "inlineUnconditionally" predicate is just what we want.
856 A worry: could this lead to non-termination? For example:
865 Here, f and g call each other (just once) and neither is used elsewhere.
868 * the occurrence analyser will drop any (sub)-group that isn't used at
871 * If the group is used outside itself (ie in the "in" part), then there
874 ** IMPORTANT: check that NewOccAnal has the property that a group of
875 bindings like the above has f&g dropped.! ***
878 2. We'd also like to pull out any top-level let(rec)s from the
882 f = let h = ... in \x -> ....h...f...h...
888 f = \x -> ....h...f...h...
892 But floating cases is less easy? (Don't for now; ToDo?)
895 3. We'd like to arrange that the RHSs "know" about members of the
896 group that are bound to constructors. For example:
900 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
901 /= a b = unpack tuple a, unpack tuple b, call f
904 here, by knowing about d.Eq in f's rhs, one could get rid of
905 the case (and break out the recursion completely).
906 [This occurred with more aggressive inlining threshold (4),
907 nofib/spectral/knights]
910 1: we simplify constructor rhss first.
911 2: we record the "known constructors" in the environment
912 3: we simplify the other rhss, with the knowledge about the constructors
917 simplBind env (CoRec pairs) body_c body_ty
918 = -- Do floating, if necessary
919 (if float_lets || always_float_let_from_let
921 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
922 returnSmpl (concat floated_pairs_s)
925 ) `thenSmpl` \ floated_pairs ->
927 binders = map fst floated_pairs
929 cloneIds env binders `thenSmpl` \ ids' ->
931 env_w_clones = extendIdEnvWithClones env binders ids'
932 triples = ids' `zip` floated_pairs
935 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
937 body_c new_env `thenSmpl` \ body' ->
939 returnSmpl (CoLet binding body')
942 ------------ Floating stuff -------------------
944 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
945 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
949 pairs_s = float_pair (binder,rhs)
952 [_] -> returnSmpl pairs_s
954 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
955 -- It's important to increment the tick counts if we
956 -- do any floating. A situation where this turns out
957 -- to be important is this:
958 -- Float in produces:
959 -- letrec x = let y = Ey in Ex
961 -- Now floating gives this:
965 --- We now want to iterate once more in case Ey doesn't
966 -- mention x, in which case the y binding can be pulled
967 -- out as an enclosing let(rec), which in turn gives
968 -- the strictness analyser more chance.
971 float_pairs pairs = concat (map float_pair pairs)
973 float_pair (binder, rhs)
974 | always_float_let_from_let ||
975 floatExposesHNF True False False rhs
976 = (binder,rhs') : pairs'
981 (pairs', rhs') = do_float rhs
983 -- Float just pulls out any top-level let(rec) bindings
984 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
985 do_float (CoLet (CoRec pairs) body) = (float_pairs pairs ++ pairs', body')
987 (pairs', body') = do_float body
988 do_float (CoLet (CoNonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
990 (pairs', body') = do_float body
991 do_float other = ([], other)
993 simplRecursiveGroup env triples
994 = -- Toss out all the dead pairs? No, there shouldn't be any!
995 -- Dead code is discarded by the occurrence analyser
997 -- Separate the live triples into "inline"able and
998 -- "ordinary" We're paranoid about duplication!
999 (inline_triples, ordinary_triples)
1000 = partition is_inline_triple triples
1002 is_inline_triple (_, ((_,occ_info),_))
1003 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1005 -- Now add in the inline_pairs info (using "env_w_clones"),
1006 -- so that we will save away suitably-clone-laden envs
1007 -- inside the InlineIts...).
1009 -- NOTE ALSO that we tie a knot here, because the
1010 -- saved-away envs must also include these very inlinings
1011 -- (they aren't stored anywhere else, and a late one might
1012 -- be used in an early one).
1014 env_w_inlinings = foldl add_inline env inline_triples
1016 add_inline env (id', (binder,rhs))
1017 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1019 -- Separate the remaining bindings into the ones which
1020 -- need to be dealt with first (the "early" ones)
1021 -- and the others (the "late" ones)
1022 (early_triples, late_triples)
1023 = partition is_early_triple ordinary_triples
1025 is_early_triple (_, (_, CoCon _ _ _)) = True
1026 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1028 -- Process the early bindings first
1029 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1031 -- Now further extend the environment to record our knowledge
1032 -- about the form of the binders bound in the constructor bindings
1034 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1035 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1037 -- Now process the non-constructor bindings
1038 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1042 binding = CoRec (map snd early_triples' ++ map snd late_triples')
1044 returnSmpl (binding, env_w_early_info)
1047 do_one_binding env (id', (binder,rhs))
1048 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1049 returnSmpl (binder, (id', rhs'))
1053 @completeLet@ looks at the simplified post-floating RHS of the
1054 let-expression, and decides what to do. There's one interesting
1055 aspect to this, namely constructor reuse. Consider
1061 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1062 bit on the compiler technology, but in general I believe not. For
1063 example, here's some code from a real program:
1065 const.Int.max.wrk{-s2516-} =
1066 \ upk.s3297# upk.s3298# ->
1070 a.s3299 = I#! upk.s3297#
1072 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1073 _LT -> I#! upk.s3298#
1078 The a.s3299 really isn't doing much good. We'd be better off inlining
1079 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1081 So the current strategy is to inline all known-form constructors, and
1082 only do the reverse (turn a constructor application back into a
1083 variable) when we find a let-expression:
1087 ... (let y = C a1 .. an in ...) ...
1089 where it is always good to ditch the binding for y, and replace y by
1090 x. That's just what completeLetBinding does.
1096 -> InExpr -- Original RHS
1097 -> OutExpr -- The simplified RHS
1098 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1099 -> OutUniType -- Type of body
1102 completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
1104 -- See if RHS is an atom, or a reusable constructor
1105 | maybeToBool maybe_atomic_rhs
1107 new_env = extendIdEnvWithAtom env binder rhs_atom
1109 tick atom_tick_type `thenSmpl_`
1112 -- Maybe the rhs is an application of error, and sure to be demanded
1113 | will_be_demanded &&
1114 maybeToBool maybe_error_app
1115 = tick CaseOfError `thenSmpl_`
1116 returnSmpl retyped_error_app
1120 = cloneId env binder `thenSmpl` \ id' ->
1122 env1 = extendIdEnvWithClone env binder id'
1123 new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
1125 body_c new_env `thenSmpl` \ body' ->
1126 returnSmpl (CoLet (CoNonRec id' new_rhs) body')
1129 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1130 try_to_reuse_constr = switchIsSet env SimplReuseCon
1132 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1134 maybe_atomic_rhs :: Maybe (OutAtom, TickType)
1135 -- If the RHS is atomic, we return Just (atom, tick type)
1136 -- otherwise Nothing
1140 CoVar var -> Just (CoVarAtom var, AtomicRhs)
1142 CoLit lit | not (isNoRepLit lit)
1143 -> Just (CoLitAtom lit, AtomicRhs)
1145 CoCon con tys con_args
1146 | try_to_reuse_constr
1150 --- ...(let w = C same-args in ...)...
1151 -- Then use v instead of w. This may save
1152 -- re-constructing an existing constructor.
1153 -> case lookForConstructor env con tys con_args of
1155 Just var -> Just (CoVarAtom var, ConReused)
1159 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1160 Just retyped_error_app = maybe_error_app
1163 %************************************************************************
1165 \subsection[Simplify-atoms]{Simplifying atoms}
1167 %************************************************************************
1170 simplAtom :: SimplEnv -> InAtom -> OutAtom
1172 simplAtom env (CoLitAtom lit) = CoLitAtom lit
1174 simplAtom env (CoVarAtom id)
1175 | isLocallyDefined id
1176 = case lookupId env id of
1177 Just (ItsAnAtom atom) -> atom
1178 Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1179 Nothing -> CoVarAtom id -- Must be an uncloned thing
1182 = -- Not locally defined, so no change
1187 %************************************************************************
1189 \subsection[Simplify-quickies]{Some local help functions}
1191 %************************************************************************
1195 -- fix_up_demandedness switches off the willBeDemanded Info field
1196 -- for bindings floated out of a non-demanded let
1197 fix_up_demandedness True {- Will be demanded -} bind
1198 = bind -- Simple; no change to demand info needed
1199 fix_up_demandedness False {- May not be demanded -} (CoNonRec binder rhs)
1200 = CoNonRec (un_demandify binder) rhs
1201 fix_up_demandedness False {- May not be demanded -} (CoRec pairs)
1202 = CoRec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1204 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1206 is_cheap_prim_app (CoPrim op tys args) = primOpOkForSpeculation op
1207 is_cheap_prim_app other = False
1209 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
1210 computeResultType env expr args
1213 expr_ty = typeOfCoreExpr (unTagBinders expr)
1214 expr_ty' = simplTy env expr_ty
1217 do ty (TypeArg ty_arg : args) = do (applyTy ty ty_arg) args
1218 do ty (ValArg a : args) = case maybeUnpackFunTy ty of
1219 Just (_, res_ty) -> do res_ty args
1220 Nothing -> panic "computeResultType"