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
15 import CmdLineOpts ( SimplifierSwitch(..) )
16 import ConFold ( completePrim )
17 import CostCentre ( isSccCountCostCentre, cmpCostCentre )
19 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
20 unTagBinders, squashableDictishCcExpr,
23 import Id ( idType, idWantsToBeINLINEd,
24 getIdDemandInfo, addIdDemandInfo,
25 GenId{-instance NamedThing-}
27 import IdInfo ( willBeDemanded, DemandInfo )
28 import Literal ( isNoRepLit )
29 import Maybes ( maybeToBool )
30 import Name ( isLocallyDefined )
31 import PprStyle ( PprStyle(..) )
32 import PprType ( GenType{-instance Outputable-} )
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 TysWiredIn ( realWorldStateTy )
44 import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
47 The controlling flags, and what they do
48 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
52 -fsimplify = run the simplifier
53 -ffloat-inwards = runs the float lets inwards pass
54 -ffloat = runs the full laziness pass
55 (ToDo: rename to -ffull-laziness)
56 -fupdate-analysis = runs update analyser
57 -fstrictness = runs strictness analyser
58 -fsaturate-apps = saturates applications (eta expansion)
62 -ffloat-past-lambda = OK to do full laziness.
63 (ToDo: remove, as the full laziness pass is
64 useless without this flag, therefore
65 it is unnecessary. Just -ffull-laziness
68 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
69 let is strict or if the floating will expose
72 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
73 is a primop that cannot fail [simplifier].
75 -fcode-duplication-ok = allows the previous option to work on cases with
76 multiple branches [simplifier].
78 -flet-to-case = does let-to-case transformation [simplifier].
80 -fcase-of-case = does case of case transformation [simplifier].
82 -fpedantic-bottoms = does not allow:
83 case x of y -> e ===> e[x/y]
84 (which may turn bottom into non-bottom)
90 Inlining is one of the delicate aspects of the simplifier. By
91 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
92 the RHS of x's definition. Thus
94 let x = e in ...x... ===> let x = e in ...e...
96 We have two mechanisms for inlining:
98 1. Unconditional. The occurrence analyser has pinned an (OneOcc
99 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
100 certainly safe to inline this variable, and to drop its binding''.
101 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
102 happy to be duplicating code...) When it encounters such a beast, the
103 simplifer binds the variable to its RHS (in the id_env) and continues.
104 It doesn't even look at the RHS at that stage. It also drops the
107 2. Conditional. In all other situations, the simplifer simplifies
108 the RHS anyway, and keeps the new binding. It also binds the new
109 (cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
111 Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
112 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
113 the variable has an INLINE pragma on it). The idea is that anything
114 in the UnfoldEnv is safe to use, but also has an enclosing binding if
115 you decide not to use it.
119 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
122 At one time I thought it would be OK to put non-HNF unfoldings in for
123 variables which occur only once [if they got inlined at that
124 occurrence the RHS of the binding would become dead, so no duplication
125 would occur]. But consider:
128 f = \y -> ...y...y...y...
131 Now, it seems that @x@ appears only once, but even so it is NOT safe
132 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
133 duplicate the references to @x@.
135 Because of this, the "unconditional-inline" mechanism above is the
136 only way in which non-HNFs can get inlined.
141 When a variable has an INLINE pragma on it --- which includes wrappers
142 produced by the strictness analyser --- we treat it rather carefully.
144 For a start, we are careful not to substitute into its RHS, because
145 that might make it BIG, and the user said "inline exactly this", not
146 "inline whatever you get after inlining other stuff inside me". For
150 in {-# INLINE y #-} y = f 3
153 Here we don't want to substitute BIG for the (single) occurrence of f,
154 because then we'd duplicate BIG when we inline'd y. (Exception:
155 things in the UnfoldEnv with UnfoldAlways flags, which originated in
156 other INLINE pragmas.)
158 So, we clean out the UnfoldEnv of all GenForm inlinings before
159 going into such an RHS.
161 What about imports? They don't really matter much because we only
162 inline relatively small things via imports.
164 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
165 INLINE pragma. We also do this for the RHSs of recursive decls,
166 before looking at the recursive decls. That way we achieve the effect
167 of inlining a wrapper in the body of its worker, in the case of a
168 mutually-recursive worker/wrapper split.
171 %************************************************************************
173 \subsection[Simplify-simplExpr]{The main function: simplExpr}
175 %************************************************************************
177 At the top level things are a little different.
179 * No cloning (not allowed for exported Ids, unnecessary for the others)
181 * No floating. Case floating is obviously out. Let floating is
182 theoretically OK, but dangerous because of space leaks.
183 The long-distance let-floater lifts these lets.
186 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
188 simplTopBinds env [] = returnSmpl []
190 -- Dead code is now discarded by the occurrence analyser,
192 simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
193 | inlineUnconditionally ok_to_dup_code occ_info
195 new_env = extendIdEnvWithInlining env env binder rhs
197 simplTopBinds new_env binds
199 ok_to_dup_code = switchIsSet env SimplOkToDupCode
201 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
202 = -- No cloning necessary at top level
203 -- Process the binding
204 simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
206 new_env = case rhs' of
207 Var v -> extendIdEnvWithAtom env binder (VarArg v)
208 Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
209 other -> extendUnfoldEnvGivenRhs env binder in_id 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 (NonRec in_id rhs' : binds')
220 simplTopBinds env (Rec pairs : binds)
221 = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
223 -- Process the other bindings
224 simplTopBinds new_env binds `thenSmpl` \ binds' ->
226 -- Glue together and return
227 returnSmpl (bind' : binds')
229 triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
230 -- No cloning necessary at top level
233 %************************************************************************
235 \subsection[Simplify-simplExpr]{The main function: simplExpr}
237 %************************************************************************
241 simplExpr :: SimplEnv
242 -> InExpr -> [OutArg]
246 The expression returned has the same meaning as the input expression
247 applied to the specified arguments.
252 Check if there's a macro-expansion, and if so rattle on. Otherwise do
253 the more sophisticated stuff.
256 simplExpr env (Var v) args
257 = case (lookupId env v) of
259 new_v = simplTyInId env v
261 completeVar env new_v args
265 ItsAnAtom (LitArg lit) -- A boring old literal
266 -- Paranoia check for args empty
268 [] -> returnSmpl (Lit lit)
269 other -> panic "simplExpr:coVar"
271 ItsAnAtom (VarArg var) -- More interesting! An id!
272 -- No need to substitute the type env here,
273 -- because we already have!
274 -> completeVar env var args
276 InlineIt id_env ty_env in_expr -- A macro-expansion
277 -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
284 simplExpr env (Lit l) [] = returnSmpl (Lit l)
286 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
290 Primitive applications are simple.
291 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
293 NB: Prim expects an empty argument list! (Because it should be
294 saturated and not higher-order. ADR)
297 simplExpr env (Prim op prim_args) args
300 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
303 completePrim env op' prim_args'
305 -- PrimOps just need any types in them renamed.
307 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
309 arg_tys' = map (simplTy env) arg_tys
310 result_ty' = simplTy env result_ty
312 CCallOp label is_asm may_gc arg_tys' result_ty'
314 simpl_op other_op = other_op
317 Constructor applications
318 ~~~~~~~~~~~~~~~~~~~~~~~~
319 Nothing to try here. We only reuse constructors when they appear as the
320 rhs of a let binding (see completeLetBinding).
323 simplExpr env (Con con con_args) args
324 = ASSERT( null args )
325 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
329 Applications are easy too:
330 ~~~~~~~~~~~~~~~~~~~~~~~~~~
331 Just stuff 'em in the arg stack
334 simplExpr env (App fun arg) args
335 = simplExpr env fun (simplArg env arg : args)
341 We only eta-reduce a type lambda if all type arguments in the body can
342 be eta-reduced. This requires us to collect up all tyvar parameters so
343 we can pass them all to @mkTyLamTryingEta@.
346 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
347 = -- ASSERT(not (isPrimType ty))
349 new_env = extendTyEnv env tyvar ty
351 tick TyBetaReduction `thenSmpl_`
352 simplExpr new_env body args
354 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
355 = do_tylambdas env [] tylam
357 do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
358 = -- Clone the type variable
359 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
361 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
363 do_tylambdas new_env (tyvar':tyvars') body
365 do_tylambdas env tyvars' body
366 = simplExpr env body [] `thenSmpl` \ body' ->
368 (if switchIsSet env SimplDoEtaReduction
369 then mkTyLamTryingEta
370 else mkTyLam) (reverse tyvars') body'
374 simplExpr env (Lam (TyBinder _) _) (_ : _)
375 = panic "simplExpr:TyLam with non-TyArg"
384 simplExpr env (Lam (ValBinder binder) body) args
385 | null leftover_binders
386 = -- The lambda is saturated (or over-saturated)
387 tick BetaReduction `thenSmpl_`
388 simplExpr env_for_enough_args body leftover_args
391 = -- Too few args to saturate the lambda
392 ASSERT( null leftover_args )
394 (if not (null args) -- ah, we must've gotten rid of some...
395 then tick BetaReduction
396 else returnSmpl (panic "BetaReduction")
399 simplLam env_for_too_few_args leftover_binders body
400 0 {- Guaranteed applied to at least 0 args! -}
403 (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
405 env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
407 env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
409 -- Since there aren't enough args the binders we are cancelling with
410 -- the args supplied are, in effect, ocurring inside a lambda.
411 -- So we modify their occurrence info to reflect this fact.
412 -- Example: (\ x y z -> e) p q
413 -- ==> (\z -> e[p/x, q/y])
414 -- but we should behave as if x and y are marked "inside lambda".
415 -- The occurrence analyser does not mark them so itself because then we
416 -- do badly on the very common case of saturated lambdas applications:
417 -- (\ x y z -> e) p q r
418 -- ==> e[p/x, q/y, r/z]
420 zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
421 | ((id, occ_info), arg) <- binder_args_pairs ]
423 collect_val_args :: InBinder -- Binder
424 -> [OutArg] -- Arguments
425 -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
426 [InBinder], -- Leftover binders (ToDo: a maybe)
427 [OutArg]) -- Leftover args
429 -- collect_val_args strips off the leading ValArgs from
430 -- the current arg list, returning them along with the
432 collect_val_args binder [] = ([], [binder], [])
433 collect_val_args binder (arg : args) | isValArg arg
434 = ([(binder,arg)], [], args)
437 collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
438 -- TyArg should never meet a Lam
447 simplExpr env (Let bind body) args
449 {- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
450 and it doesn't seem worth retaining the ability to not float applications
453 | switchIsSet env SimplNoLetFromApp
454 = simplBind env bind (\env -> simplExpr env body [])
455 (computeResultType env body []) `thenSmpl` \ let_expr' ->
456 returnSmpl (mkGenApp let_expr' args)
458 | otherwise -- No float from application
461 = simplBind env bind (\env -> simplExpr env body args)
462 (computeResultType env body args)
469 simplExpr env expr@(Case scrut alts) args
470 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
471 (computeResultType env expr args)
478 simplExpr env (Coerce coercion ty body) args
479 = simplCoerce env coercion ty body args
486 1) Eliminating nested sccs ...
487 We must be careful to maintain the scc counts ...
490 simplExpr env (SCC cc1 (SCC cc2 expr)) args
491 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
492 -- eliminate inner scc if no call counts and same cc as outer
493 = simplExpr env (SCC cc1 expr) args
495 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
496 -- eliminate outer scc if no call counts associated with either ccs
497 = simplExpr env (SCC cc2 expr) args
500 2) Moving sccs inside lambdas ...
503 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args
504 | not (isSccCountCostCentre cc)
505 -- move scc inside lambda only if no call counts
506 = simplExpr env (Lam binder (SCC cc body)) args
508 simplExpr env (SCC cc (Lam binder body)) args
509 -- always ok to move scc inside type/usage lambda
510 = simplExpr env (Lam binder (SCC cc body)) args
513 3) Eliminating dict sccs ...
516 simplExpr env (SCC cc expr) args
517 | squashableDictishCcExpr cc expr
518 -- eliminate dict cc if trivial dict expression
519 = simplExpr env expr args
522 4) Moving arguments inside the body of an scc ...
523 This moves the cost of doing the application inside the scc
524 (which may include the cost of extracting methods etc)
527 simplExpr env (SCC cost_centre body) args
529 new_env = setEnclosingCC env (EnclosingCC cost_centre)
531 simplExpr new_env body args `thenSmpl` \ body' ->
532 returnSmpl (SCC cost_centre body')
535 %************************************************************************
537 \subsection{Simplify RHS of a Let/Letrec}
539 %************************************************************************
541 simplRhsExpr does arity-expansion. That is, given:
543 * a right hand side /\ tyvars -> \a1 ... an -> e
544 * the information (stored in BinderInfo) that the function will always
545 be applied to at least k arguments
547 it transforms the rhs to
549 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
551 This is a Very Good Thing!
560 simplRhsExpr env binder@(id,occ_info) rhs
561 | dont_eta_expand rhs
562 = simplExpr rhs_env rhs []
564 | otherwise -- Have a go at eta expansion
565 = -- Deal with the big lambda part
566 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
568 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
570 -- Deal with the little lambda part
571 -- Note that we call simplLam even if there are no binders, in case
572 -- it can do arity expansion.
573 simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' ->
575 -- Put it back together
577 (if switchIsSet env SimplDoEtaReduction
578 then mkTyLamTryingEta
579 else mkTyLam) tyvars' lambda'
583 -- If you say {-# INLINE #-} then you get what's coming to you;
584 -- you are saying inline the rhs, please.
585 -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
586 rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
589 (uvars, tyvars, binders, body) = collectBinders rhs
591 min_no_of_args | not (null binders) && -- It's not a thunk
592 switchIsSet env SimplDoArityExpand -- Arity expansion on
593 = getBinderInfoArity occ_info - length binders
595 | otherwise -- Not a thunk
598 -- dont_eta_expand prevents eta expansion in silly situations.
599 -- For example, consider the defn
601 -- It would be silly to eta expand the "y", because it would just
602 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
603 -- and x was exported, then the defn won't be eliminated, so this
604 -- silly expand/reduce cycle will happen every time, which makes the
606 -- The solution is to not even try eta expansion unless the rhs looks
608 dont_eta_expand (Lit _) = True
609 dont_eta_expand (Var _) = True
610 dont_eta_expand (Con _ _) = True
611 dont_eta_expand (App f a)
612 | notValArg a = dont_eta_expand f
613 dont_eta_expand (Lam x b)
614 | notValBinder x = dont_eta_expand b
615 dont_eta_expand _ = False
619 %************************************************************************
621 \subsection{Simplify a lambda abstraction}
623 %************************************************************************
625 Simplify (\binders -> body) trying eta expansion and reduction, given that
626 the abstraction will always be applied to at least min_no_of_args.
629 simplLam env binders body min_no_of_args
630 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
631 null potential_extra_binder_tys || -- or ain't a function
632 no_of_extra_binders == 0 -- or no extra binders needed
633 = cloneIds env binders `thenSmpl` \ binders' ->
635 new_env = extendIdEnvWithClones env binders binders'
637 simplExpr new_env body [] `thenSmpl` \ body' ->
639 (if switchIsSet new_env SimplDoEtaReduction
640 then mkValLamTryingEta
641 else mkValLam) binders' body'
644 | otherwise -- Eta expansion possible
645 = tick EtaExpansion `thenSmpl_`
646 cloneIds env binders `thenSmpl` \ binders' ->
648 new_env = extendIdEnvWithClones env binders binders'
650 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
651 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
653 (if switchIsSet new_env SimplDoEtaReduction
654 then mkValLamTryingEta
655 else mkValLam) (binders' ++ extra_binders') body'
659 (potential_extra_binder_tys, res_ty)
660 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
661 -- Note: it's possible that simplLam will be applied to something
662 -- with a forall type. Eg when being applied to the rhs of
664 -- where wurble has a forall-type, but no big lambdas at the top.
665 -- We could be clever an insert new big lambdas, but we don't bother.
667 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
669 no_of_extra_binders = -- First, use the info about how many args it's
670 -- always applied to in its scope
673 -- Next, try seeing if there's a lambda hidden inside
678 -- Finally, see if it's a state transformer, in which
679 -- case we eta-expand on principle! This can waste work,
680 -- but usually doesn't
682 case potential_extra_binder_tys of
683 [ty] | ty `eqTy` realWorldStateTy -> 1
690 %************************************************************************
692 \subsection[Simplify-coerce]{Coerce expressions}
694 %************************************************************************
697 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
698 simplCoerce env coercion ty expr@(Case scrut alts) args
699 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
700 (computeResultType env expr args)
702 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
703 simplCoerce env coercion ty (Let bind body) args
704 = simplBind env bind (\env -> simplCoerce env coercion ty body args)
705 (computeResultType env body args)
708 simplCoerce env coercion ty expr args
709 = simplExpr env expr [] `thenSmpl` \ expr' ->
710 returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
713 -- Try cancellation; we do this "on the way up" because
714 -- I think that's where it'll bite best
715 mkCoerce (CoerceIn con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body
716 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
717 mkCoerce coercion ty body = Coerce coercion ty body
721 %************************************************************************
723 \subsection[Simplify-let]{Let-expressions}
725 %************************************************************************
728 simplBind :: SimplEnv
730 -> (SimplEnv -> SmplM OutExpr)
735 When floating cases out of lets, remember this:
737 let x* = case e of alts
740 where x* is sure to be demanded or e is a cheap operation that cannot
741 fail, e.g. unboxed addition. Here we should be prepared to duplicate
742 <small expr>. A good example:
751 p1 -> foldr c n (build e1)
752 p2 -> foldr c n (build e2)
754 NEW: We use the same machinery that we use for case-of-case to
755 *always* do case floating from let, that is we let bind and abstract
756 the original let body, and let the occurrence analyser later decide
757 whether the new let should be inlined or not. The example above
761 let join_body x' = foldr c n x'
763 p1 -> let x* = build e1
765 p2 -> let x* = build e2
768 note that join_body is a let-no-escape.
769 In this particular example join_body will later be inlined,
770 achieving the same effect.
771 ToDo: check this is OK with andy
776 -- Dead code is now discarded by the occurrence analyser,
778 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
779 | inlineUnconditionally ok_to_dup occ_info
780 = body_c (extendIdEnvWithInlining env env binder rhs)
783 -- It's important to try let-to-case before floating. Consider
785 -- let a*::Int = case v of {p1->e1; p2->e2}
788 -- (The * means that a is sure to be demanded.)
789 -- If we do case-floating first we get this:
793 -- p1-> let a*=e1 in k a
794 -- p2-> let a*=e2 in k a
796 -- Now watch what happens if we do let-to-case first:
798 -- case (case v of {p1->e1; p2->e2}) of
799 -- Int a# -> let a*=I# a# in b
801 -- let k = \a# -> let a*=I# a# in b
803 -- p1 -> case e1 of I# a# -> k a#
804 -- p1 -> case e1 of I# a# -> k a#
806 -- The latter is clearly better. (Remember the reboxing let-decl
807 -- for a is likely to go away, because after all b is strict in a.)
809 | will_be_demanded &&
811 type_ok_for_let_to_case rhs_ty &&
812 not (manifestlyWHNF rhs)
813 -- note: no "manifestlyBottom rhs" in there... (comment below)
814 = tick Let2Case `thenSmpl_`
815 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
816 simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
818 We do not do let to case for WHNFs, e.g.
824 as this is less efficient.
825 but we don't mind doing let-to-case for "bottom", as that
827 allow us to remove more dead code, if anything:
830 case error of x -> ...
834 Notice that let to case occurs only if x is used strictly in
835 its body (obviously).
838 | (will_be_demanded && not no_float) ||
839 always_float_let_from_let ||
840 floatExposesHNF float_lets float_primops ok_to_dup rhs
841 = try_float env rhs body_c
844 = done_float env rhs body_c
847 will_be_demanded = willBeDemanded (getIdDemandInfo id)
850 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
851 float_primops = switchIsSet env SimplOkToFloatPrimOps
852 ok_to_dup = switchIsSet env SimplOkToDupCode
853 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
854 try_let_to_case = switchIsSet env SimplLetToCase
855 no_float = switchIsSet env SimplNoLetFromStrictLet
857 -------------------------------------------
858 done_float env rhs body_c
859 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
860 completeLet env binder rhs' body_c body_ty
862 ---------------------------------------
863 try_float env (Let bind rhs) body_c
864 = tick LetFloatFromLet `thenSmpl_`
865 simplBind env (fix_up_demandedness will_be_demanded bind)
866 (\env -> try_float env rhs body_c) body_ty
868 try_float env (Case scrut alts) body_c
869 | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
870 = tick CaseFloatFromLet `thenSmpl_`
872 -- First, bind large let-body if necessary
873 if no_need_to_bind_large_body then
874 simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
876 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
878 body_c' = \env -> simplExpr env new_body []
880 simplCase env scrut alts
881 (\env rhs -> try_float env rhs body_c')
882 body_ty `thenSmpl` \ case_expr ->
884 returnSmpl (Let extra_binding case_expr)
886 no_need_to_bind_large_body
887 = ok_to_dup || isSingleton (nonErrorRHSs alts)
889 try_float env other_rhs body_c = done_float env other_rhs body_c
895 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
896 on and it'll expose a HNF), and bang the whole resulting mess together
899 1. Any "macros" should be expanded. The main application of this
908 Here we would like the single call to g to be inlined.
910 We can spot this easily, because g will be tagged as having just one
911 occurrence. The "inlineUnconditionally" predicate is just what we want.
913 A worry: could this lead to non-termination? For example:
922 Here, f and g call each other (just once) and neither is used elsewhere.
925 * the occurrence analyser will drop any (sub)-group that isn't used at
928 * If the group is used outside itself (ie in the "in" part), then there
931 ** IMPORTANT: check that NewOccAnal has the property that a group of
932 bindings like the above has f&g dropped.! ***
935 2. We'd also like to pull out any top-level let(rec)s from the
939 f = let h = ... in \x -> ....h...f...h...
945 f = \x -> ....h...f...h...
949 But floating cases is less easy? (Don't for now; ToDo?)
952 3. We'd like to arrange that the RHSs "know" about members of the
953 group that are bound to constructors. For example:
957 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
958 /= a b = unpack tuple a, unpack tuple b, call f
961 here, by knowing about d.Eq in f's rhs, one could get rid of
962 the case (and break out the recursion completely).
963 [This occurred with more aggressive inlining threshold (4),
964 nofib/spectral/knights]
967 1: we simplify constructor rhss first.
968 2: we record the "known constructors" in the environment
969 3: we simplify the other rhss, with the knowledge about the constructors
974 simplBind env (Rec pairs) body_c body_ty
975 = -- Do floating, if necessary
976 (if float_lets || always_float_let_from_let
978 mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
979 returnSmpl (concat floated_pairs_s)
982 ) `thenSmpl` \ floated_pairs ->
984 binders = map fst floated_pairs
986 cloneIds env binders `thenSmpl` \ ids' ->
988 env_w_clones = extendIdEnvWithClones env binders ids'
989 triples = zipEqual "simplBind" ids' floated_pairs
992 simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
994 body_c new_env `thenSmpl` \ body' ->
996 returnSmpl (Let binding body')
999 ------------ Floating stuff -------------------
1001 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1002 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1006 pairs_s = float_pair (binder,rhs)
1009 [_] -> returnSmpl pairs_s
1011 -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
1012 -- It's important to increment the tick counts if we
1013 -- do any floating. A situation where this turns out
1014 -- to be important is this:
1015 -- Float in produces:
1016 -- letrec x = let y = Ey in Ex
1018 -- Now floating gives this:
1022 --- We now want to iterate once more in case Ey doesn't
1023 -- mention x, in which case the y binding can be pulled
1024 -- out as an enclosing let(rec), which in turn gives
1025 -- the strictness analyser more chance.
1028 float_pairs pairs = concat (map float_pair pairs)
1030 float_pair (binder, rhs)
1031 | always_float_let_from_let ||
1032 floatExposesHNF True False False rhs
1033 = (binder,rhs') : pairs'
1038 (pairs', rhs') = do_float rhs
1040 -- Float just pulls out any top-level let(rec) bindings
1041 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
1042 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
1044 (pairs', body') = do_float body
1045 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
1047 (pairs', body') = do_float body
1048 do_float other = ([], other)
1050 simplRecursiveGroup env triples
1051 = -- Toss out all the dead pairs? No, there shouldn't be any!
1052 -- Dead code is discarded by the occurrence analyser
1054 -- Separate the live triples into "inline"able and
1055 -- "ordinary" We're paranoid about duplication!
1056 (inline_triples, ordinary_triples)
1057 = partition is_inline_triple triples
1059 is_inline_triple (_, ((_,occ_info),_))
1060 = inlineUnconditionally False {-not ok_to_dup-} occ_info
1062 -- Now add in the inline_pairs info (using "env_w_clones"),
1063 -- so that we will save away suitably-clone-laden envs
1064 -- inside the InlineIts...).
1066 -- NOTE ALSO that we tie a knot here, because the
1067 -- saved-away envs must also include these very inlinings
1068 -- (they aren't stored anywhere else, and a late one might
1069 -- be used in an early one).
1071 env_w_inlinings = foldl add_inline env inline_triples
1073 add_inline env (id', (binder,rhs))
1074 = extendIdEnvWithInlining env env_w_inlinings binder rhs
1076 -- Separate the remaining bindings into the ones which
1077 -- need to be dealt with first (the "early" ones)
1078 -- and the others (the "late" ones)
1079 (early_triples, late_triples)
1080 = partition is_early_triple ordinary_triples
1082 is_early_triple (_, (_, Con _ _)) = True
1083 is_early_triple (i, _ ) = idWantsToBeINLINEd i
1085 -- Process the early bindings first
1086 mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
1088 -- Now further extend the environment to record our knowledge
1089 -- about the form of the binders bound in the constructor bindings
1091 env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1092 add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1094 -- Now process the non-constructor bindings
1095 mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
1099 binding = Rec (map snd early_triples' ++ map snd late_triples')
1101 returnSmpl (binding, env_w_early_info)
1104 do_one_binding env (id', (binder,rhs))
1105 = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1106 returnSmpl (binder, (id', rhs'))
1110 @completeLet@ looks at the simplified post-floating RHS of the
1111 let-expression, and decides what to do. There's one interesting
1112 aspect to this, namely constructor reuse. Consider
1118 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1119 bit on the compiler technology, but in general I believe not. For
1120 example, here's some code from a real program:
1122 const.Int.max.wrk{-s2516-} =
1123 \ upk.s3297# upk.s3298# ->
1127 a.s3299 = I#! upk.s3297#
1129 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1130 _LT -> I#! upk.s3298#
1135 The a.s3299 really isn't doing much good. We'd be better off inlining
1136 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1138 So the current strategy is to inline all known-form constructors, and
1139 only do the reverse (turn a constructor application back into a
1140 variable) when we find a let-expression:
1144 ... (let y = C a1 .. an in ...) ...
1146 where it is always good to ditch the binding for y, and replace y by
1147 x. That's just what completeLetBinding does.
1153 -> OutExpr -- The simplified RHS
1154 -> (SimplEnv -> SmplM OutExpr) -- Body handler
1155 -> OutType -- Type of body
1158 completeLet env binder new_rhs body_c body_ty
1159 -- See if RHS is an atom, or a reusable constructor
1160 | maybeToBool maybe_atomic_rhs
1162 new_env = extendIdEnvWithAtom env binder rhs_atom
1164 tick atom_tick_type `thenSmpl_`
1167 maybe_atomic_rhs :: Maybe (OutArg, TickType)
1168 maybe_atomic_rhs = exprToAtom env new_rhs
1169 -- If the RHS is atomic, we return Just (atom, tick type)
1170 -- otherwise Nothing
1171 Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1173 completeLet env binder@(id,_) new_rhs body_c body_ty
1174 -- Maybe the rhs is an application of error, and sure to be demanded
1175 | will_be_demanded &&
1176 maybeToBool maybe_error_app
1177 = tick CaseOfError `thenSmpl_`
1178 returnSmpl retyped_error_app
1180 will_be_demanded = willBeDemanded (getIdDemandInfo id)
1181 maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
1182 Just retyped_error_app = maybe_error_app
1185 completeLet env binder (Coerce coercion ty rhs) body_c body_ty
1186 -- Rhs is a coercion
1187 | maybeToBool maybe_atomic_coerce_rhs
1188 = tick tick_type `thenSmpl_`
1189 complete_coerce env rhs_atom rhs
1191 maybe_atomic_coerce_rhs = exprToAtom env rhs
1192 Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
1194 returnSmpl (CoerceForm coercion rhs_atom, env)
1196 newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1198 complete_coerce env atom rhs
1199 = cloneId env binder `thenSmpl` \ id' ->
1201 env1 = extendIdEnvWithClone env binder id'
1202 new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
1204 body_c new_env `thenSmpl` \ body' ->
1205 returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
1208 completeLet env binder new_rhs body_c body_ty
1210 = cloneId env binder `thenSmpl` \ id' ->
1212 env1 = extendIdEnvWithClone env binder id'
1213 new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
1215 body_c new_env `thenSmpl` \ body' ->
1216 returnSmpl (Let (NonRec id' new_rhs) body')
1219 %************************************************************************
1221 \subsection[Simplify-atoms]{Simplifying atoms}
1223 %************************************************************************
1226 simplArg :: SimplEnv -> InArg -> OutArg
1228 simplArg env (LitArg lit) = LitArg lit
1229 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1231 simplArg env (VarArg id)
1232 | isLocallyDefined id
1233 = case lookupId env id of
1234 Just (ItsAnAtom atom) -> atom
1235 Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1236 Nothing -> VarArg id -- Must be an uncloned thing
1239 = -- Not locally defined, so no change
1245 exprToAtom env (Var var)
1246 = Just (VarArg var, AtomicRhs)
1248 exprToAtom env (Lit lit)
1249 | not (isNoRepLit lit)
1250 = Just (LitArg lit, AtomicRhs)
1252 exprToAtom env (Con con con_args)
1253 | switchIsSet env SimplReuseCon
1257 --- ...(let w = C same-args in ...)...
1258 -- Then use v instead of w. This may save
1259 -- re-constructing an existing constructor.
1260 = case (lookForConstructor env con con_args) of
1262 Just var -> Just (VarArg var, ConReused)
1264 exprToAtom env other
1268 %************************************************************************
1270 \subsection[Simplify-quickies]{Some local help functions}
1272 %************************************************************************
1276 -- fix_up_demandedness switches off the willBeDemanded Info field
1277 -- for bindings floated out of a non-demanded let
1278 fix_up_demandedness True {- Will be demanded -} bind
1279 = bind -- Simple; no change to demand info needed
1280 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1281 = NonRec (un_demandify binder) rhs
1282 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1283 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1285 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1287 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1288 is_cheap_prim_app other = False
1290 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1291 computeResultType env expr args
1294 expr_ty = coreExprType (unTagBinders expr)
1295 expr_ty' = simplTy env expr_ty
1298 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1299 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1300 Just (_, res_ty) -> go res_ty args
1301 Nothing -> panic "computeResultType"