2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[Simplify]{The main module of the simplifier}
7 module Simplify ( simplTopBinds, simplExpr, simplBind ) where
9 #include "HsVersions.h"
12 import CmdLineOpts ( SimplifierSwitch(..) )
13 import ConFold ( completePrim )
14 import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary,
15 exprIsTrivial, whnfOrBottom, inlineUnconditionally,
18 import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
20 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
21 unTagBinders, squashableDictishCcExpr
23 import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
24 addIdArity, getIdArity,
25 getIdDemandInfo, addIdDemandInfo,
26 GenId{-instance NamedThing-}
28 import Name ( isExported )
29 import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
30 atLeastArity, unknownArity )
31 import Literal ( isNoRepLit )
32 import Maybes ( maybeToBool )
33 import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} )
34 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
35 import SimplCase ( simplCase, bindLargeRhs )
38 import SimplVar ( completeVar )
39 import Unique ( Unique )
41 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, splitAlgTyConApp_maybe,
42 splitFunTys, splitFunTy_maybe, isUnpointedType
44 import TysPrim ( realWorldStatePrimTy )
45 import Util ( Eager, appEager, returnEager, runEager, mapEager,
46 isSingleton, zipEqual, zipWithEqual, mapAndUnzip
51 The controlling flags, and what they do
52 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
56 -fsimplify = run the simplifier
57 -ffloat-inwards = runs the float lets inwards pass
58 -ffloat = runs the full laziness pass
59 (ToDo: rename to -ffull-laziness)
60 -fupdate-analysis = runs update analyser
61 -fstrictness = runs strictness analyser
62 -fsaturate-apps = saturates applications (eta expansion)
66 -ffloat-past-lambda = OK to do full laziness.
67 (ToDo: remove, as the full laziness pass is
68 useless without this flag, therefore
69 it is unnecessary. Just -ffull-laziness
72 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
73 let is strict or if the floating will expose
76 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
77 is a primop that cannot fail [simplifier].
79 -fcode-duplication-ok = allows the previous option to work on cases with
80 multiple branches [simplifier].
82 -flet-to-case = does let-to-case transformation [simplifier].
84 -fcase-of-case = does case of case transformation [simplifier].
86 -fpedantic-bottoms = does not allow:
87 case x of y -> e ===> e[x/y]
88 (which may turn bottom into non-bottom)
94 Inlining is one of the delicate aspects of the simplifier. By
95 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
96 the RHS of x's definition. Thus
98 let x = e in ...x... ===> let x = e in ...e...
100 We have two mechanisms for inlining:
102 1. Unconditional. The occurrence analyser has pinned an (OneOcc
103 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
104 certainly safe to inline this variable, and to drop its binding''.
105 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
106 happy to be duplicating code...) When it encounters such a beast, the
107 simplifer binds the variable to its RHS (in the id_env) and continues.
108 It doesn't even look at the RHS at that stage. It also drops the
111 2. Conditional. In all other situations, the simplifer simplifies
112 the RHS anyway, and keeps the new binding. It also binds the new
113 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
115 Here, ``suitable'' might mean NoUnfolding (if the occurrence
116 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
117 the variable has an INLINE pragma on it). The idea is that anything
118 in the UnfoldEnv is safe to use, but also has an enclosing binding if
119 you decide not to use it.
123 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
126 At one time I thought it would be OK to put non-HNF unfoldings in for
127 variables which occur only once [if they got inlined at that
128 occurrence the RHS of the binding would become dead, so no duplication
129 would occur]. But consider:
132 f = \y -> ...y...y...y...
135 Now, it seems that @x@ appears only once, but even so it is NOT safe
136 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
137 duplicate the references to @x@.
139 Because of this, the "unconditional-inline" mechanism above is the
140 only way in which non-HNFs can get inlined.
145 When a variable has an INLINE pragma on it --- which includes wrappers
146 produced by the strictness analyser --- we treat it rather carefully.
148 For a start, we are careful not to substitute into its RHS, because
149 that might make it BIG, and the user said "inline exactly this", not
150 "inline whatever you get after inlining other stuff inside me". For
154 in {-# INLINE y #-} y = f 3
157 Here we don't want to substitute BIG for the (single) occurrence of f,
158 because then we'd duplicate BIG when we inline'd y. (Exception:
159 things in the UnfoldEnv with UnfoldAlways flags, which originated in
160 other INLINE pragmas.)
162 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
163 going into such an RHS.
165 What about imports? They don't really matter much because we only
166 inline relatively small things via imports.
168 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
169 INLINE pragma. We also do this for the RHSs of recursive decls,
170 before looking at the recursive decls. That way we achieve the effect
171 of inlining a wrapper in the body of its worker, in the case of a
172 mutually-recursive worker/wrapper split.
175 %************************************************************************
177 \subsection[Simplify-simplExpr]{The main function: simplExpr}
179 %************************************************************************
181 At the top level things are a little different.
183 * No cloning (not allowed for exported Ids, unnecessary for the others)
184 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
187 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
189 -- Dead code is now discarded by the occurrence analyser,
191 simplTopBinds env binds
192 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
193 simpl_top_binds env (concat binds_s)
195 simpl_top_binds env [] = returnSmpl []
197 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
198 = --- No cloning necessary at top level
199 simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) ->
200 completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
201 simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
202 returnSmpl (binds1' ++ binds2')
204 simpl_top_binds env (Rec pairs : binds)
205 = -- No cloning necessary at top level, but we nevertheless
206 -- add the Ids to the environment. This makes sure that
207 -- info carried on the Id (such as arity info) gets propagated
210 -- This may seem optional, but I found an occasion when it Really matters.
211 -- Consider foo{n} = ...foo...
214 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
215 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
216 -- thing: baz*{n} = ...baz...
218 -- Sure we could have made the indirection-shorting a bit cleverer, but
219 -- propagating pragma info is a Good Idea anyway.
221 env1 = extendIdEnvWithClones env binders ids
223 simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) ->
224 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
225 returnSmpl (Rec bind' : binds')
227 binders = map fst pairs
228 ids = map fst binders
231 %************************************************************************
233 \subsection[Simplify-simplExpr]{The main function: simplExpr}
235 %************************************************************************
239 simplExpr :: SimplEnv
240 -> InExpr -> [OutArg]
241 -> OutType -- Type of (e args); i.e. type of overall result
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 result_ty
256 = case (runEager $ lookupId env v) of
257 LitArg lit -- A boring old literal
258 -> ASSERT( null args )
261 VarArg var -- More interesting! An id!
262 -> completeVar env var args result_ty
263 -- Either Id is in the local envt, or it's a global.
264 -- In either case we don't need to apply the type
265 -- environment to it.
272 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
274 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
278 Primitive applications are simple.
279 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
281 NB: Prim expects an empty argument list! (Because it should be
282 saturated and not higher-order. ADR)
285 simplExpr env (Prim op prim_args) args result_ty
287 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
288 simpl_op op `appEager` \ op' ->
289 completePrim env op' prim_args'
291 -- PrimOps just need any types in them renamed.
293 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
294 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
295 simplTy env result_ty `appEager` \ result_ty' ->
296 returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
298 simpl_op other_op = returnEager other_op
301 Constructor applications
302 ~~~~~~~~~~~~~~~~~~~~~~~~
303 Nothing to try here. We only reuse constructors when they appear as the
304 rhs of a let binding (see completeLetBinding).
307 simplExpr env (Con con con_args) args result_ty
308 = ASSERT( null args )
309 mapEager (simplArg env) con_args `appEager` \ con_args' ->
310 returnSmpl (Con con con_args')
314 Applications are easy too:
315 ~~~~~~~~~~~~~~~~~~~~~~~~~~
316 Just stuff 'em in the arg stack
319 simplExpr env (App fun arg) args result_ty
320 = simplArg env arg `appEager` \ arg' ->
321 simplExpr env fun (arg' : args) result_ty
327 First the case when it's applied to an argument.
330 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
331 = tick TyBetaReduction `thenSmpl_`
332 simplExpr (extendTyEnv env tyvar ty) body args result_ty
336 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
337 = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
339 new_ty = mkTyVarTy tyvar'
340 new_env = extendTyEnv env tyvar new_ty
341 new_result_ty = applyTy result_ty new_ty
343 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
344 returnSmpl (Lam (TyBinder tyvar') body')
347 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
348 = panic "simplExpr:TyLam with non-TyArg"
356 There's a complication with lambdas that aren't saturated.
361 If we did nothing, x is used inside the \y, so would be marked
362 as dangerous to dup. But in the common case where the abstraction
363 is applied to two arguments this is over-pessimistic.
364 So instead we don't take account of the \y when dealing with x's usage;
365 instead, the simplifier is careful when partially applying lambdas.
368 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
369 = go 0 env expr orig_args
371 go n env (Lam (ValBinder binder) body) (val_arg : args)
372 | isValArg val_arg -- The lambda has an argument
373 = tick BetaReduction `thenSmpl_`
374 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
376 go n env expr@(Lam (ValBinder binder) body) args
377 -- The lambda is un-saturated, so we must zap the occurrence info
378 -- on the arguments we've already beta-reduced into the body of the lambda
379 = ASSERT( null args ) -- Value lambda must match value argument!
381 new_env = markDangerousOccs env (take n orig_args)
383 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
384 `thenSmpl` \ (expr', arity) ->
387 go n env non_val_lam_expr args -- The lambda had enough arguments
388 = simplExpr env non_val_lam_expr args result_ty
396 simplExpr env (Let bind body) args result_ty
397 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
404 simplExpr env expr@(Case scrut alts) args result_ty
405 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
412 simplExpr env (Coerce coercion ty body) args result_ty
413 = simplCoerce env coercion ty body args result_ty
420 1) Eliminating nested sccs ...
421 We must be careful to maintain the scc counts ...
424 simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
425 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
426 -- eliminate inner scc if no call counts and same cc as outer
427 = simplExpr env (SCC cc1 expr) args result_ty
429 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
430 -- eliminate outer scc if no call counts associated with either ccs
431 = simplExpr env (SCC cc2 expr) args result_ty
434 2) Moving sccs inside lambdas ...
437 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
438 | not (isSccCountCostCentre cc)
439 -- move scc inside lambda only if no call counts
440 = simplExpr env (Lam binder (SCC cc body)) args result_ty
442 simplExpr env (SCC cc (Lam binder body)) args result_ty
443 -- always ok to move scc inside type/usage lambda
444 = simplExpr env (Lam binder (SCC cc body)) args result_ty
447 3) Eliminating dict sccs ...
450 simplExpr env (SCC cc expr) args result_ty
451 | squashableDictishCcExpr cc expr
452 -- eliminate dict cc if trivial dict expression
453 = simplExpr env expr args result_ty
456 4) Moving arguments inside the body of an scc ...
457 This moves the cost of doing the application inside the scc
458 (which may include the cost of extracting methods etc)
461 simplExpr env (SCC cost_centre body) args result_ty
463 new_env = setEnclosingCC env cost_centre
465 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
466 returnSmpl (SCC cost_centre body')
469 %************************************************************************
471 \subsection{Simplify RHS of a Let/Letrec}
473 %************************************************************************
475 simplRhsExpr does arity-expansion. That is, given:
477 * a right hand side /\ tyvars -> \a1 ... an -> e
478 * the information (stored in BinderInfo) that the function will always
479 be applied to at least k arguments
481 it transforms the rhs to
483 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
485 This is a Very Good Thing!
492 -> OutId -- The new binder (used only for its type)
493 -> SmplM (OutExpr, ArityInfo)
498 simplRhsExpr env binder@(id,occ_info) rhs new_id
499 | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
500 -- Deal with the data type case, in which case the elaborate
501 -- eta-expansion nonsense is really quite a waste of time.
502 = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
503 returnSmpl (rhs', ArityExactly 0)
505 | otherwise -- OK, use the big hammer
506 = -- Deal with the big lambda part
507 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
509 new_tys = mkTyVarTys tyvars'
510 body_ty = foldl applyTy rhs_ty new_tys
511 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
513 -- Deal with the little lambda part
514 -- Note that we call simplLam even if there are no binders,
515 -- in case it can do arity expansion.
516 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
518 -- Put on the big lambdas, trying to float out any bindings caught inside
519 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
521 returnSmpl (rhs', arity)
523 rhs_ty = idType new_id
524 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
525 = switchOffInlining env1 -- See comments with switchOffInlining
529 -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
530 -- for the rhs of top level defs is "OST_CENTRE". Consider
532 -- g = \y -> let v = f y in scc "x" (v ...)
533 -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
534 -- want to inline "v" since its CC is dynamically determined.
536 current_cc = getEnclosingCC env
537 env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
540 (tyvars, body) = collectTyBinders rhs
544 ----------------------------------------------------------------
545 An old special case that is now nuked.
547 First a special case for variable right-hand sides
549 It's OK to simplify the RHS, but it's often a waste of time. Often
550 these v = w things persist because v is exported, and w is used
551 elsewhere. So if we're not careful we'll eta expand the rhs, only
552 to eta reduce it in competeNonRec.
554 If we leave the binding unchanged, we will certainly replace v by w at
555 every occurrence of v, which is good enough.
557 In fact, it's *better* to replace v by w than to inline w in v's rhs,
558 even if this is the only occurrence of w. Why? Because w might have
559 IdInfo (such as strictness) that v doesn't.
561 Furthermore, there might be other uses of w; if so, inlining w in
562 v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
564 HOWEVER, we have to be careful if w is something that *must* be
565 inlined. In particular, its binding may have been dropped. Here's
566 an example that actually happened:
567 let x = let y = e in y
569 The "let y" was floated out, and then (since y occurs once in a
570 definitely inlinable position) the binding was dropped, leaving
571 {y=e} let x = y in f x
572 But now using the reasoning of this little section,
573 y wasn't inlined, because it was a let x=y form.
578 This "optimisation" turned out to be a bad idea. If there's are
579 top-level exported bindings like
584 then y wasn't getting inlined in x's rhs, and we were getting
585 bad code. So I've removed the special case from here, and
586 instead we only try eta reduction and constructor reuse
587 in completeNonRec if the thing is *not* exported.
591 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
592 | maybeToBool maybe_stop_at_var
593 = returnSmpl (Var the_var, getIdArity the_var)
596 = case (runEager $ lookupId env v) of
597 VarArg v' | not (must_unfold v') -> Just v'
600 Just the_var = maybe_stop_at_var
602 must_unfold v' = idMustBeINLINEd v'
603 || case lookupOutIdEnv env v' of
604 Just (_, _, InUnfolding _ _) -> True
608 End of old, nuked, special case.
609 ------------------------------------------------------------------
612 %************************************************************************
614 \subsection{Simplify a lambda abstraction}
616 %************************************************************************
618 Simplify (\binders -> body) trying eta expansion and reduction, given that
619 the abstraction will always be applied to at least min_no_of_args.
622 simplValLam env expr min_no_of_args expr_ty
623 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
625 exprIsTrivial expr || -- or it's a trivial RHS
626 -- No eta expansion for trivial RHSs
627 -- It's rather a Bad Thing to expand
630 -- g = \a b c -> f alpha beta a b c
632 -- The original RHS is "trivial" (exprIsTrivial), because it generates
633 -- no code (renames f to g). But the new RHS isn't.
635 null potential_extra_binder_tys || -- or ain't a function
636 no_of_extra_binders <= 0 -- or no extra binders needed
637 = cloneIds env binders `thenSmpl` \ binders' ->
639 new_env = extendIdEnvWithClones env binders binders'
641 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
642 returnSmpl (mkValLam binders' body', final_arity)
644 | otherwise -- Eta expansion possible
645 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
646 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
647 pprTrace "simplValLam" (vcat [ppr expr,
650 int no_of_extra_binders,
651 ppr potential_extra_binder_tys])
654 tick EtaExpansion `thenSmpl_`
655 cloneIds env binders `thenSmpl` \ binders' ->
657 new_env = extendIdEnvWithClones env binders binders'
659 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
660 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
662 mkValLam (binders' ++ extra_binders') body',
667 (binders,body) = collectValBinders expr
668 no_of_binders = length binders
669 (arg_tys, res_ty) = splitFunTys expr_ty
670 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
671 pprTrace "simplValLam" (vcat [ppr expr,
675 drop no_of_binders arg_tys
676 body_ty = mkFunTys potential_extra_binder_tys res_ty
678 -- Note: it's possible that simplValLam will be applied to something
679 -- with a forall type. Eg when being applied to the rhs of
681 -- where wurble has a forall-type, but no big lambdas at the top.
682 -- We could be clever an insert new big lambdas, but we don't bother.
684 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
685 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
686 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
688 no_of_extra_binders = -- First, use the info about how many args it's
689 -- always applied to in its scope; but ignore this
690 -- info for thunks. To see why we ignore it for thunks,
691 -- consider let f = lookup env key in (f 1, f 2)
692 -- We'd better not eta expand f just because it is
694 (min_no_of_args - no_of_binders)
696 -- Next, try seeing if there's a lambda hidden inside
698 -- etaExpandCount can reuturn a huge number (like 10000!) if
699 -- it finds that the body is a call to "error"; hence
700 -- the use of "min" here.
702 (etaExpandCount body `min` length potential_extra_binder_tys)
704 -- Finally, see if it's a state transformer, in which
705 -- case we eta-expand on principle! This can waste work,
706 -- but usually doesn't
708 case potential_extra_binder_tys of
709 [ty] | ty == realWorldStatePrimTy -> 1
715 %************************************************************************
717 \subsection[Simplify-coerce]{Coerce expressions}
719 %************************************************************************
722 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
723 simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
724 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
726 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
727 simplCoerce env coercion ty (Let bind body) args result_ty
728 = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
731 simplCoerce env coercion ty expr args result_ty
732 = simplTy env ty `appEager` \ ty' ->
733 simplTy env expr_ty `appEager` \ expr_ty' ->
734 simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
735 returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
737 expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
739 -- Try cancellation; we do this "on the way up" because
740 -- I think that's where it'll bite best
741 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
742 mkCoerce coercion ty body = Coerce coercion ty body
746 %************************************************************************
748 \subsection[Simplify-bind]{Binding groups}
750 %************************************************************************
753 simplBind :: SimplEnv
755 -> (SimplEnv -> SmplM OutExpr)
759 simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
760 simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
764 %************************************************************************
766 \subsection[Simplify-let]{Let-expressions}
768 %************************************************************************
772 The booleans controlling floating have to be set with a little care.
773 Here's one performance bug I found:
775 let x = let y = let z = case a# +# 1 of {b# -> E1}
780 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
781 Before case_floating_ok included float_exposes_hnf, the case expression was floated
782 *one level per simplifier iteration* outwards. So it made th s
785 Floating case from let
786 ~~~~~~~~~~~~~~~~~~~~~~
787 When floating cases out of lets, remember this:
789 let x* = case e of alts
792 where x* is sure to be demanded or e is a cheap operation that cannot
793 fail, e.g. unboxed addition. Here we should be prepared to duplicate
794 <small expr>. A good example:
803 p1 -> foldr c n (build e1)
804 p2 -> foldr c n (build e2)
806 NEW: We use the same machinery that we use for case-of-case to
807 *always* do case floating from let, that is we let bind and abstract
808 the original let body, and let the occurrence analyser later decide
809 whether the new let should be inlined or not. The example above
813 let join_body x' = foldr c n x'
815 p1 -> let x* = build e1
817 p2 -> let x* = build e2
820 note that join_body is a let-no-escape.
821 In this particular example join_body will later be inlined,
822 achieving the same effect.
823 ToDo: check this is OK with andy
826 Let to case: two points
829 Point 1. We defer let-to-case for all data types except single-constructor
830 ones. Suppose we change
836 It can be the case that we find that b ultimately contains ...(case x of ..)....
837 and this is the only occurrence of x. Then if we've done let-to-case
838 we can't inline x, which is a real pain. On the other hand, we lose no
839 transformations by not doing this transformation, because the relevant
840 case-of-X transformations are also implemented by simpl_bind.
842 If x is a single-constructor type, then we go ahead anyway, giving
844 case e of (y,z) -> let x = (y,z) in b
846 because now we can squash case-on-x wherever they occur in b.
848 We do let-to-case on multi-constructor types in the tidy-up phase
849 (tidyCoreExpr) mainly so that the code generator doesn't need to
850 spot the demand-flag.
853 Point 2. It's important to try let-to-case before doing the
854 strict-let-of-case transformation, which happens in the next equation
857 let a*::Int = case v of {p1->e1; p2->e2}
860 (The * means that a is sure to be demanded.)
861 If we do case-floating first we get this:
865 p1-> let a*=e1 in k a
866 p2-> let a*=e2 in k a
868 Now watch what happens if we do let-to-case first:
870 case (case v of {p1->e1; p2->e2}) of
871 Int a# -> let a*=I# a# in b
873 let k = \a# -> let a*=I# a# in b
875 p1 -> case e1 of I# a# -> k a#
876 p1 -> case e2 of I# a# -> k a#
878 The latter is clearly better. (Remember the reboxing let-decl for a
879 is likely to go away, because after all b is strict in a.)
881 We do not do let to case for WHNFs, e.g.
887 as this is less efficient. but we don't mind doing let-to-case for
888 "bottom", as that will allow us to remove more dead code, if anything:
892 case error of x -> ...
896 Notice that let to case occurs only if x is used strictly in its body
901 -- Dead code is now discarded by the occurrence analyser,
903 simplNonRec env binder@(id,occ_info) rhs body_c body_ty
904 | inlineUnconditionally ok_to_dup id occ_info
905 = -- The binder is used in definitely-inline way in the body
906 -- So add it to the environment, drop the binding, and continue
907 body_c (extendEnvGivenInlining env id occ_info rhs)
909 | idWantsToBeINLINEd id
910 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
913 -- Do let-to-case right away for unpointed types
914 -- These shouldn't occur much, but do occur right after desugaring,
915 -- because we havn't done dependency analysis at that point, so
916 -- we can't trivially do let-to-case (because there may be some unboxed
917 -- things bound in letrecs that aren't really recursive).
918 | isUnpointedType rhs_ty && not rhs_is_whnf
919 = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id)))
920 (\env rhs -> complete_bind env rhs) body_ty
922 -- Try let-to-case; see notes below about let-to-case
926 || (not rhs_is_whnf && singleConstructorType rhs_ty)
927 -- Don't do let-to-case if the RHS is a constructor application.
928 -- Even then only do it for single constructor types.
929 -- For other types we defer doing it until the tidy-up phase at
930 -- the end of simplification.
932 = tick Let2Case `thenSmpl_`
933 simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
934 (\env rhs -> complete_bind env rhs) body_ty
935 -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
936 -- NB: it's tidier to call complete_bind not simpl_bind, else
937 -- we nearly end up in a loop. Consider:
939 -- ==> case rhs of (p,q) -> let x=(p,q) in b
940 -- This effectively what the above simplCase call does.
941 -- Now, the inner let is a let-to-case target again! Actually, since
942 -- the RHS is in WHNF it won't happen, but it's a close thing!
948 simpl_bind env (Let bind rhs) | let_floating_ok
949 = tick LetFloatFromLet `thenSmpl_`
950 simplBind env (if will_be_demanded then bind
951 else un_demandify_bind bind)
952 (\env -> simpl_bind env rhs) body_ty
954 -- Try case-from-let; this deals with a strict let of error too
955 simpl_bind env (Case scrut alts) | case_floating_ok scrut
956 = tick CaseFloatFromLet `thenSmpl_`
958 -- First, bind large let-body if necessary
959 if ok_to_dup || isSingleton (nonErrorRHSs alts)
961 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
963 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
965 body_c' = \env -> simplExpr env new_body [] body_ty
966 case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
968 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
969 returnSmpl (Let extra_binding case_expr)
971 -- None of the above; simplify rhs and tidy up
972 simpl_bind env rhs = complete_bind env rhs
974 complete_bind env rhs
975 = cloneId env binder `thenSmpl` \ new_id ->
976 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
977 completeNonRec env binder
978 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
979 body_c new_env `thenSmpl` \ body' ->
980 returnSmpl (mkCoLetsAny binds body')
983 -- All this stuff is computed at the start of the simpl_bind loop
984 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
985 float_primops = switchIsSet env SimplOkToFloatPrimOps
986 ok_to_dup = switchIsSet env SimplOkToDupCode
987 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
988 try_let_to_case = switchIsSet env SimplLetToCase
989 no_float = switchIsSet env SimplNoLetFromStrictLet
991 demand_info = getIdDemandInfo id
992 will_be_demanded = willBeDemanded demand_info
995 form = mkFormSummary rhs
996 rhs_is_bot = case form of
999 rhs_is_whnf = case form of
1004 float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
1006 let_floating_ok = (will_be_demanded && not no_float) ||
1007 always_float_let_from_let ||
1010 case_floating_ok scrut = (will_be_demanded && not no_float) ||
1011 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
1016 @completeNonRec@ looks at the simplified post-floating RHS of the
1017 let-expression, with a view to turning
1021 where y is just a variable. Now we can eliminate the binding
1022 altogether, and replace x by y throughout.
1024 There are two cases when we can do this:
1026 * When e is a constructor application, and we have
1027 another variable in scope bound to the same
1028 constructor application. [This is just a special
1029 case of common-subexpression elimination.]
1031 * When e can be eta-reduced to a variable. E.g.
1035 HOWEVER, if x is exported, we don't attempt this at all. Why not?
1036 Because then we can't remove the x=y binding, in which case we
1037 have just made things worse, perhaps a lot worse.
1040 -- Right hand sides that are constructors
1043 --- ...(let w = C same-args in ...)...
1044 -- Then use v instead of w. This may save
1045 -- re-constructing an existing constructor.
1046 completeNonRec env binder new_id new_rhs
1047 | not (isExported new_id) -- Don't bother for exported things
1048 -- because we won't be able to drop
1050 && maybeToBool maybe_atomic_rhs
1051 = tick tick_type `thenSmpl_`
1052 returnSmpl (extendIdEnvWithAtom env binder rhs_arg, [])
1054 Just (rhs_arg, tick_type) = maybe_atomic_rhs
1056 = -- Try first for an existing constructor application
1057 case maybe_con new_rhs of {
1058 Just con -> Just (VarArg con, ConReused);
1060 Nothing -> -- No good; try eta-reduction
1061 case etaCoreExpr new_rhs of {
1062 Var v -> Just (VarArg v, AtomicRhs);
1063 Lit l -> Just (LitArg l, AtomicRhs);
1065 other -> Nothing -- Neither worked, so return Nothing
1069 maybe_con (Con con con_args) | switchIsSet env SimplReuseCon
1070 = lookForConstructor env con con_args
1071 maybe_con other_rhs = Nothing
1073 completeNonRec env binder@(id,occ_info) new_id new_rhs
1074 = returnSmpl (new_env , [NonRec new_id new_rhs])
1076 new_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
1077 occ_info new_id new_rhs
1080 ----------------------------------------------------------------------------
1081 A digression on constructor CSE
1089 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1090 bit on the compiler technology, but in general I believe not. For
1091 example, here's some code from a real program:
1093 const.Int.max.wrk{-s2516-} =
1094 \ upk.s3297# upk.s3298# ->
1098 a.s3299 = I#! upk.s3297#
1100 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1101 _LT -> I#! upk.s3298#
1106 The a.s3299 really isn't doing much good. We'd be better off inlining
1107 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1109 So the current strategy is to inline all known-form constructors, and
1110 only do the reverse (turn a constructor application back into a
1111 variable) when we find a let-expression:
1115 ... (let y = C a1 .. an in ...) ...
1117 where it is always good to ditch the binding for y, and replace y by
1120 ----------------------------------------------------------------------------
1122 ----------------------------------------------------------------------------
1123 A digression on "optimising" coercions
1125 The trouble is that we kept transforming
1133 and counting a couple of ticks for this non-transformation
1135 -- We want to ensure that all let-bound Coerces have
1136 -- atomic bodies, so they can freely be inlined.
1137 completeNonRec env binder new_id (Coerce coercion ty rhs)
1138 | not (is_atomic rhs)
1139 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1141 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1142 -- Dangerous occ because, like constructor args,
1143 -- it can be duplicated easily
1145 atomic_rhs = case runEager $ lookupId env1 inner_id of
1149 completeNonRec env1 binder new_id
1150 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1152 returnSmpl (env2, binds1 ++ binds2)
1154 ----------------------------------------------------------------------------
1158 %************************************************************************
1160 \subsection[Simplify-letrec]{Letrec-expressions}
1162 %************************************************************************
1166 Here's the game plan
1168 1. Float any let(rec)s out of the RHSs
1169 2. Clone all the Ids and extend the envt with these clones
1170 3. Simplify one binding at a time, adding each binding to the
1171 environment once it's done.
1173 This relies on the occurrence analyser to
1174 a) break all cycles with an Id marked MustNotBeInlined
1175 b) sort the decls into topological order
1176 The former prevents infinite inlinings, and the latter means
1177 that we get maximum benefit from working top to bottom.
1181 simplRec env pairs body_c body_ty
1182 = -- Do floating, if necessary
1183 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1185 binders = map fst pairs'
1187 cloneIds env binders `thenSmpl` \ ids' ->
1189 env_w_clones = extendIdEnvWithClones env binders ids'
1191 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1193 body_c new_env `thenSmpl` \ body' ->
1195 returnSmpl (Let (Rec pairs') body')
1199 -- The env passed to simplRecursiveGroup already has
1200 -- bindings that clone the variables of the group.
1201 simplRecursiveGroup env new_ids []
1202 = returnSmpl ([], env)
1204 simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs)
1205 | inlineUnconditionally ok_to_dup id occ_info
1206 = -- Single occurrence, so drop binding and extend env with the inlining
1207 -- This is a little delicate, because what if the unique occurrence
1208 -- is *before* this binding? This'll never happen, because
1209 -- either it'll be marked "never inline" or else its occurrence will
1210 -- occur after its binding in the group.
1212 -- If these claims aren't right Core Lint will spot an unbound
1213 -- variable. A quick fix is to delete this clause for simplRecursiveGroup
1215 new_env = extendEnvGivenInlining env new_id occ_info rhs
1217 simplRecursiveGroup new_env new_ids pairs
1220 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1222 new_id' = new_id `withArity` arity
1224 -- ToDo: this next bit could usefully share code with completeNonRec
1227 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1230 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1231 = extendIdEnvWithAtom env binder the_arg
1233 | otherwise -- Non-atomic
1234 = extendEnvGivenBinding env occ_info new_id new_rhs
1235 -- Don't eta if it doesn't eliminate the binding
1237 eta'd_rhs = etaCoreExpr new_rhs
1238 the_arg = case eta'd_rhs of
1242 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1243 returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
1245 ok_to_dup = switchIsSet env SimplOkToDupCode
1251 floatBind :: SimplEnv
1252 -> Bool -- True <=> Top level
1254 -> SmplM [InBinding]
1256 floatBind env top_level bind
1262 = tickN LetFloatFromLet n_extras `thenSmpl_`
1263 -- It's important to increment the tick counts if we
1264 -- do any floating. A situation where this turns out
1265 -- to be important is this:
1266 -- Float in produces:
1267 -- letrec x = let y = Ey in Ex
1269 -- Now floating gives this:
1273 --- We now want to iterate once more in case Ey doesn't
1274 -- mention x, in which case the y binding can be pulled
1275 -- out as an enclosing let(rec), which in turn gives
1276 -- the strictness analyser more chance.
1280 binds' = fltBind bind
1281 n_extras = sum (map no_of_binds binds') - no_of_binds bind
1283 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1284 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1286 -- fltBind guarantees not to return leaky floats
1287 -- and all the binders of the floats have had their demand-info zapped
1288 fltBind (NonRec bndr rhs)
1289 = binds ++ [NonRec bndr rhs']
1291 (binds, rhs') = fltRhs rhs
1296 pairs' = concat [ let
1297 (binds, rhs') = fltRhs rhs
1299 foldr get_pairs [(bndr, rhs')] binds
1300 | (bndr, rhs) <- pairs
1303 get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest
1304 get_pairs (Rec pairs) rest = pairs ++ rest
1306 -- fltRhs has same invariant as fltBind
1308 | (always_float_let_from_let ||
1309 floatExposesHNF True False False rhs)
1316 -- fltExpr has same invariant as fltBind
1317 fltExpr (Let bind body)
1318 | not top_level || binds_wont_leak
1319 -- fltExpr guarantees not to return leaky floats
1320 = (binds' ++ body_binds, body')
1322 binds_wont_leak = all leakFreeBind binds'
1323 (body_binds, body') = fltExpr body
1324 binds' = fltBind (un_demandify_bind bind)
1326 fltExpr expr = ([], expr)
1328 -- Crude but effective
1329 no_of_binds (NonRec _ _) = 1
1330 no_of_binds (Rec pairs) = length pairs
1332 leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
1333 leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
1335 leakFree (id,_) rhs = case getIdArity id of
1336 ArityAtLeast n | n > 0 -> True
1337 ArityExactly n | n > 0 -> True
1338 other -> whnfOrBottom (mkFormSummary rhs)
1342 %************************************************************************
1344 \subsection[Simplify-atoms]{Simplifying atoms}
1346 %************************************************************************
1349 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1351 simplArg env (LitArg lit) = returnEager (LitArg lit)
1352 simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
1353 returnEager (TyArg ty')
1354 simplArg env (VarArg id) = lookupId env id
1357 %************************************************************************
1359 \subsection[Simplify-quickies]{Some local help functions}
1361 %************************************************************************
1365 -- un_demandify_bind switches off the willBeDemanded Info field
1366 -- for bindings floated out of a non-demanded let
1367 un_demandify_bind (NonRec binder rhs)
1368 = NonRec (un_demandify_bndr binder) rhs
1369 un_demandify_bind (Rec pairs)
1370 = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
1372 un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1374 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1375 is_cheap_prim_app other = False
1377 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1378 computeResultType env expr_ty orig_args
1379 = simplTy env expr_ty `appEager` \ expr_ty' ->
1382 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1383 go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
1384 Just (_, res_ty) -> go res_ty args
1386 pprPanic "computeResultType" (vcat [
1392 go expr_ty' orig_args
1395 var `withArity` UnknownArity = var
1396 var `withArity` arity = var `addIdArity` arity
1398 is_atomic (Var v) = True
1399 is_atomic (Lit l) = not (isNoRepLit l)
1400 is_atomic other = False