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_DELOOPER(SmplLoop) -- paranoia checking
13 IMPORT_1_3(List(partition))
16 import CmdLineOpts ( SimplifierSwitch(..) )
17 import ConFold ( completePrim )
18 import CostCentre ( isSccCountCostCentre, cmpCostCentre )
20 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
21 unTagBinders, squashableDictishCcExpr,
24 import Id ( idType, idWantsToBeINLINEd,
25 getIdDemandInfo, addIdDemandInfo,
26 GenId{-instance NamedThing-}
28 import IdInfo ( willBeDemanded, DemandInfo )
29 import Literal ( isNoRepLit )
30 import Maybes ( maybeToBool )
31 import Name ( isLocallyDefined )
32 import PprStyle ( PprStyle(..) )
33 import PprType ( GenType{-instance Outputable-} )
34 import Pretty ( ppAbove )
35 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
36 import SimplCase ( simplCase, bindLargeRhs )
39 import SimplVar ( completeVar )
41 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
42 splitFunTy, getFunTy_maybe, eqTy
44 import TysWiredIn ( realWorldStateTy )
45 import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
48 The controlling flags, and what they do
49 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
53 -fsimplify = run the simplifier
54 -ffloat-inwards = runs the float lets inwards pass
55 -ffloat = runs the full laziness pass
56 (ToDo: rename to -ffull-laziness)
57 -fupdate-analysis = runs update analyser
58 -fstrictness = runs strictness analyser
59 -fsaturate-apps = saturates applications (eta expansion)
63 -ffloat-past-lambda = OK to do full laziness.
64 (ToDo: remove, as the full laziness pass is
65 useless without this flag, therefore
66 it is unnecessary. Just -ffull-laziness
69 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
70 let is strict or if the floating will expose
73 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
74 is a primop that cannot fail [simplifier].
76 -fcode-duplication-ok = allows the previous option to work on cases with
77 multiple branches [simplifier].
79 -flet-to-case = does let-to-case transformation [simplifier].
81 -fcase-of-case = does case of case transformation [simplifier].
83 -fpedantic-bottoms = does not allow:
84 case x of y -> e ===> e[x/y]
85 (which may turn bottom into non-bottom)
91 Inlining is one of the delicate aspects of the simplifier. By
92 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
93 the RHS of x's definition. Thus
95 let x = e in ...x... ===> let x = e in ...e...
97 We have two mechanisms for inlining:
99 1. Unconditional. The occurrence analyser has pinned an (OneOcc
100 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
101 certainly safe to inline this variable, and to drop its binding''.
102 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
103 happy to be duplicating code...) When it encounters such a beast, the
104 simplifer binds the variable to its RHS (in the id_env) and continues.
105 It doesn't even look at the RHS at that stage. It also drops the
108 2. Conditional. In all other situations, the simplifer simplifies
109 the RHS anyway, and keeps the new binding. It also binds the new
110 (cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
112 Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
113 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
114 the variable has an INLINE pragma on it). The idea is that anything
115 in the UnfoldEnv is safe to use, but also has an enclosing binding if
116 you decide not to use it.
120 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
123 At one time I thought it would be OK to put non-HNF unfoldings in for
124 variables which occur only once [if they got inlined at that
125 occurrence the RHS of the binding would become dead, so no duplication
126 would occur]. But consider:
129 f = \y -> ...y...y...y...
132 Now, it seems that @x@ appears only once, but even so it is NOT safe
133 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
134 duplicate the references to @x@.
136 Because of this, the "unconditional-inline" mechanism above is the
137 only way in which non-HNFs can get inlined.
142 When a variable has an INLINE pragma on it --- which includes wrappers
143 produced by the strictness analyser --- we treat it rather carefully.
145 For a start, we are careful not to substitute into its RHS, because
146 that might make it BIG, and the user said "inline exactly this", not
147 "inline whatever you get after inlining other stuff inside me". For
151 in {-# INLINE y #-} y = f 3
154 Here we don't want to substitute BIG for the (single) occurrence of f,
155 because then we'd duplicate BIG when we inline'd y. (Exception:
156 things in the UnfoldEnv with UnfoldAlways flags, which originated in
157 other INLINE pragmas.)
159 So, we clean out the UnfoldEnv of all GenForm inlinings before
160 going into such an RHS.
162 What about imports? They don't really matter much because we only
163 inline relatively small things via imports.
165 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
166 INLINE pragma. We also do this for the RHSs of recursive decls,
167 before looking at the recursive decls. That way we achieve the effect
168 of inlining a wrapper in the body of its worker, in the case of a
169 mutually-recursive worker/wrapper split.
172 %************************************************************************
174 \subsection[Simplify-simplExpr]{The main function: simplExpr}
176 %************************************************************************
178 At the top level things are a little different.
180 * No cloning (not allowed for exported Ids, unnecessary for the others)
182 * No floating. Case floating is obviously out. Let floating is
183 theoretically OK, but dangerous because of space leaks.
184 The long-distance let-floater lifts these lets.
187 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
189 simplTopBinds env [] = returnSmpl []
191 -- Dead code is now discarded by the occurrence analyser,
193 simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
194 | inlineUnconditionally ok_to_dup_code occ_info
196 new_env = extendIdEnvWithInlining env env binder rhs
198 simplTopBinds new_env binds
200 ok_to_dup_code = switchIsSet env SimplOkToDupCode
202 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
203 = -- No cloning necessary at top level
204 -- Process the binding
205 simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
207 new_env = case rhs' of
208 Var v -> extendIdEnvWithAtom env binder (VarArg v)
209 Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
210 other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
212 -- Process the other bindings
213 simplTopBinds new_env binds `thenSmpl` \ binds' ->
215 -- Glue together and return ...
216 -- We leave it to susequent occurrence analysis to throw away
217 -- an unused atom binding. This localises the decision about
218 -- discarding top-level bindings.
219 returnSmpl (NonRec in_id rhs' : binds')
221 simplTopBinds env (Rec pairs : binds)
222 = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
224 -- Process the other bindings
225 simplTopBinds new_env binds `thenSmpl` \ binds' ->
227 -- Glue together and return
228 returnSmpl (bind' : binds')
230 triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
231 -- No cloning necessary at top level
234 %************************************************************************
236 \subsection[Simplify-simplExpr]{The main function: simplExpr}
238 %************************************************************************
242 simplExpr :: SimplEnv
243 -> InExpr -> [OutArg]
247 The expression returned has the same meaning as the input expression
248 applied to the specified arguments.
253 Check if there's a macro-expansion, and if so rattle on. Otherwise do
254 the more sophisticated stuff.
257 simplExpr env (Var v) args
258 = case (lookupId env v) of
260 new_v = simplTyInId env v
262 completeVar env new_v args
266 ItsAnAtom (LitArg lit) -- A boring old literal
267 -- Paranoia check for args empty
269 [] -> returnSmpl (Lit lit)
270 other -> panic "simplExpr:coVar"
272 ItsAnAtom (VarArg var) -- More interesting! An id!
273 -- No need to substitute the type env here,
274 -- because we already have!
275 -> completeVar env var args
277 InlineIt id_env ty_env in_expr -- A macro-expansion
278 -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
285 simplExpr env (Lit l) [] = returnSmpl (Lit l)
287 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
291 Primitive applications are simple.
292 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
294 NB: Prim expects an empty argument list! (Because it should be
295 saturated and not higher-order. ADR)
298 simplExpr env (Prim op prim_args) args
301 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
304 completePrim env op' prim_args'
306 -- PrimOps just need any types in them renamed.
308 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
310 arg_tys' = map (simplTy env) arg_tys
311 result_ty' = simplTy env result_ty
313 CCallOp label is_asm may_gc arg_tys' result_ty'
315 simpl_op other_op = other_op
318 Constructor applications
319 ~~~~~~~~~~~~~~~~~~~~~~~~
320 Nothing to try here. We only reuse constructors when they appear as the
321 rhs of a let binding (see completeLetBinding).
324 simplExpr env (Con con con_args) args
325 = ASSERT( null args )
326 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
330 Applications are easy too:
331 ~~~~~~~~~~~~~~~~~~~~~~~~~~
332 Just stuff 'em in the arg stack
335 simplExpr env (App fun arg) args
336 = simplExpr env fun (simplArg env arg : args)
342 We only eta-reduce a type lambda if all type arguments in the body can
343 be eta-reduced. This requires us to collect up all tyvar parameters so
344 we can pass them all to @mkTyLamTryingEta@.
347 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
348 = -- ASSERT(not (isPrimType ty))
350 new_env = extendTyEnv env tyvar ty
352 tick TyBetaReduction `thenSmpl_`
353 simplExpr new_env body args
355 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
356 = do_tylambdas env [] tylam
358 do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
359 = -- Clone the type variable
360 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
362 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
364 do_tylambdas new_env (tyvar':tyvars') body
366 do_tylambdas env tyvars' body
367 = simplExpr env body [] `thenSmpl` \ body' ->
369 (if switchIsSet env SimplDoEtaReduction
370 then mkTyLamTryingEta
371 else mkTyLam) (reverse tyvars') body'
375 simplExpr env (Lam (TyBinder _) _) (_ : _)
376 = panic "simplExpr:TyLam with non-TyArg"
385 simplExpr env (Lam (ValBinder binder) body) args
386 | null leftover_binders
387 = -- The lambda is saturated (or over-saturated)
388 tick BetaReduction `thenSmpl_`
389 simplExpr env_for_enough_args body leftover_args
392 = -- Too few args to saturate the lambda
393 ASSERT( null leftover_args )
395 (if not (null args) -- ah, we must've gotten rid of some...
396 then tick BetaReduction
397 else returnSmpl (panic "BetaReduction")
400 simplLam env_for_too_few_args leftover_binders body
401 0 {- Guaranteed applied to at least 0 args! -}
404 (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
406 env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
408 env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
410 -- Since there aren't enough args the binders we are cancelling with
411 -- the args supplied are, in effect, ocurring inside a lambda.
412 -- So we modify their occurrence info to reflect this fact.
413 -- Example: (\ x y z -> e) p q
414 -- ==> (\z -> e[p/x, q/y])
415 -- but we should behave as if x and y are marked "inside lambda".
416 -- The occurrence analyser does not mark them so itself because then we
417 -- do badly on the very common case of saturated lambdas applications:
418 -- (\ x y z -> e) p q r
419 -- ==> e[p/x, q/y, r/z]
421 zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
422 | ((id, occ_info), arg) <- binder_args_pairs ]
424 collect_val_args :: InBinder -- Binder
425 -> [OutArg] -- Arguments
426 -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
427 [InBinder], -- Leftover binders (ToDo: a maybe)
428 [OutArg]) -- Leftover args
430 -- collect_val_args strips off the leading ValArgs from
431 -- the current arg list, returning them along with the
433 collect_val_args binder [] = ([], [binder], [])
434 collect_val_args binder (arg : args) | isValArg arg
435 = ([(binder,arg)], [], args)
438 collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
439 -- TyArg should never meet a Lam
448 simplExpr env (Let bind body) args
450 {- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
451 and it doesn't seem worth retaining the ability to not float applications
454 | switchIsSet env SimplNoLetFromApp
455 = simplBind env bind (\env -> simplExpr env body [])
456 (computeResultType env body []) `thenSmpl` \ let_expr' ->
457 returnSmpl (mkGenApp let_expr' args)
459 | otherwise -- No float from application
462 = simplBind env bind (\env -> simplExpr env body args)
463 (computeResultType env body args)
470 simplExpr env expr@(Case scrut alts) args
471 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
472 (computeResultType env expr args)
479 simplExpr env (Coerce coercion ty body) args
480 = simplCoerce env coercion ty body args
487 1) Eliminating nested sccs ...
488 We must be careful to maintain the scc counts ...
491 simplExpr env (SCC cc1 (SCC cc2 expr)) args
492 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
493 -- eliminate inner scc if no call counts and same cc as outer
494 = simplExpr env (SCC cc1 expr) args
496 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
497 -- eliminate outer scc if no call counts associated with either ccs
498 = simplExpr env (SCC cc2 expr) args
501 2) Moving sccs inside lambdas ...
504 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args
505 | not (isSccCountCostCentre cc)
506 -- move scc inside lambda only if no call counts
507 = simplExpr env (Lam binder (SCC cc body)) args
509 simplExpr env (SCC cc (Lam binder body)) args
510 -- always ok to move scc inside type/usage lambda
511 = simplExpr env (Lam binder (SCC cc body)) args
514 3) Eliminating dict sccs ...
517 simplExpr env (SCC cc expr) args
518 | squashableDictishCcExpr cc expr
519 -- eliminate dict cc if trivial dict expression
520 = simplExpr env expr args
523 4) Moving arguments inside the body of an scc ...
524 This moves the cost of doing the application inside the scc
525 (which may include the cost of extracting methods etc)
528 simplExpr env (SCC cost_centre body) args
530 new_env = setEnclosingCC env (EnclosingCC cost_centre)
532 simplExpr new_env body args `thenSmpl` \ body' ->
533 returnSmpl (SCC cost_centre body')
536 %************************************************************************
538 \subsection{Simplify RHS of a Let/Letrec}
540 %************************************************************************
542 simplRhsExpr does arity-expansion. That is, given:
544 * a right hand side /\ tyvars -> \a1 ... an -> e
545 * the information (stored in BinderInfo) that the function will always
546 be applied to at least k arguments
548 it transforms the rhs to
550 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
552 This is a Very Good Thing!
561 simplRhsExpr env binder@(id,occ_info) rhs
562 | dont_eta_expand rhs
563 = simplExpr rhs_env rhs []
565 | otherwise -- Have a go at eta expansion
566 = -- Deal with the big lambda part
567 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
569 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
571 -- Deal with the little lambda part
572 -- Note that we call simplLam even if there are no binders, in case
573 -- it can do arity expansion.
574 simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
576 -- Put it back together
578 (if switchIsSet env SimplDoEtaReduction
579 then mkTyLamTryingEta
580 else mkTyLam) tyvars' lambda'
584 -- If you say {-# INLINE #-} then you get what's coming to you;
585 -- you are saying inline the rhs, please.
586 -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
587 rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
590 (uvars, tyvars, binders, body) = collectBinders rhs
592 min_no_of_args | not (null binders) && -- It's not a thunk
593 switchIsSet env SimplDoArityExpand -- Arity expansion on
594 = getBinderInfoArity occ_info - length binders
596 | otherwise -- Not a thunk
599 -- dont_eta_expand prevents eta expansion in silly situations.
600 -- For example, consider the defn
602 -- It would be silly to eta expand the "y", because it would just
603 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
604 -- and x was exported, then the defn won't be eliminated, so this
605 -- silly expand/reduce cycle will happen every time, which makes the
607 -- The solution is to not even try eta expansion unless the rhs looks
609 dont_eta_expand (Lit _) = True
610 dont_eta_expand (Var _) = True
611 dont_eta_expand (Con _ _) = True
612 dont_eta_expand (App f a)
613 | notValArg a = dont_eta_expand f
614 dont_eta_expand (Lam x b)
615 | notValBinder x = dont_eta_expand b
616 dont_eta_expand _ = False
620 %************************************************************************
622 \subsection{Simplify a lambda abstraction}
624 %************************************************************************
626 Simplify (\binders -> body) trying eta expansion and reduction, given that
627 the abstraction will always be applied to at least min_no_of_args.
630 simplLam env binders body min_no_of_args
631 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
632 null potential_extra_binder_tys || -- or ain't a function
633 no_of_extra_binders == 0 -- or no extra binders needed
634 = cloneIds env binders `thenSmpl` \ binders' ->
636 new_env = extendIdEnvWithClones env binders binders'
638 simplExpr new_env body [] `thenSmpl` \ body' ->
640 (if switchIsSet new_env SimplDoEtaReduction
641 then mkValLamTryingEta
642 else mkValLam) binders' body'
645 | otherwise -- Eta expansion possible
646 = tick EtaExpansion `thenSmpl_`
647 cloneIds env binders `thenSmpl` \ binders' ->
649 new_env = extendIdEnvWithClones env binders binders'
651 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
652 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
654 (if switchIsSet new_env SimplDoEtaReduction
655 then mkValLamTryingEta
656 else mkValLam) (binders' ++ extra_binders') body'
660 (potential_extra_binder_tys, res_ty)
661 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
662 -- Note: it's possible that simplLam will be applied to something
663 -- with a forall type. Eg when being applied to the rhs of
665 -- where wurble has a forall-type, but no big lambdas at the top.
666 -- We could be clever an insert new big lambdas, but we don't bother.
668 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
670 no_of_extra_binders = -- First, use the info about how many args it's
671 -- always applied to in its scope
674 -- Next, try seeing if there's a lambda hidden inside
679 -- Finally, see if it's a state transformer, in which
680 -- case we eta-expand on principle! This can waste work,
681 -- but usually doesn't
683 case potential_extra_binder_tys of
684 [ty] | ty `eqTy` realWorldStateTy -> 1
691 %************************************************************************
693 \subsection[Simplify-coerce]{Coerce expressions}
695 %************************************************************************
698 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
699 simplCoerce env coercion ty expr@(Case scrut alts) args
700 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
701 (computeResultType env expr args)
703 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
704 simplCoerce env coercion ty (Let bind body) args
705 = simplBind env bind (\env -> simplCoerce env coercion ty body args)
706 (computeResultType env body args)
709 simplCoerce env coercion ty expr args
710 = simplExpr env expr [] `thenSmpl` \ expr' ->
711 returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
714 -- Try cancellation; we do this "on the way up" because
715 -- I think that's where it'll bite best
716 mkCoerce (CoerceIn con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body
717 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
718 mkCoerce coercion ty body = Coerce coercion ty body
722 %************************************************************************
724 \subsection[Simplify-let]{Let-expressions}
726 %************************************************************************
729 simplBind :: SimplEnv
731 -> (SimplEnv -> SmplM OutExpr)
736 When floating cases out of lets, remember this:
738 let x* = case e of alts
741 where x* is sure to be demanded or e is a cheap operation that cannot
742 fail, e.g. unboxed addition. Here we should be prepared to duplicate
743 <small expr>. A good example:
752 p1 -> foldr c n (build e1)
753 p2 -> foldr c n (build e2)
755 NEW: We use the same machinery that we use for case-of-case to
756 *always* do case floating from let, that is we let bind and abstract
757 the original let body, and let the occurrence analyser later decide
758 whether the new let should be inlined or not. The example above
762 let join_body x' = foldr c n x'
764 p1 -> let x* = build e1
766 p2 -> let x* = build e2
769 note that join_body is a let-no-escape.
770 In this particular example join_body will later be inlined,
771 achieving the same effect.
772 ToDo: check this is OK with andy
777 -- Dead code is now discarded by the occurrence analyser,
779 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
780 | inlineUnconditionally ok_to_dup occ_info
781 = body_c (extendIdEnvWithInlining env env binder rhs)
784 -- It's important to try let-to-case before floating. Consider
786 -- let a*::Int = case v of {p1->e1; p2->e2}
789 -- (The * means that a is sure to be demanded.)
790 -- If we do case-floating first we get this:
794 -- p1-> let a*=e1 in k a
795 -- p2-> let a*=e2 in k a
797 -- Now watch what happens if we do let-to-case first:
799 -- case (case v of {p1->e1; p2->e2}) of
800 -- Int a# -> let a*=I# a# in b
802 -- let k = \a# -> let a*=I# a# in b
804 -- p1 -> case e1 of I# a# -> k a#
805 -- p1 -> case e1 of I# a# -> k a#
807 -- The latter is clearly better. (Remember the reboxing let-decl
808 -- for a is likely to go away, because after all b is strict in a.)
810 | will_be_demanded &&
812 type_ok_for_let_to_case rhs_ty &&
813 not (manifestlyWHNF rhs)
814 -- note: no "manifestlyBottom rhs" in there... (comment below)
815 = tick Let2Case `thenSmpl_`
816 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
817 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
819 We do not do let to case for WHNFs, e.g.
825 as this is less efficient.
826 but we don't mind doing let-to-case for "bottom", as that
828 allow us to remove more dead code, if anything:
831 case error of x -> ...
835 Notice that let to case occurs only if x is used strictly in
836 its body (obviously).
839 | (will_be_demanded && not no_float) ||
840 always_float_let_from_let ||
841 floatExposesHNF float_lets float_primops ok_to_dup rhs
842 = try_float env rhs body_c
845 = done_float env rhs body_c
848 will_be_demanded = willBeDemanded (getIdDemandInfo id)
851 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
852 float_primops = switchIsSet env SimplOkToFloatPrimOps
853 ok_to_dup = switchIsSet env SimplOkToDupCode
854 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
855 try_let_to_case = switchIsSet env SimplLetToCase
856 no_float = switchIsSet env SimplNoLetFromStrictLet
858 -------------------------------------------
859 done_float env rhs body_c
860 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
861 completeLet env binder rhs' body_c body_ty
863 ---------------------------------------
864 try_float env (Let bind rhs) body_c
865 = tick LetFloatFromLet `thenSmpl_`
866 simplBind env (fix_up_demandedness will_be_demanded bind)
867 (\env -> try_float env rhs body_c) body_ty
869 try_float env (Case scrut alts) body_c
870 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
871 = tick CaseFloatFromLet `thenSmpl_`
873 -- First, bind large let-body if necessary
874 if no_need_to_bind_large_body then
875 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
877 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
879 body_c' = \env -> simplExpr env new_body []
881 simplCase env scrut alts
882 (\env rhs -> try_float env rhs body_c')
883 body_ty `thenSmpl` \ case_expr ->
885 returnSmpl (Let extra_binding case_expr)
887 no_need_to_bind_large_body
888 = ok_to_dup || isSingleton (nonErrorRHSs alts)
890 try_float env other_rhs body_c = done_float env other_rhs body_c
896 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
897 on and it'll expose a HNF), and bang the whole resulting mess together
900 1. Any "macros" should be expanded. The main application of this
909 Here we would like the single call to g to be inlined.
911 We can spot this easily, because g will be tagged as having just one
912 occurrence. The "inlineUnconditionally" predicate is just what we want.
914 A worry: could this lead to non-termination? For example:
923 Here, f and g call each other (just once) and neither is used elsewhere.
926 * the occurrence analyser will drop any (sub)-group that isn't used at
929 * If the group is used outside itself (ie in the "in" part), then there
932 ** IMPORTANT: check that NewOccAnal has the property that a group of
933 bindings like the above has f&g dropped.! ***
936 2. We'd also like to pull out any top-level let(rec)s from the
940 f = let h = ... in \x -> ....h...f...h...
946 f = \x -> ....h...f...h...
950 But floating cases is less easy? (Don't for now; ToDo?)
953 3. We'd like to arrange that the RHSs "know" about members of the
954 group that are bound to constructors. For example:
958 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
959 /= a b = unpack tuple a, unpack tuple b, call f
962 here, by knowing about d.Eq in f's rhs, one could get rid of
963 the case (and break out the recursion completely).
964 [This occurred with more aggressive inlining threshold (4),
965 nofib/spectral/knights]
968 1: we simplify constructor rhss first.
969 2: we record the "known constructors" in the environment
970 3: we simplify the other rhss, with the knowledge about the constructors
975 simplBind env (Rec pairs) body_c body_ty
976 = -- Do floating, if necessary
977 (if float_lets || always_float_let_from_let
979 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
980 returnSmpl (concat floated_pairs_s)
983 ) `thenSmpl` \ floated_pairs ->
985 binders = map fst floated_pairs
987 cloneIds env binders `thenSmpl` \ ids' ->
989 env_w_clones = extendIdEnvWithClones env binders ids'
990 triples = zipEqual "simplBind" ids' floated_pairs
993 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
995 body_c new_env `thenSmpl` \ body' ->
997 returnSmpl (Let binding body')
1000 ------------ Floating stuff -------------------
1002 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1003 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1007 pairs_s = float_pair (binder,rhs)
1010 [_] -> returnSmpl pairs_s
1012 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
1013 -- It's important to increment the tick counts if we
1014 -- do any floating. A situation where this turns out
1015 -- to be important is this:
1016 -- Float in produces:
1017 -- letrec x = let y = Ey in Ex
1019 -- Now floating gives this:
1023 --- We now want to iterate once more in case Ey doesn't
1024 -- mention x, in which case the y binding can be pulled
1025 -- out as an enclosing let(rec), which in turn gives
1026 -- the strictness analyser more chance.
1029 float_pairs pairs = concat (map float_pair pairs)
1031 float_pair (binder, rhs)
1032 | always_float_let_from_let ||
1033 floatExposesHNF True False False rhs
1034 = (binder,rhs') : pairs'
1039 (pairs', rhs') = do_float rhs
1041 -- Float just pulls out any top-level let(rec) bindings
1042 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
1043 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
1045 (pairs', body') = do_float body
1046 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
1048 (pairs', body') = do_float body
1049 do_float other = ([], other)
1051 simplRecursiveGroup env triples
1052 = -- Toss out all the dead pairs? No, there shouldn't be any!
1053 -- Dead code is discarded by the occurrence analyser
1055 -- Separate the live triples into "inline"able and
1056 -- "ordinary" We're paranoid about duplication!
1057 (inline_triples, ordinary_triples)
1058 = partition is_inline_triple triples
1060 is_inline_triple (_, ((_,occ_info),_))
1061 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1063 -- Now add in the inline_pairs info (using "env_w_clones"),
1064 -- so that we will save away suitably-clone-laden envs
1065 -- inside the InlineIts...).
1067 -- NOTE ALSO that we tie a knot here, because the
1068 -- saved-away envs must also include these very inlinings
1069 -- (they aren't stored anywhere else, and a late one might
1070 -- be used in an early one).
1072 env_w_inlinings = foldl add_inline env inline_triples
1074 add_inline env (id', (binder,rhs))
1075 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1077 -- Separate the remaining bindings into the ones which
1078 -- need to be dealt with first (the "early" ones)
1079 -- and the others (the "late" ones)
1080 (early_triples, late_triples)
1081 = partition is_early_triple ordinary_triples
1083 is_early_triple (_, (_, Con _ _)) = True
1084 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1086 -- Process the early bindings first
1087 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1089 -- Now further extend the environment to record our knowledge
1090 -- about the form of the binders bound in the constructor bindings
1092 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1093 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1095 -- Now process the non-constructor bindings
1096 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1100 binding = Rec (map snd early_triples' ++ map snd late_triples')
1102 returnSmpl (binding, env_w_early_info)
1105 do_one_binding env (id', (binder,rhs))
1106 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1107 returnSmpl (binder, (id', rhs'))
1111 @completeLet@ looks at the simplified post-floating RHS of the
1112 let-expression, and decides what to do. There's one interesting
1113 aspect to this, namely constructor reuse. Consider
1119 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1120 bit on the compiler technology, but in general I believe not. For
1121 example, here's some code from a real program:
1123 const.Int.max.wrk{-s2516-} =
1124 \ upk.s3297# upk.s3298# ->
1128 a.s3299 = I#! upk.s3297#
1130 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1131 _LT -> I#! upk.s3298#
1136 The a.s3299 really isn't doing much good. We'd be better off inlining
1137 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1139 So the current strategy is to inline all known-form constructors, and
1140 only do the reverse (turn a constructor application back into a
1141 variable) when we find a let-expression:
1145 ... (let y = C a1 .. an in ...) ...
1147 where it is always good to ditch the binding for y, and replace y by
1148 x. That's just what completeLetBinding does.
1154 -> OutExpr -- The simplified RHS
1155 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1156 -> OutType -- Type of body
1159 completeLet env binder new_rhs body_c body_ty
1160 -- See if RHS is an atom, or a reusable constructor
1161 | maybeToBool maybe_atomic_rhs
1163 new_env = extendIdEnvWithAtom env binder rhs_atom
1165 tick atom_tick_type `thenSmpl_`
1168 maybe_atomic_rhs :: Maybe (OutArg, TickType)
1169 maybe_atomic_rhs = exprToAtom env new_rhs
1170 -- If the RHS is atomic, we return Just (atom, tick type)
1171 -- otherwise Nothing
1172 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1174 completeLet env binder@(id,_) new_rhs body_c body_ty
1175 -- Maybe the rhs is an application of error, and sure to be demanded
1176 | will_be_demanded &&
1177 maybeToBool maybe_error_app
1178 = tick CaseOfError `thenSmpl_`
1179 returnSmpl retyped_error_app
1181 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1182 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1183 Just retyped_error_app = maybe_error_app
1186 completeLet env binder (Coerce coercion ty rhs) body_c body_ty
1187 -- Rhs is a coercion
1188 | maybeToBool maybe_atomic_coerce_rhs
1189 = tick tick_type `thenSmpl_`
1190 complete_coerce env rhs_atom rhs
1192 maybe_atomic_coerce_rhs = exprToAtom env rhs
1193 Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
1195 returnSmpl (CoerceForm coercion rhs_atom, env)
1197 newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1199 complete_coerce env atom rhs
1200 = cloneId env binder `thenSmpl` \ id' ->
1202 env1 = extendIdEnvWithClone env binder id'
1203 new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
1205 body_c new_env `thenSmpl` \ body' ->
1206 returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
1209 completeLet env binder new_rhs body_c body_ty
1211 = cloneId env binder `thenSmpl` \ id' ->
1213 env1 = extendIdEnvWithClone env binder id'
1214 new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
1216 body_c new_env `thenSmpl` \ body' ->
1217 returnSmpl (Let (NonRec id' new_rhs) body')
1220 %************************************************************************
1222 \subsection[Simplify-atoms]{Simplifying atoms}
1224 %************************************************************************
1227 simplArg :: SimplEnv -> InArg -> OutArg
1229 simplArg env (LitArg lit) = LitArg lit
1230 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1232 simplArg env (VarArg id)
1233 | isLocallyDefined id
1234 = case lookupId env id of
1235 Just (ItsAnAtom atom) -> atom
1236 Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1237 Nothing -> VarArg id -- Must be an uncloned thing
1240 = -- Not locally defined, so no change
1246 exprToAtom env (Var var)
1247 = Just (VarArg var, AtomicRhs)
1249 exprToAtom env (Lit lit)
1250 | not (isNoRepLit lit)
1251 = Just (LitArg lit, AtomicRhs)
1253 exprToAtom env (Con con con_args)
1254 | switchIsSet env SimplReuseCon
1258 --- ...(let w = C same-args in ...)...
1259 -- Then use v instead of w. This may save
1260 -- re-constructing an existing constructor.
1261 = case (lookForConstructor env con con_args) of
1263 Just var -> Just (VarArg var, ConReused)
1265 exprToAtom env other
1269 %************************************************************************
1271 \subsection[Simplify-quickies]{Some local help functions}
1273 %************************************************************************
1277 -- fix_up_demandedness switches off the willBeDemanded Info field
1278 -- for bindings floated out of a non-demanded let
1279 fix_up_demandedness True {- Will be demanded -} bind
1280 = bind -- Simple; no change to demand info needed
1281 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1282 = NonRec (un_demandify binder) rhs
1283 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1284 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1286 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1288 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1289 is_cheap_prim_app other = False
1291 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1292 computeResultType env expr args
1295 expr_ty = coreExprType (unTagBinders expr)
1296 expr_ty' = simplTy env expr_ty
1299 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1300 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1301 Just (_, res_ty) -> go res_ty args
1302 Nothing -> panic "computeResultType"