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
11 IMPORT_1_3(List(partition))
14 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
15 IMPORT_DELOOPER(SmplLoop) -- paranoia checking
19 import CmdLineOpts ( SimplifierSwitch(..) )
20 import ConFold ( completePrim )
21 import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary,
22 exprIsTrivial, whnfOrBottom, inlineUnconditionally,
25 import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
27 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
28 unTagBinders, squashableDictishCcExpr
30 import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
31 addIdArity, getIdArity,
32 getIdDemandInfo, addIdDemandInfo,
33 GenId{-instance NamedThing-}
35 import Name ( isExported )
36 import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
37 atLeastArity, unknownArity )
38 import Literal ( isNoRepLit )
39 import Maybes ( maybeToBool )
40 import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} )
41 #if __GLASGOW_HASKELL__ <= 30
42 import PprCore ( GenCoreArg, GenCoreExpr )
44 import TyVar ( GenTyVar {- instance Eq -} )
45 import Pretty --( ($$) )
46 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
47 import SimplCase ( simplCase, bindLargeRhs )
50 import SimplVar ( completeVar )
51 import Unique ( Unique )
53 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon,
54 splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy
56 import TysPrim ( realWorldStatePrimTy )
57 import Outputable ( PprStyle(..), Outputable(..) )
58 import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
59 isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
62 The controlling flags, and what they do
63 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
67 -fsimplify = run the simplifier
68 -ffloat-inwards = runs the float lets inwards pass
69 -ffloat = runs the full laziness pass
70 (ToDo: rename to -ffull-laziness)
71 -fupdate-analysis = runs update analyser
72 -fstrictness = runs strictness analyser
73 -fsaturate-apps = saturates applications (eta expansion)
77 -ffloat-past-lambda = OK to do full laziness.
78 (ToDo: remove, as the full laziness pass is
79 useless without this flag, therefore
80 it is unnecessary. Just -ffull-laziness
83 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
84 let is strict or if the floating will expose
87 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
88 is a primop that cannot fail [simplifier].
90 -fcode-duplication-ok = allows the previous option to work on cases with
91 multiple branches [simplifier].
93 -flet-to-case = does let-to-case transformation [simplifier].
95 -fcase-of-case = does case of case transformation [simplifier].
97 -fpedantic-bottoms = does not allow:
98 case x of y -> e ===> e[x/y]
99 (which may turn bottom into non-bottom)
105 Inlining is one of the delicate aspects of the simplifier. By
106 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
107 the RHS of x's definition. Thus
109 let x = e in ...x... ===> let x = e in ...e...
111 We have two mechanisms for inlining:
113 1. Unconditional. The occurrence analyser has pinned an (OneOcc
114 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
115 certainly safe to inline this variable, and to drop its binding''.
116 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
117 happy to be duplicating code...) When it encounters such a beast, the
118 simplifer binds the variable to its RHS (in the id_env) and continues.
119 It doesn't even look at the RHS at that stage. It also drops the
122 2. Conditional. In all other situations, the simplifer simplifies
123 the RHS anyway, and keeps the new binding. It also binds the new
124 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
126 Here, ``suitable'' might mean NoUnfolding (if the occurrence
127 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
128 the variable has an INLINE pragma on it). The idea is that anything
129 in the UnfoldEnv is safe to use, but also has an enclosing binding if
130 you decide not to use it.
134 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
137 At one time I thought it would be OK to put non-HNF unfoldings in for
138 variables which occur only once [if they got inlined at that
139 occurrence the RHS of the binding would become dead, so no duplication
140 would occur]. But consider:
143 f = \y -> ...y...y...y...
146 Now, it seems that @x@ appears only once, but even so it is NOT safe
147 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
148 duplicate the references to @x@.
150 Because of this, the "unconditional-inline" mechanism above is the
151 only way in which non-HNFs can get inlined.
156 When a variable has an INLINE pragma on it --- which includes wrappers
157 produced by the strictness analyser --- we treat it rather carefully.
159 For a start, we are careful not to substitute into its RHS, because
160 that might make it BIG, and the user said "inline exactly this", not
161 "inline whatever you get after inlining other stuff inside me". For
165 in {-# INLINE y #-} y = f 3
168 Here we don't want to substitute BIG for the (single) occurrence of f,
169 because then we'd duplicate BIG when we inline'd y. (Exception:
170 things in the UnfoldEnv with UnfoldAlways flags, which originated in
171 other INLINE pragmas.)
173 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
174 going into such an RHS.
176 What about imports? They don't really matter much because we only
177 inline relatively small things via imports.
179 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
180 INLINE pragma. We also do this for the RHSs of recursive decls,
181 before looking at the recursive decls. That way we achieve the effect
182 of inlining a wrapper in the body of its worker, in the case of a
183 mutually-recursive worker/wrapper split.
186 %************************************************************************
188 \subsection[Simplify-simplExpr]{The main function: simplExpr}
190 %************************************************************************
192 At the top level things are a little different.
194 * No cloning (not allowed for exported Ids, unnecessary for the others)
195 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
198 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
200 -- Dead code is now discarded by the occurrence analyser,
202 simplTopBinds env binds
203 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
204 simpl_top_binds env (concat binds_s)
206 simpl_top_binds env [] = returnSmpl []
208 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
209 = --- No cloning necessary at top level
210 simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) ->
211 completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
212 simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
213 returnSmpl (binds1' ++ binds2')
215 simpl_top_binds env (Rec pairs : binds)
216 = -- No cloning necessary at top level, but we nevertheless
217 -- add the Ids to the environment. This makes sure that
218 -- info carried on the Id (such as arity info) gets propagated
221 -- This may seem optional, but I found an occasion when it Really matters.
222 -- Consider foo{n} = ...foo...
225 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
226 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
227 -- thing: baz*{n} = ...baz...
229 -- Sure we could have made the indirection-shorting a bit cleverer, but
230 -- propagating pragma info is a Good Idea anyway.
232 env1 = extendIdEnvWithClones env binders ids
234 simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) ->
235 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
236 returnSmpl (Rec bind' : binds')
238 binders = map fst pairs
239 ids = map fst binders
242 %************************************************************************
244 \subsection[Simplify-simplExpr]{The main function: simplExpr}
246 %************************************************************************
250 simplExpr :: SimplEnv
251 -> InExpr -> [OutArg]
252 -> OutType -- Type of (e args); i.e. type of overall result
256 The expression returned has the same meaning as the input expression
257 applied to the specified arguments.
262 Check if there's a macro-expansion, and if so rattle on. Otherwise do
263 the more sophisticated stuff.
266 simplExpr env (Var v) args result_ty
267 = case (runEager $ lookupId env v) of
268 LitArg lit -- A boring old literal
269 -> ASSERT( null args )
272 VarArg var -- More interesting! An id!
273 -> completeVar env var args result_ty
274 -- Either Id is in the local envt, or it's a global.
275 -- In either case we don't need to apply the type
276 -- environment to it.
283 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
285 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
289 Primitive applications are simple.
290 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
292 NB: Prim expects an empty argument list! (Because it should be
293 saturated and not higher-order. ADR)
296 simplExpr env (Prim op prim_args) args result_ty
298 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
299 simpl_op op `appEager` \ op' ->
300 completePrim env op' prim_args'
302 -- PrimOps just need any types in them renamed.
304 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
305 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
306 simplTy env result_ty `appEager` \ result_ty' ->
307 returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
309 simpl_op other_op = returnEager other_op
312 Constructor applications
313 ~~~~~~~~~~~~~~~~~~~~~~~~
314 Nothing to try here. We only reuse constructors when they appear as the
315 rhs of a let binding (see completeLetBinding).
318 simplExpr env (Con con con_args) args result_ty
319 = ASSERT( null args )
320 mapEager (simplArg env) con_args `appEager` \ con_args' ->
321 returnSmpl (Con con con_args')
325 Applications are easy too:
326 ~~~~~~~~~~~~~~~~~~~~~~~~~~
327 Just stuff 'em in the arg stack
330 simplExpr env (App fun arg) args result_ty
331 = simplArg env arg `appEager` \ arg' ->
332 simplExpr env fun (arg' : args) result_ty
338 First the case when it's applied to an argument.
341 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
342 = -- ASSERT(not (isPrimType ty))
343 tick TyBetaReduction `thenSmpl_`
344 simplExpr (extendTyEnv env tyvar ty) body args result_ty
348 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
349 = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
351 new_ty = mkTyVarTy tyvar'
352 new_env = extendTyEnv env tyvar new_ty
353 new_result_ty = applyTy result_ty new_ty
355 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
356 returnSmpl (Lam (TyBinder tyvar') body')
359 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
360 = panic "simplExpr:TyLam with non-TyArg"
368 There's a complication with lambdas that aren't saturated.
373 If we did nothing, x is used inside the \y, so would be marked
374 as dangerous to dup. But in the common case where the abstraction
375 is applied to two arguments this is over-pessimistic.
376 So instead we don't take account of the \y when dealing with x's usage;
377 instead, the simplifier is careful when partially applying lambdas.
380 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
381 = go 0 env expr orig_args
383 go n env (Lam (ValBinder binder) body) (val_arg : args)
384 | isValArg val_arg -- The lambda has an argument
385 = tick BetaReduction `thenSmpl_`
386 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
388 go n env expr@(Lam (ValBinder binder) body) args
389 -- The lambda is un-saturated, so we must zap the occurrence info
390 -- on the arguments we've already beta-reduced into the body of the lambda
391 = ASSERT( null args ) -- Value lambda must match value argument!
393 new_env = markDangerousOccs env (take n orig_args)
395 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
396 `thenSmpl` \ (expr', arity) ->
399 go n env non_val_lam_expr args -- The lambda had enough arguments
400 = simplExpr env non_val_lam_expr args result_ty
408 simplExpr env (Let bind body) args result_ty
409 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
416 simplExpr env expr@(Case scrut alts) args result_ty
417 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
424 simplExpr env (Coerce coercion ty body) args result_ty
425 = simplCoerce env coercion ty body args result_ty
432 1) Eliminating nested sccs ...
433 We must be careful to maintain the scc counts ...
436 simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
437 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
438 -- eliminate inner scc if no call counts and same cc as outer
439 = simplExpr env (SCC cc1 expr) args result_ty
441 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
442 -- eliminate outer scc if no call counts associated with either ccs
443 = simplExpr env (SCC cc2 expr) args result_ty
446 2) Moving sccs inside lambdas ...
449 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
450 | not (isSccCountCostCentre cc)
451 -- move scc inside lambda only if no call counts
452 = simplExpr env (Lam binder (SCC cc body)) args result_ty
454 simplExpr env (SCC cc (Lam binder body)) args result_ty
455 -- always ok to move scc inside type/usage lambda
456 = simplExpr env (Lam binder (SCC cc body)) args result_ty
459 3) Eliminating dict sccs ...
462 simplExpr env (SCC cc expr) args result_ty
463 | squashableDictishCcExpr cc expr
464 -- eliminate dict cc if trivial dict expression
465 = simplExpr env expr args result_ty
468 4) Moving arguments inside the body of an scc ...
469 This moves the cost of doing the application inside the scc
470 (which may include the cost of extracting methods etc)
473 simplExpr env (SCC cost_centre body) args result_ty
475 new_env = setEnclosingCC env cost_centre
477 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
478 returnSmpl (SCC cost_centre body')
481 %************************************************************************
483 \subsection{Simplify RHS of a Let/Letrec}
485 %************************************************************************
487 simplRhsExpr does arity-expansion. That is, given:
489 * a right hand side /\ tyvars -> \a1 ... an -> e
490 * the information (stored in BinderInfo) that the function will always
491 be applied to at least k arguments
493 it transforms the rhs to
495 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
497 This is a Very Good Thing!
504 -> OutId -- The new binder (used only for its type)
505 -> SmplM (OutExpr, ArityInfo)
510 simplRhsExpr env binder@(id,occ_info) rhs new_id
511 | maybeToBool (maybeAppDataTyCon rhs_ty)
512 -- Deal with the data type case, in which case the elaborate
513 -- eta-expansion nonsense is really quite a waste of time.
514 = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
515 returnSmpl (rhs', ArityExactly 0)
517 | otherwise -- OK, use the big hammer
518 = -- Deal with the big lambda part
519 ASSERT( null uvars ) -- For now
521 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
523 new_tys = mkTyVarTys tyvars'
524 body_ty = foldl applyTy rhs_ty new_tys
525 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
527 -- Deal with the little lambda part
528 -- Note that we call simplLam even if there are no binders,
529 -- in case it can do arity expansion.
530 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
532 -- Put on the big lambdas, trying to float out any bindings caught inside
533 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
535 returnSmpl (rhs', arity)
537 rhs_ty = idType new_id
538 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
539 = switchOffInlining env1 -- See comments with switchOffInlining
543 -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
544 -- for the rhs of top level defs is "OST_CENTRE". Consider
546 -- g = \y -> let v = f y in scc "x" (v ...)
547 -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
548 -- want to inline "v" since its CC is dynamically determined.
550 current_cc = getEnclosingCC env
551 env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
554 (uvars, tyvars, body) = collectUsageAndTyBinders rhs
558 ----------------------------------------------------------------
559 An old special case that is now nuked.
561 First a special case for variable right-hand sides
563 It's OK to simplify the RHS, but it's often a waste of time. Often
564 these v = w things persist because v is exported, and w is used
565 elsewhere. So if we're not careful we'll eta expand the rhs, only
566 to eta reduce it in competeNonRec.
568 If we leave the binding unchanged, we will certainly replace v by w at
569 every occurrence of v, which is good enough.
571 In fact, it's *better* to replace v by w than to inline w in v's rhs,
572 even if this is the only occurrence of w. Why? Because w might have
573 IdInfo (such as strictness) that v doesn't.
575 Furthermore, there might be other uses of w; if so, inlining w in
576 v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
578 HOWEVER, we have to be careful if w is something that *must* be
579 inlined. In particular, its binding may have been dropped. Here's
580 an example that actually happened:
581 let x = let y = e in y
583 The "let y" was floated out, and then (since y occurs once in a
584 definitely inlinable position) the binding was dropped, leaving
585 {y=e} let x = y in f x
586 But now using the reasoning of this little section,
587 y wasn't inlined, because it was a let x=y form.
592 This "optimisation" turned out to be a bad idea. If there's are
593 top-level exported bindings like
598 then y wasn't getting inlined in x's rhs, and we were getting
599 bad code. So I've removed the special case from here, and
600 instead we only try eta reduction and constructor reuse
601 in completeNonRec if the thing is *not* exported.
605 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
606 | maybeToBool maybe_stop_at_var
607 = returnSmpl (Var the_var, getIdArity the_var)
610 = case (runEager $ lookupId env v) of
611 VarArg v' | not (must_unfold v') -> Just v'
614 Just the_var = maybe_stop_at_var
616 must_unfold v' = idMustBeINLINEd v'
617 || case lookupOutIdEnv env v' of
618 Just (_, _, InUnfolding _ _) -> True
622 End of old, nuked, special case.
623 ------------------------------------------------------------------
626 %************************************************************************
628 \subsection{Simplify a lambda abstraction}
630 %************************************************************************
632 Simplify (\binders -> body) trying eta expansion and reduction, given that
633 the abstraction will always be applied to at least min_no_of_args.
636 simplValLam env expr min_no_of_args expr_ty
637 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
639 exprIsTrivial expr || -- or it's a trivial RHS
640 -- No eta expansion for trivial RHSs
641 -- It's rather a Bad Thing to expand
644 -- g = \a b c -> f alpha beta a b c
646 -- The original RHS is "trivial" (exprIsTrivial), because it generates
647 -- no code (renames f to g). But the new RHS isn't.
649 null potential_extra_binder_tys || -- or ain't a function
650 no_of_extra_binders <= 0 -- or no extra binders needed
651 = cloneIds env binders `thenSmpl` \ binders' ->
653 new_env = extendIdEnvWithClones env binders binders'
655 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
656 returnSmpl (mkValLam binders' body', final_arity)
658 | otherwise -- Eta expansion possible
659 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
660 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
661 pprTrace "simplValLam" (vcat [ppr PprDebug expr,
662 ppr PprDebug expr_ty,
663 ppr PprDebug binders,
664 int no_of_extra_binders,
665 ppr PprDebug potential_extra_binder_tys])
668 tick EtaExpansion `thenSmpl_`
669 cloneIds env binders `thenSmpl` \ binders' ->
671 new_env = extendIdEnvWithClones env binders binders'
673 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
674 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
676 mkValLam (binders' ++ extra_binders') body',
681 (binders,body) = collectValBinders expr
682 no_of_binders = length binders
683 (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty
684 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
685 pprTrace "simplValLam" (vcat [ppr PprDebug expr,
686 ppr PprDebug expr_ty,
687 ppr PprDebug binders])
689 drop no_of_binders arg_tys
690 body_ty = mkFunTys potential_extra_binder_tys res_ty
692 -- Note: it's possible that simplValLam will be applied to something
693 -- with a forall type. Eg when being applied to the rhs of
695 -- where wurble has a forall-type, but no big lambdas at the top.
696 -- We could be clever an insert new big lambdas, but we don't bother.
698 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
699 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
700 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
702 no_of_extra_binders = -- First, use the info about how many args it's
703 -- always applied to in its scope; but ignore this
704 -- info for thunks. To see why we ignore it for thunks,
705 -- consider let f = lookup env key in (f 1, f 2)
706 -- We'd better not eta expand f just because it is
708 (min_no_of_args - no_of_binders)
710 -- Next, try seeing if there's a lambda hidden inside
712 -- etaExpandCount can reuturn a huge number (like 10000!) if
713 -- it finds that the body is a call to "error"; hence
714 -- the use of "min" here.
716 (etaExpandCount body `min` length potential_extra_binder_tys)
718 -- Finally, see if it's a state transformer, in which
719 -- case we eta-expand on principle! This can waste work,
720 -- but usually doesn't
722 case potential_extra_binder_tys of
723 [ty] | ty `eqTy` realWorldStatePrimTy -> 1
729 %************************************************************************
731 \subsection[Simplify-coerce]{Coerce expressions}
733 %************************************************************************
736 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
737 simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
738 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
740 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
741 simplCoerce env coercion ty (Let bind body) args result_ty
742 = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
745 simplCoerce env coercion ty expr args result_ty
746 = simplTy env ty `appEager` \ ty' ->
747 simplTy env expr_ty `appEager` \ expr_ty' ->
748 simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
749 returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
751 expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
753 -- Try cancellation; we do this "on the way up" because
754 -- I think that's where it'll bite best
755 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
756 mkCoerce coercion ty body = Coerce coercion ty body
760 %************************************************************************
762 \subsection[Simplify-bind]{Binding groups}
764 %************************************************************************
767 simplBind :: SimplEnv
769 -> (SimplEnv -> SmplM OutExpr)
773 simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
774 simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
778 %************************************************************************
780 \subsection[Simplify-let]{Let-expressions}
782 %************************************************************************
786 The booleans controlling floating have to be set with a little care.
787 Here's one performance bug I found:
789 let x = let y = let z = case a# +# 1 of {b# -> E1}
794 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
795 Before case_floating_ok included float_exposes_hnf, the case expression was floated
796 *one level per simplifier iteration* outwards. So it made th s
799 Floating case from let
800 ~~~~~~~~~~~~~~~~~~~~~~
801 When floating cases out of lets, remember this:
803 let x* = case e of alts
806 where x* is sure to be demanded or e is a cheap operation that cannot
807 fail, e.g. unboxed addition. Here we should be prepared to duplicate
808 <small expr>. A good example:
817 p1 -> foldr c n (build e1)
818 p2 -> foldr c n (build e2)
820 NEW: We use the same machinery that we use for case-of-case to
821 *always* do case floating from let, that is we let bind and abstract
822 the original let body, and let the occurrence analyser later decide
823 whether the new let should be inlined or not. The example above
827 let join_body x' = foldr c n x'
829 p1 -> let x* = build e1
831 p2 -> let x* = build e2
834 note that join_body is a let-no-escape.
835 In this particular example join_body will later be inlined,
836 achieving the same effect.
837 ToDo: check this is OK with andy
840 Let to case: two points
843 Point 1. We defer let-to-case for all data types except single-constructor
844 ones. Suppose we change
850 It can be the case that we find that b ultimately contains ...(case x of ..)....
851 and this is the only occurrence of x. Then if we've done let-to-case
852 we can't inline x, which is a real pain. On the other hand, we lose no
853 transformations by not doing this transformation, because the relevant
854 case-of-X transformations are also implemented by simpl_bind.
856 If x is a single-constructor type, then we go ahead anyway, giving
858 case e of (y,z) -> let x = (y,z) in b
860 because now we can squash case-on-x wherever they occur in b.
862 We do let-to-case on multi-constructor types in the tidy-up phase
863 (tidyCoreExpr) mainly so that the code generator doesn't need to
864 spot the demand-flag.
867 Point 2. It's important to try let-to-case before doing the
868 strict-let-of-case transformation, which happens in the next equation
871 let a*::Int = case v of {p1->e1; p2->e2}
874 (The * means that a is sure to be demanded.)
875 If we do case-floating first we get this:
879 p1-> let a*=e1 in k a
880 p2-> let a*=e2 in k a
882 Now watch what happens if we do let-to-case first:
884 case (case v of {p1->e1; p2->e2}) of
885 Int a# -> let a*=I# a# in b
887 let k = \a# -> let a*=I# a# in b
889 p1 -> case e1 of I# a# -> k a#
890 p1 -> case e2 of I# a# -> k a#
892 The latter is clearly better. (Remember the reboxing let-decl for a
893 is likely to go away, because after all b is strict in a.)
895 We do not do let to case for WHNFs, e.g.
901 as this is less efficient. but we don't mind doing let-to-case for
902 "bottom", as that will allow us to remove more dead code, if anything:
906 case error of x -> ...
910 Notice that let to case occurs only if x is used strictly in its body
915 -- Dead code is now discarded by the occurrence analyser,
917 simplNonRec env binder@(id,occ_info) rhs body_c body_ty
918 | inlineUnconditionally ok_to_dup id occ_info
919 = -- The binder is used in definitely-inline way in the body
920 -- So add it to the environment, drop the binding, and continue
921 body_c (extendEnvGivenInlining env id occ_info rhs)
923 | idWantsToBeINLINEd id
924 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
929 -- Try let-to-case; see notes below about let-to-case
930 simpl_bind env rhs | try_let_to_case &&
933 not rhs_is_whnf && -- Don't do it if RHS is a constr applicn
934 singleConstructorType rhs_ty
935 -- Only do let-to-case for single constructor types.
936 -- For other types we defer doing it until the tidy-up phase at
937 -- the end of simplification.
939 = tick Let2Case `thenSmpl_`
940 simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
941 (\env rhs -> complete_bind env rhs) body_ty
942 -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
943 -- NB: it's tidier to call complete_bind not simpl_bind, else
944 -- we nearly end up in a loop. Consider:
946 -- ==> case rhs of (p,q) -> let x=(p,q) in b
947 -- This effectively what the above simplCase call does.
948 -- Now, the inner let is a let-to-case target again! Actually, since
949 -- the RHS is in WHNF it won't happen, but it's a close thing!
952 simpl_bind env (Let bind rhs) | let_floating_ok
953 = tick LetFloatFromLet `thenSmpl_`
954 simplBind env (fix_up_demandedness will_be_demanded bind)
955 (\env -> simpl_bind env rhs) body_ty
957 -- Try case-from-let; this deals with a strict let of error too
958 simpl_bind env (Case scrut alts) | case_floating_ok scrut
959 = tick CaseFloatFromLet `thenSmpl_`
961 -- First, bind large let-body if necessary
962 if ok_to_dup || isSingleton (nonErrorRHSs alts)
964 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
966 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
968 body_c' = \env -> simplExpr env new_body [] body_ty
969 case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
971 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
972 returnSmpl (Let extra_binding case_expr)
974 -- None of the above; simplify rhs and tidy up
975 simpl_bind env rhs = complete_bind env rhs
977 complete_bind env rhs
978 = cloneId env binder `thenSmpl` \ new_id ->
979 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
980 completeNonRec env binder
981 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
982 body_c new_env `thenSmpl` \ body' ->
983 returnSmpl (mkCoLetsAny binds body')
986 -- All this stuff is computed at the start of the simpl_bind loop
987 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
988 float_primops = switchIsSet env SimplOkToFloatPrimOps
989 ok_to_dup = switchIsSet env SimplOkToDupCode
990 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
991 try_let_to_case = switchIsSet env SimplLetToCase
992 no_float = switchIsSet env SimplNoLetFromStrictLet
994 demand_info = getIdDemandInfo id
995 will_be_demanded = willBeDemanded demand_info
998 form = mkFormSummary rhs
999 rhs_is_bot = case form of
1002 rhs_is_whnf = case form of
1007 float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
1009 let_floating_ok = (will_be_demanded && not no_float) ||
1010 always_float_let_from_let ||
1013 case_floating_ok scrut = (will_be_demanded && not no_float) ||
1014 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
1019 @completeNonRec@ looks at the simplified post-floating RHS of the
1020 let-expression, with a view to turning
1024 where y is just a variable. Now we can eliminate the binding
1025 altogether, and replace x by y throughout.
1027 There are two cases when we can do this:
1029 * When e is a constructor application, and we have
1030 another variable in scope bound to the same
1031 constructor application. [This is just a special
1032 case of common-subexpression elimination.]
1034 * When e can be eta-reduced to a variable. E.g.
1038 HOWEVER, if x is exported, we don't attempt this at all. Why not?
1039 Because then we can't remove the x=y binding, in which case we
1040 have just made things worse, perhaps a lot worse.
1043 -- Right hand sides that are constructors
1046 --- ...(let w = C same-args in ...)...
1047 -- Then use v instead of w. This may save
1048 -- re-constructing an existing constructor.
1049 completeNonRec env binder new_id new_rhs
1050 | not (isExported new_id) -- Don't bother for exported things
1051 -- because we won't be able to drop
1053 && maybeToBool maybe_atomic_rhs
1054 = tick tick_type `thenSmpl_`
1055 returnSmpl (extendIdEnvWithAtom env binder rhs_arg, [])
1057 Just (rhs_arg, tick_type) = maybe_atomic_rhs
1059 = -- Try first for an existing constructor application
1060 case maybe_con new_rhs of {
1061 Just con -> Just (VarArg con, ConReused);
1063 Nothing -> -- No good; try eta-reduction
1064 case etaCoreExpr new_rhs of {
1065 Var v -> Just (VarArg v, AtomicRhs);
1066 Lit l -> Just (LitArg l, AtomicRhs);
1068 other -> Nothing -- Neither worked, so return Nothing
1072 maybe_con (Con con con_args) | switchIsSet env SimplReuseCon
1073 = lookForConstructor env con con_args
1074 maybe_con other_rhs = Nothing
1076 completeNonRec env binder@(id,occ_info) new_id new_rhs
1077 = returnSmpl (new_env , [NonRec new_id new_rhs])
1079 new_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
1080 occ_info new_id new_rhs
1083 ----------------------------------------------------------------------------
1084 A digression on constructor CSE
1092 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1093 bit on the compiler technology, but in general I believe not. For
1094 example, here's some code from a real program:
1096 const.Int.max.wrk{-s2516-} =
1097 \ upk.s3297# upk.s3298# ->
1101 a.s3299 = I#! upk.s3297#
1103 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1104 _LT -> I#! upk.s3298#
1109 The a.s3299 really isn't doing much good. We'd be better off inlining
1110 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1112 So the current strategy is to inline all known-form constructors, and
1113 only do the reverse (turn a constructor application back into a
1114 variable) when we find a let-expression:
1118 ... (let y = C a1 .. an in ...) ...
1120 where it is always good to ditch the binding for y, and replace y by
1123 ----------------------------------------------------------------------------
1125 ----------------------------------------------------------------------------
1126 A digression on "optimising" coercions
1128 The trouble is that we kept transforming
1136 and counting a couple of ticks for this non-transformation
1138 -- We want to ensure that all let-bound Coerces have
1139 -- atomic bodies, so they can freely be inlined.
1140 completeNonRec env binder new_id (Coerce coercion ty rhs)
1141 | not (is_atomic rhs)
1142 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1144 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1145 -- Dangerous occ because, like constructor args,
1146 -- it can be duplicated easily
1148 atomic_rhs = case runEager $ lookupId env1 inner_id of
1152 completeNonRec env1 binder new_id
1153 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1155 returnSmpl (env2, binds1 ++ binds2)
1157 ----------------------------------------------------------------------------
1161 %************************************************************************
1163 \subsection[Simplify-letrec]{Letrec-expressions}
1165 %************************************************************************
1169 Here's the game plan
1171 1. Float any let(rec)s out of the RHSs
1172 2. Clone all the Ids and extend the envt with these clones
1173 3. Simplify one binding at a time, adding each binding to the
1174 environment once it's done.
1176 This relies on the occurrence analyser to
1177 a) break all cycles with an Id marked MustNotBeInlined
1178 b) sort the decls into topological order
1179 The former prevents infinite inlinings, and the latter means
1180 that we get maximum benefit from working top to bottom.
1184 simplRec env pairs body_c body_ty
1185 = -- Do floating, if necessary
1186 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1188 binders = map fst pairs'
1190 cloneIds env binders `thenSmpl` \ ids' ->
1192 env_w_clones = extendIdEnvWithClones env binders ids'
1194 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1196 body_c new_env `thenSmpl` \ body' ->
1198 returnSmpl (Let (Rec pairs') body')
1202 -- The env passed to simplRecursiveGroup already has
1203 -- bindings that clone the variables of the group.
1204 simplRecursiveGroup env new_ids []
1205 = returnSmpl ([], env)
1207 simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs)
1208 | inlineUnconditionally ok_to_dup id occ_info
1209 = -- Single occurrence, so drop binding and extend env with the inlining
1210 -- This is a little delicate, because what if the unique occurrence
1211 -- is *before* this binding? This'll never happen, because
1212 -- either it'll be marked "never inline" or else its occurrence will
1213 -- occur after its binding in the group.
1215 -- If these claims aren't right Core Lint will spot an unbound
1216 -- variable. A quick fix is to delete this clause for simplRecursiveGroup
1218 new_env = extendEnvGivenInlining env new_id occ_info rhs
1220 simplRecursiveGroup new_env new_ids pairs
1223 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1225 new_id' = new_id `withArity` arity
1227 -- ToDo: this next bit could usefully share code with completeNonRec
1230 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1233 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1234 = extendIdEnvWithAtom env binder the_arg
1236 | otherwise -- Non-atomic
1237 = extendEnvGivenBinding env occ_info new_id new_rhs
1238 -- Don't eta if it doesn't eliminate the binding
1240 eta'd_rhs = etaCoreExpr new_rhs
1241 the_arg = case eta'd_rhs of
1245 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1246 returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
1248 ok_to_dup = switchIsSet env SimplOkToDupCode
1254 floatBind :: SimplEnv
1255 -> Bool -- True <=> Top level
1257 -> SmplM [InBinding]
1259 floatBind env top_level bind
1265 = tickN LetFloatFromLet n_extras `thenSmpl_`
1266 -- It's important to increment the tick counts if we
1267 -- do any floating. A situation where this turns out
1268 -- to be important is this:
1269 -- Float in produces:
1270 -- letrec x = let y = Ey in Ex
1272 -- Now floating gives this:
1276 --- We now want to iterate once more in case Ey doesn't
1277 -- mention x, in which case the y binding can be pulled
1278 -- out as an enclosing let(rec), which in turn gives
1279 -- the strictness analyser more chance.
1283 (binds', _, n_extras) = fltBind bind
1285 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1286 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1288 -- fltBind guarantees not to return leaky floats
1289 -- and all the binders of the floats have had their demand-info zapped
1290 fltBind (NonRec bndr rhs)
1291 = (binds ++ [NonRec (un_demandify bndr) rhs'],
1295 (binds, rhs') = fltRhs rhs
1300 binders `zip` rhss')],
1301 and (zipWith leakFree binders rhss'),
1306 (binders, rhss) = unzip pairs
1307 (binds_s, rhss') = mapAndUnzip fltRhs rhss
1308 extras = concat (map get_pairs (concat binds_s))
1310 get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
1311 get_pairs (Rec pairs) = pairs
1313 -- fltRhs has same invariant as fltBind
1315 | (always_float_let_from_let ||
1316 floatExposesHNF True False False rhs)
1323 -- fltExpr has same invariant as fltBind
1324 fltExpr (Let bind body)
1325 | not top_level || binds_wont_leak
1326 -- fltExpr guarantees not to return leaky floats
1327 = (binds' ++ body_binds, body')
1329 (body_binds, body') = fltExpr body
1330 (binds', binds_wont_leak, _) = fltBind bind
1332 fltExpr expr = ([], expr)
1334 -- Crude but effective
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 -- fix_up_demandedness switches off the willBeDemanded Info field
1366 -- for bindings floated out of a non-demanded let
1367 fix_up_demandedness True {- Will be demanded -} bind
1368 = bind -- Simple; no change to demand info needed
1369 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1370 = NonRec (un_demandify binder) rhs
1371 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1372 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1374 un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1376 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1377 is_cheap_prim_app other = False
1379 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1380 computeResultType env expr_ty orig_args
1381 = simplTy env expr_ty `appEager` \ expr_ty' ->
1384 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1385 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1386 Just (_, res_ty) -> go res_ty args
1388 pprPanic "computeResultType" (vcat [
1389 ppr PprDebug (a:args),
1390 ppr PprDebug orig_args,
1391 ppr PprDebug expr_ty',
1394 go expr_ty' orig_args
1397 var `withArity` UnknownArity = var
1398 var `withArity` arity = var `addIdArity` arity
1400 is_atomic (Var v) = True
1401 is_atomic (Lit l) = not (isNoRepLit l)
1402 is_atomic other = False