2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[Simplify]{The main module of the simplifier}
7 #include "HsVersions.h"
9 module Simplify ( simplTopBinds, simplExpr, simplBind ) where
12 import SmplLoop -- paranoia checking
15 import CmdLineOpts ( SimplifierSwitch(..) )
16 import ConFold ( completePrim )
18 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
19 unTagBinders, squashableDictishCcExpr,
22 import Id ( idType, idWantsToBeINLINEd,
23 getIdDemandInfo, addIdDemandInfo,
24 GenId{-instance NamedThing-}
26 import IdInfo ( willBeDemanded, DemandInfo )
27 import Literal ( isNoRepLit )
28 import Maybes ( maybeToBool )
29 import Outputable ( isLocallyDefined )
30 import PprStyle ( PprStyle(..) )
31 import PprType ( GenType{-instance Outputable-} )
32 import PrelInfo ( realWorldStateTy )
33 import Pretty ( ppAbove )
34 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
35 import SimplCase ( simplCase, bindLargeRhs )
38 import SimplVar ( completeVar )
40 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
41 splitFunTy, getFunTy_maybe, eqTy
43 import Util ( isSingleton, panic, pprPanic, assertPanic )
46 The controlling flags, and what they do
47 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
51 -fsimplify = run the simplifier
52 -ffloat-inwards = runs the float lets inwards pass
53 -ffloat = runs the full laziness pass
54 (ToDo: rename to -ffull-laziness)
55 -fupdate-analysis = runs update analyser
56 -fstrictness = runs strictness analyser
57 -fsaturate-apps = saturates applications (eta expansion)
61 -ffloat-past-lambda = OK to do full laziness.
62 (ToDo: remove, as the full laziness pass is
63 useless without this flag, therefore
64 it is unnecessary. Just -ffull-laziness
67 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
68 let is strict or if the floating will expose
71 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
72 is a primop that cannot fail [simplifier].
74 -fcode-duplication-ok = allows the previous option to work on cases with
75 multiple branches [simplifier].
77 -flet-to-case = does let-to-case transformation [simplifier].
79 -fcase-of-case = does case of case transformation [simplifier].
81 -fpedantic-bottoms = does not allow:
82 case x of y -> e ===> e[x/y]
83 (which may turn bottom into non-bottom)
89 Inlining is one of the delicate aspects of the simplifier. By
90 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
91 the RHS of x's definition. Thus
93 let x = e in ...x... ===> let x = e in ...e...
95 We have two mechanisms for inlining:
97 1. Unconditional. The occurrence analyser has pinned an (OneOcc
98 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
99 certainly safe to inline this variable, and to drop its binding''.
100 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
101 happy to be duplicating code...) When it encounters such a beast, the
102 simplifer binds the variable to its RHS (in the id_env) and continues.
103 It doesn't even look at the RHS at that stage. It also drops the
106 2. Conditional. In all other situations, the simplifer simplifies
107 the RHS anyway, and keeps the new binding. It also binds the new
108 (cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
110 Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
111 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
112 the variable has an INLINE pragma on it). The idea is that anything
113 in the UnfoldEnv is safe to use, but also has an enclosing binding if
114 you decide not to use it.
118 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
121 At one time I thought it would be OK to put non-HNF unfoldings in for
122 variables which occur only once [if they got inlined at that
123 occurrence the RHS of the binding would become dead, so no duplication
124 would occur]. But consider:
127 f = \y -> ...y...y...y...
130 Now, it seems that @x@ appears only once, but even so it is NOT safe
131 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
132 duplicate the references to @x@.
134 Because of this, the "unconditional-inline" mechanism above is the
135 only way in which non-HNFs can get inlined.
140 When a variable has an INLINE pragma on it --- which includes wrappers
141 produced by the strictness analyser --- we treat it rather carefully.
143 For a start, we are careful not to substitute into its RHS, because
144 that might make it BIG, and the user said "inline exactly this", not
145 "inline whatever you get after inlining other stuff inside me". For
149 in {-# INLINE y #-} y = f 3
152 Here we don't want to substitute BIG for the (single) occurrence of f,
153 because then we'd duplicate BIG when we inline'd y. (Exception:
154 things in the UnfoldEnv with UnfoldAlways flags, which originated in
155 other INLINE pragmas.)
157 So, we clean out the UnfoldEnv of all GenForm inlinings before
158 going into such an RHS.
160 What about imports? They don't really matter much because we only
161 inline relatively small things via imports.
163 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
164 INLINE pragma. We also do this for the RHSs of recursive decls,
165 before looking at the recursive decls. That way we achieve the effect
166 of inlining a wrapper in the body of its worker, in the case of a
167 mutually-recursive worker/wrapper split.
170 %************************************************************************
172 \subsection[Simplify-simplExpr]{The main function: simplExpr}
174 %************************************************************************
176 At the top level things are a little different.
178 * No cloning (not allowed for exported Ids, unnecessary for the others)
180 * No floating. Case floating is obviously out. Let floating is
181 theoretically OK, but dangerous because of space leaks.
182 The long-distance let-floater lifts these lets.
185 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
187 simplTopBinds env [] = returnSmpl []
189 -- Dead code is now discarded by the occurrence analyser,
191 simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
192 | inlineUnconditionally ok_to_dup_code occ_info
194 new_env = extendIdEnvWithInlining env env binder rhs
196 simplTopBinds new_env binds
198 ok_to_dup_code = switchIsSet env SimplOkToDupCode
200 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
201 = -- No cloning necessary at top level
202 -- Process the binding
203 simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
205 new_env = case rhs' of
206 Var v -> extendIdEnvWithAtom env binder (VarArg v)
207 Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
208 other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
210 -- Process the other bindings
211 simplTopBinds new_env binds `thenSmpl` \ binds' ->
213 -- Glue together and return ...
214 -- We leave it to susequent occurrence analysis to throw away
215 -- an unused atom binding. This localises the decision about
216 -- discarding top-level bindings.
217 returnSmpl (NonRec in_id rhs' : binds')
219 simplTopBinds env (Rec pairs : binds)
220 = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
222 -- Process the other bindings
223 simplTopBinds new_env binds `thenSmpl` \ binds' ->
225 -- Glue together and return
226 returnSmpl (bind' : binds')
228 triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
229 -- No cloning necessary at top level
232 %************************************************************************
234 \subsection[Simplify-simplExpr]{The main function: simplExpr}
236 %************************************************************************
240 simplExpr :: SimplEnv
241 -> InExpr -> [OutArg]
245 The expression returned has the same meaning as the input expression
246 applied to the specified arguments.
251 Check if there's a macro-expansion, and if so rattle on. Otherwise do
252 the more sophisticated stuff.
255 simplExpr env (Var v) args
256 = case (lookupId env v) of
258 new_v = simplTyInId env v
260 completeVar env new_v args
264 ItsAnAtom (LitArg lit) -- A boring old literal
265 -- Paranoia check for args empty
267 [] -> returnSmpl (Lit lit)
268 other -> panic "simplExpr:coVar"
270 ItsAnAtom (VarArg var) -- More interesting! An id!
271 -- No need to substitute the type env here,
272 -- because we already have!
273 -> completeVar env var args
275 InlineIt id_env ty_env in_expr -- A macro-expansion
276 -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
283 simplExpr env (Lit l) [] = returnSmpl (Lit l)
285 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
289 Primitive applications are simple.
290 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
292 NB: Prim expects an empty argument list! (Because it should be
293 saturated and not higher-order. ADR)
296 simplExpr env (Prim op prim_args) args
299 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
302 completePrim env op' prim_args'
304 -- PrimOps just need any types in them renamed.
306 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
308 arg_tys' = map (simplTy env) arg_tys
309 result_ty' = simplTy env result_ty
311 CCallOp label is_asm may_gc arg_tys' result_ty'
313 simpl_op other_op = other_op
316 Constructor applications
317 ~~~~~~~~~~~~~~~~~~~~~~~~
318 Nothing to try here. We only reuse constructors when they appear as the
319 rhs of a let binding (see completeLetBinding).
322 simplExpr env (Con con con_args) args
323 = ASSERT( null args )
324 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
328 Applications are easy too:
329 ~~~~~~~~~~~~~~~~~~~~~~~~~~
330 Just stuff 'em in the arg stack
333 simplExpr env (App fun arg) args
334 = simplExpr env fun (simplArg env arg : args)
340 We only eta-reduce a type lambda if all type arguments in the body can
341 be eta-reduced. This requires us to collect up all tyvar parameters so
342 we can pass them all to @mkTyLamTryingEta@.
345 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
346 = -- ASSERT(not (isPrimType ty))
348 new_env = extendTyEnv env tyvar ty
350 tick TyBetaReduction `thenSmpl_`
351 simplExpr new_env body args
353 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
354 = do_tylambdas env [] tylam
356 do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
357 = -- Clone the type variable
358 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
360 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
362 do_tylambdas new_env (tyvar':tyvars') body
364 do_tylambdas env tyvars' body
365 = simplExpr env body [] `thenSmpl` \ body' ->
367 (if switchIsSet env SimplDoEtaReduction
368 then mkTyLamTryingEta
369 else mkTyLam) (reverse tyvars') body'
373 simplExpr env (Lam (TyBinder _) _) (_ : _)
374 = panic "simplExpr:TyLam with non-TyArg"
383 simplExpr env (Lam (ValBinder binder) body) args
384 | null leftover_binders
385 = -- The lambda is saturated (or over-saturated)
386 tick BetaReduction `thenSmpl_`
387 simplExpr env_for_enough_args body leftover_args
390 = -- Too few args to saturate the lambda
391 ASSERT( null leftover_args )
393 (if not (null args) -- ah, we must've gotten rid of some...
394 then tick BetaReduction
395 else returnSmpl (panic "BetaReduction")
398 simplLam env_for_too_few_args leftover_binders body
399 0 {- Guaranteed applied to at least 0 args! -}
402 (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
404 env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
406 env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
408 -- Since there aren't enough args the binders we are cancelling with
409 -- the args supplied are, in effect, ocurring inside a lambda.
410 -- So we modify their occurrence info to reflect this fact.
411 -- Example: (\ x y z -> e) p q
412 -- ==> (\z -> e[p/x, q/y])
413 -- but we should behave as if x and y are marked "inside lambda".
414 -- The occurrence analyser does not mark them so itself because then we
415 -- do badly on the very common case of saturated lambdas applications:
416 -- (\ x y z -> e) p q r
417 -- ==> e[p/x, q/y, r/z]
419 zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
420 | ((id, occ_info), arg) <- binder_args_pairs ]
422 collect_val_args :: InBinder -- Binder
423 -> [OutArg] -- Arguments
424 -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
425 [InBinder], -- Leftover binders (ToDo: a maybe)
426 [OutArg]) -- Leftover args
428 -- collect_val_args strips off the leading ValArgs from
429 -- the current arg list, returning them along with the
431 collect_val_args binder [] = ([], [binder], [])
432 collect_val_args binder (arg : args) | isValArg arg
433 = ([(binder,arg)], [], args)
436 collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
437 -- TyArg should never meet a Lam
446 simplExpr env (Let bind body) args
447 | not (switchIsSet env SimplNoLetFromApp) -- The common case
448 = simplBind env bind (\env -> simplExpr env body args)
449 (computeResultType env body args)
451 | otherwise -- No float from application
452 = simplBind env bind (\env -> simplExpr env body [])
453 (computeResultType env body []) `thenSmpl` \ let_expr' ->
454 returnSmpl (mkGenApp let_expr' args)
461 simplExpr env expr@(Case scrut alts) args
462 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
463 (computeResultType env expr args)
470 A special case we do:
472 scc "foo" (\x -> e) ===> \x -> scc "foo" e
474 Simon thinks it's OK, at least for lexical scoping; and it makes
475 interfaces change less (arities).
478 simplExpr env (SCC cc (Lam binder body)) args
479 = simplExpr env (Lam binder (SCC cc body)) args
482 Some other slightly turgid SCC tidying-up cases:
484 simplExpr env (SCC cc1 expr@(SCC _ _)) args
485 = simplExpr env expr args
486 -- the outer _scc_ serves no purpose
488 simplExpr env (SCC cc expr) args
489 | squashableDictishCcExpr cc expr
490 = simplExpr env expr args
491 -- the DICT-ish CC is no longer serving any purpose
494 NB: for other set-cost-centre we move arguments inside the body.
495 ToDo: check with Patrick that this is ok.
498 simplExpr env (SCC cost_centre body) args
500 new_env = setEnclosingCC env (EnclosingCC cost_centre)
502 simplExpr new_env body args `thenSmpl` \ body' ->
503 returnSmpl (SCC cost_centre body')
506 %************************************************************************
508 \subsection{Simplify RHS of a Let/Letrec}
510 %************************************************************************
512 simplRhsExpr does arity-expansion. That is, given:
514 * a right hand side /\ tyvars -> \a1 ... an -> e
515 * the information (stored in BinderInfo) that the function will always
516 be applied to at least k arguments
518 it transforms the rhs to
520 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
522 This is a Very Good Thing!
531 simplRhsExpr env binder@(id,occ_info) rhs
532 | dont_eta_expand rhs
533 = simplExpr rhs_env rhs []
535 | otherwise -- Have a go at eta expansion
536 = -- Deal with the big lambda part
537 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
539 lam_env = extendTyEnvList rhs_env (tyvars `zip` (mkTyVarTys tyvars'))
541 -- Deal with the little lambda part
542 -- Note that we call simplLam even if there are no binders, in case
543 -- it can do arity expansion.
544 simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
546 -- Put it back together
548 (if switchIsSet env SimplDoEtaReduction
549 then mkTyLamTryingEta
550 else mkTyLam) tyvars' lambda'
554 -- If you say {-# INLINE #-} then you get what's coming to you;
555 -- you are saying inline the rhs, please.
556 -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
557 rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
560 (uvars, tyvars, binders, body) = collectBinders rhs
562 min_no_of_args | not (null binders) && -- It's not a thunk
563 switchIsSet env SimplDoArityExpand -- Arity expansion on
564 = getBinderInfoArity occ_info - length binders
566 | otherwise -- Not a thunk
569 -- dont_eta_expand prevents eta expansion in silly situations.
570 -- For example, consider the defn
572 -- It would be silly to eta expand the "y", because it would just
573 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
574 -- and x was exported, then the defn won't be eliminated, so this
575 -- silly expand/reduce cycle will happen every time, which makes the
577 -- The solution is to not even try eta expansion unless the rhs looks
579 dont_eta_expand (Lit _) = True
580 dont_eta_expand (Var _) = True
581 dont_eta_expand (Con _ _) = True
582 dont_eta_expand (App f a)
583 | notValArg a = dont_eta_expand f
584 dont_eta_expand (Lam x b)
585 | notValBinder x = dont_eta_expand b
586 dont_eta_expand _ = False
590 %************************************************************************
592 \subsection{Simplify a lambda abstraction}
594 %************************************************************************
596 Simplify (\binders -> body) trying eta expansion and reduction, given that
597 the abstraction will always be applied to at least min_no_of_args.
600 simplLam env binders body min_no_of_args
601 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
602 null potential_extra_binder_tys || -- or ain't a function
603 no_of_extra_binders == 0 -- or no extra binders needed
604 = cloneIds env binders `thenSmpl` \ binders' ->
606 new_env = extendIdEnvWithClones env binders binders'
608 simplExpr new_env body [] `thenSmpl` \ body' ->
610 (if switchIsSet new_env SimplDoEtaReduction
611 then mkValLamTryingEta
612 else mkValLam) binders' body'
615 | otherwise -- Eta expansion possible
616 = tick EtaExpansion `thenSmpl_`
617 cloneIds env binders `thenSmpl` \ binders' ->
619 new_env = extendIdEnvWithClones env binders binders'
621 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
622 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
624 (if switchIsSet new_env SimplDoEtaReduction
625 then mkValLamTryingEta
626 else mkValLam) (binders' ++ extra_binders') body'
630 (potential_extra_binder_tys, res_ty)
631 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
632 -- Note: it's possible that simplLam will be applied to something
633 -- with a forall type. Eg when being applied to the rhs of
635 -- where wurble has a forall-type, but no big lambdas at the top.
636 -- We could be clever an insert new big lambdas, but we don't bother.
638 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
640 no_of_extra_binders = -- First, use the info about how many args it's
641 -- always applied to in its scope
644 -- Next, try seeing if there's a lambda hidden inside
649 -- Finally, see if it's a state transformer, in which
650 -- case we eta-expand on principle! This can waste work,
651 -- but usually doesn't
653 case potential_extra_binder_tys of
654 [ty] | ty `eqTy` realWorldStateTy -> 1
660 %************************************************************************
662 \subsection[Simplify-let]{Let-expressions}
664 %************************************************************************
667 simplBind :: SimplEnv
669 -> (SimplEnv -> SmplM OutExpr)
674 When floating cases out of lets, remember this:
676 let x* = case e of alts
679 where x* is sure to be demanded or e is a cheap operation that cannot
680 fail, e.g. unboxed addition. Here we should be prepared to duplicate
681 <small expr>. A good example:
690 p1 -> foldr c n (build e1)
691 p2 -> foldr c n (build e2)
693 NEW: We use the same machinery that we use for case-of-case to
694 *always* do case floating from let, that is we let bind and abstract
695 the original let body, and let the occurrence analyser later decide
696 whether the new let should be inlined or not. The example above
700 let join_body x' = foldr c n x'
702 p1 -> let x* = build e1
704 p2 -> let x* = build e2
707 note that join_body is a let-no-escape.
708 In this particular example join_body will later be inlined,
709 achieving the same effect.
710 ToDo: check this is OK with andy
715 -- Dead code is now discarded by the occurrence analyser,
717 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
718 | inlineUnconditionally ok_to_dup occ_info
719 = body_c (extendIdEnvWithInlining env env binder rhs)
722 -- It's important to try let-to-case before floating. Consider
724 -- let a*::Int = case v of {p1->e1; p2->e2}
727 -- (The * means that a is sure to be demanded.)
728 -- If we do case-floating first we get this:
732 -- p1-> let a*=e1 in k a
733 -- p2-> let a*=e2 in k a
735 -- Now watch what happens if we do let-to-case first:
737 -- case (case v of {p1->e1; p2->e2}) of
738 -- Int a# -> let a*=I# a# in b
740 -- let k = \a# -> let a*=I# a# in b
742 -- p1 -> case e1 of I# a# -> k a#
743 -- p1 -> case e1 of I# a# -> k a#
745 -- The latter is clearly better. (Remember the reboxing let-decl
746 -- for a is likely to go away, because after all b is strict in a.)
748 | will_be_demanded &&
750 type_ok_for_let_to_case rhs_ty &&
751 not (manifestlyWHNF rhs)
752 -- note: no "manifestlyBottom rhs" in there... (comment below)
753 = tick Let2Case `thenSmpl_`
754 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
755 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
757 We do not do let to case for WHNFs, e.g.
763 as this is less efficient.
764 but we don't mind doing let-to-case for "bottom", as that
766 allow us to remove more dead code, if anything:
769 case error of x -> ...
773 Notice that let to case occurs only if x is used strictly in
774 its body (obviously).
777 | (will_be_demanded && not no_float) ||
778 always_float_let_from_let ||
779 floatExposesHNF float_lets float_primops ok_to_dup rhs
780 = try_float env rhs body_c
783 = done_float env rhs body_c
786 will_be_demanded = willBeDemanded (getIdDemandInfo id)
789 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
790 float_primops = switchIsSet env SimplOkToFloatPrimOps
791 ok_to_dup = switchIsSet env SimplOkToDupCode
792 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
793 try_let_to_case = switchIsSet env SimplLetToCase
794 no_float = switchIsSet env SimplNoLetFromStrictLet
796 -------------------------------------------
797 done_float env rhs body_c
798 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
799 completeLet env binder rhs rhs' body_c body_ty
801 ---------------------------------------
802 try_float env (Let bind rhs) body_c
803 = tick LetFloatFromLet `thenSmpl_`
804 simplBind env (fix_up_demandedness will_be_demanded bind)
805 (\env -> try_float env rhs body_c) body_ty
807 try_float env (Case scrut alts) body_c
808 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
809 = tick CaseFloatFromLet `thenSmpl_`
811 -- First, bind large let-body if necessary
812 if no_need_to_bind_large_body then
813 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
815 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
817 body_c' = \env -> simplExpr env new_body []
819 simplCase env scrut alts
820 (\env rhs -> try_float env rhs body_c')
821 body_ty `thenSmpl` \ case_expr ->
823 returnSmpl (Let extra_binding case_expr)
825 no_need_to_bind_large_body
826 = ok_to_dup || isSingleton (nonErrorRHSs alts)
828 try_float env other_rhs body_c = done_float env other_rhs body_c
834 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
835 on and it'll expose a HNF), and bang the whole resulting mess together
838 1. Any "macros" should be expanded. The main application of this
847 Here we would like the single call to g to be inlined.
849 We can spot this easily, because g will be tagged as having just one
850 occurrence. The "inlineUnconditionally" predicate is just what we want.
852 A worry: could this lead to non-termination? For example:
861 Here, f and g call each other (just once) and neither is used elsewhere.
864 * the occurrence analyser will drop any (sub)-group that isn't used at
867 * If the group is used outside itself (ie in the "in" part), then there
870 ** IMPORTANT: check that NewOccAnal has the property that a group of
871 bindings like the above has f&g dropped.! ***
874 2. We'd also like to pull out any top-level let(rec)s from the
878 f = let h = ... in \x -> ....h...f...h...
884 f = \x -> ....h...f...h...
888 But floating cases is less easy? (Don't for now; ToDo?)
891 3. We'd like to arrange that the RHSs "know" about members of the
892 group that are bound to constructors. For example:
896 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
897 /= a b = unpack tuple a, unpack tuple b, call f
900 here, by knowing about d.Eq in f's rhs, one could get rid of
901 the case (and break out the recursion completely).
902 [This occurred with more aggressive inlining threshold (4),
903 nofib/spectral/knights]
906 1: we simplify constructor rhss first.
907 2: we record the "known constructors" in the environment
908 3: we simplify the other rhss, with the knowledge about the constructors
913 simplBind env (Rec pairs) body_c body_ty
914 = -- Do floating, if necessary
915 (if float_lets || always_float_let_from_let
917 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
918 returnSmpl (concat floated_pairs_s)
921 ) `thenSmpl` \ floated_pairs ->
923 binders = map fst floated_pairs
925 cloneIds env binders `thenSmpl` \ ids' ->
927 env_w_clones = extendIdEnvWithClones env binders ids'
928 triples = ids' `zip` floated_pairs
931 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
933 body_c new_env `thenSmpl` \ body' ->
935 returnSmpl (Let binding body')
938 ------------ Floating stuff -------------------
940 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
941 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
945 pairs_s = float_pair (binder,rhs)
948 [_] -> returnSmpl pairs_s
950 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
951 -- It's important to increment the tick counts if we
952 -- do any floating. A situation where this turns out
953 -- to be important is this:
954 -- Float in produces:
955 -- letrec x = let y = Ey in Ex
957 -- Now floating gives this:
961 --- We now want to iterate once more in case Ey doesn't
962 -- mention x, in which case the y binding can be pulled
963 -- out as an enclosing let(rec), which in turn gives
964 -- the strictness analyser more chance.
967 float_pairs pairs = concat (map float_pair pairs)
969 float_pair (binder, rhs)
970 | always_float_let_from_let ||
971 floatExposesHNF True False False rhs
972 = (binder,rhs') : pairs'
977 (pairs', rhs') = do_float rhs
979 -- Float just pulls out any top-level let(rec) bindings
980 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
981 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
983 (pairs', body') = do_float body
984 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
986 (pairs', body') = do_float body
987 do_float other = ([], other)
989 simplRecursiveGroup env triples
990 = -- Toss out all the dead pairs? No, there shouldn't be any!
991 -- Dead code is discarded by the occurrence analyser
993 -- Separate the live triples into "inline"able and
994 -- "ordinary" We're paranoid about duplication!
995 (inline_triples, ordinary_triples)
996 = partition is_inline_triple triples
998 is_inline_triple (_, ((_,occ_info),_))
999 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1001 -- Now add in the inline_pairs info (using "env_w_clones"),
1002 -- so that we will save away suitably-clone-laden envs
1003 -- inside the InlineIts...).
1005 -- NOTE ALSO that we tie a knot here, because the
1006 -- saved-away envs must also include these very inlinings
1007 -- (they aren't stored anywhere else, and a late one might
1008 -- be used in an early one).
1010 env_w_inlinings = foldl add_inline env inline_triples
1012 add_inline env (id', (binder,rhs))
1013 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1015 -- Separate the remaining bindings into the ones which
1016 -- need to be dealt with first (the "early" ones)
1017 -- and the others (the "late" ones)
1018 (early_triples, late_triples)
1019 = partition is_early_triple ordinary_triples
1021 is_early_triple (_, (_, Con _ _)) = True
1022 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1024 -- Process the early bindings first
1025 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1027 -- Now further extend the environment to record our knowledge
1028 -- about the form of the binders bound in the constructor bindings
1030 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1031 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1033 -- Now process the non-constructor bindings
1034 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1038 binding = Rec (map snd early_triples' ++ map snd late_triples')
1040 returnSmpl (binding, env_w_early_info)
1043 do_one_binding env (id', (binder,rhs))
1044 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1045 returnSmpl (binder, (id', rhs'))
1049 @completeLet@ looks at the simplified post-floating RHS of the
1050 let-expression, and decides what to do. There's one interesting
1051 aspect to this, namely constructor reuse. Consider
1057 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1058 bit on the compiler technology, but in general I believe not. For
1059 example, here's some code from a real program:
1061 const.Int.max.wrk{-s2516-} =
1062 \ upk.s3297# upk.s3298# ->
1066 a.s3299 = I#! upk.s3297#
1068 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1069 _LT -> I#! upk.s3298#
1074 The a.s3299 really isn't doing much good. We'd be better off inlining
1075 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1077 So the current strategy is to inline all known-form constructors, and
1078 only do the reverse (turn a constructor application back into a
1079 variable) when we find a let-expression:
1083 ... (let y = C a1 .. an in ...) ...
1085 where it is always good to ditch the binding for y, and replace y by
1086 x. That's just what completeLetBinding does.
1092 -> InExpr -- Original RHS
1093 -> OutExpr -- The simplified RHS
1094 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1095 -> OutType -- Type of body
1098 completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
1100 -- See if RHS is an atom, or a reusable constructor
1101 | maybeToBool maybe_atomic_rhs
1103 new_env = extendIdEnvWithAtom env binder rhs_atom
1105 tick atom_tick_type `thenSmpl_`
1108 -- Maybe the rhs is an application of error, and sure to be demanded
1109 | will_be_demanded &&
1110 maybeToBool maybe_error_app
1111 = tick CaseOfError `thenSmpl_`
1112 returnSmpl retyped_error_app
1116 = cloneId env binder `thenSmpl` \ id' ->
1118 env1 = extendIdEnvWithClone env binder id'
1119 new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
1121 body_c new_env `thenSmpl` \ body' ->
1122 returnSmpl (Let (NonRec id' new_rhs) body')
1125 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1126 try_to_reuse_constr = switchIsSet env SimplReuseCon
1128 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1130 maybe_atomic_rhs :: Maybe (OutArg, TickType)
1131 -- If the RHS is atomic, we return Just (atom, tick type)
1132 -- otherwise Nothing
1136 Var var -> Just (VarArg var, AtomicRhs)
1138 Lit lit | not (isNoRepLit lit)
1139 -> Just (LitArg lit, AtomicRhs)
1142 | try_to_reuse_constr
1146 --- ...(let w = C same-args in ...)...
1147 -- Then use v instead of w. This may save
1148 -- re-constructing an existing constructor.
1149 -> case (lookForConstructor env con con_args) of
1151 Just var -> Just (VarArg var, ConReused)
1155 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1156 Just retyped_error_app = maybe_error_app
1159 %************************************************************************
1161 \subsection[Simplify-atoms]{Simplifying atoms}
1163 %************************************************************************
1166 simplArg :: SimplEnv -> InArg -> OutArg
1168 simplArg env (LitArg lit) = LitArg lit
1169 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1171 simplArg env (VarArg id)
1172 | isLocallyDefined id
1173 = case lookupId env id of
1174 Just (ItsAnAtom atom) -> atom
1175 Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1176 Nothing -> VarArg id -- Must be an uncloned thing
1179 = -- Not locally defined, so no change
1184 %************************************************************************
1186 \subsection[Simplify-quickies]{Some local help functions}
1188 %************************************************************************
1192 -- fix_up_demandedness switches off the willBeDemanded Info field
1193 -- for bindings floated out of a non-demanded let
1194 fix_up_demandedness True {- Will be demanded -} bind
1195 = bind -- Simple; no change to demand info needed
1196 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1197 = NonRec (un_demandify binder) rhs
1198 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1199 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1201 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1203 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1204 is_cheap_prim_app other = False
1206 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1207 computeResultType env expr args
1210 expr_ty = coreExprType (unTagBinders expr)
1211 expr_ty' = simplTy env expr_ty
1214 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1215 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1216 Just (_, res_ty) -> go res_ty args
1217 Nothing -> panic "computeResultType"