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, exprIsTrivial, whnfOrBottom, FormSummary(..) )
22 import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
24 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
25 unTagBinders, squashableDictishCcExpr
27 import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
28 addIdArity, getIdArity,
29 getIdDemandInfo, addIdDemandInfo,
30 GenId{-instance NamedThing-}
32 import Name ( isExported )
33 import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
34 atLeastArity, unknownArity )
35 import Literal ( isNoRepLit )
36 import Maybes ( maybeToBool )
37 import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} )
38 #if __GLASGOW_HASKELL__ <= 30
39 import PprCore ( GenCoreArg, GenCoreExpr )
41 import TyVar ( GenTyVar {- instance Eq -} )
42 import Pretty --( ($$) )
43 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
44 import SimplCase ( simplCase, bindLargeRhs )
47 import SimplVar ( completeVar )
48 import Unique ( Unique )
50 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon,
51 splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy
53 import TysWiredIn ( realWorldStateTy )
54 import Outputable ( PprStyle(..), Outputable(..) )
55 import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
56 isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
59 The controlling flags, and what they do
60 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
64 -fsimplify = run the simplifier
65 -ffloat-inwards = runs the float lets inwards pass
66 -ffloat = runs the full laziness pass
67 (ToDo: rename to -ffull-laziness)
68 -fupdate-analysis = runs update analyser
69 -fstrictness = runs strictness analyser
70 -fsaturate-apps = saturates applications (eta expansion)
74 -ffloat-past-lambda = OK to do full laziness.
75 (ToDo: remove, as the full laziness pass is
76 useless without this flag, therefore
77 it is unnecessary. Just -ffull-laziness
80 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
81 let is strict or if the floating will expose
84 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
85 is a primop that cannot fail [simplifier].
87 -fcode-duplication-ok = allows the previous option to work on cases with
88 multiple branches [simplifier].
90 -flet-to-case = does let-to-case transformation [simplifier].
92 -fcase-of-case = does case of case transformation [simplifier].
94 -fpedantic-bottoms = does not allow:
95 case x of y -> e ===> e[x/y]
96 (which may turn bottom into non-bottom)
102 Inlining is one of the delicate aspects of the simplifier. By
103 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
104 the RHS of x's definition. Thus
106 let x = e in ...x... ===> let x = e in ...e...
108 We have two mechanisms for inlining:
110 1. Unconditional. The occurrence analyser has pinned an (OneOcc
111 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
112 certainly safe to inline this variable, and to drop its binding''.
113 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
114 happy to be duplicating code...) When it encounters such a beast, the
115 simplifer binds the variable to its RHS (in the id_env) and continues.
116 It doesn't even look at the RHS at that stage. It also drops the
119 2. Conditional. In all other situations, the simplifer simplifies
120 the RHS anyway, and keeps the new binding. It also binds the new
121 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
123 Here, ``suitable'' might mean NoUnfolding (if the occurrence
124 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
125 the variable has an INLINE pragma on it). The idea is that anything
126 in the UnfoldEnv is safe to use, but also has an enclosing binding if
127 you decide not to use it.
131 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
134 At one time I thought it would be OK to put non-HNF unfoldings in for
135 variables which occur only once [if they got inlined at that
136 occurrence the RHS of the binding would become dead, so no duplication
137 would occur]. But consider:
140 f = \y -> ...y...y...y...
143 Now, it seems that @x@ appears only once, but even so it is NOT safe
144 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
145 duplicate the references to @x@.
147 Because of this, the "unconditional-inline" mechanism above is the
148 only way in which non-HNFs can get inlined.
153 When a variable has an INLINE pragma on it --- which includes wrappers
154 produced by the strictness analyser --- we treat it rather carefully.
156 For a start, we are careful not to substitute into its RHS, because
157 that might make it BIG, and the user said "inline exactly this", not
158 "inline whatever you get after inlining other stuff inside me". For
162 in {-# INLINE y #-} y = f 3
165 Here we don't want to substitute BIG for the (single) occurrence of f,
166 because then we'd duplicate BIG when we inline'd y. (Exception:
167 things in the UnfoldEnv with UnfoldAlways flags, which originated in
168 other INLINE pragmas.)
170 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
171 going into such an RHS.
173 What about imports? They don't really matter much because we only
174 inline relatively small things via imports.
176 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
177 INLINE pragma. We also do this for the RHSs of recursive decls,
178 before looking at the recursive decls. That way we achieve the effect
179 of inlining a wrapper in the body of its worker, in the case of a
180 mutually-recursive worker/wrapper split.
183 %************************************************************************
185 \subsection[Simplify-simplExpr]{The main function: simplExpr}
187 %************************************************************************
189 At the top level things are a little different.
191 * No cloning (not allowed for exported Ids, unnecessary for the others)
192 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
195 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
197 -- Dead code is now discarded by the occurrence analyser,
199 simplTopBinds env binds
200 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
201 simpl_top_binds env (concat binds_s)
203 simpl_top_binds env [] = returnSmpl []
205 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
206 = --- No cloning necessary at top level
207 simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) ->
208 completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
209 simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
210 returnSmpl (binds1' ++ binds2')
212 simpl_top_binds env (Rec pairs : binds)
213 = -- No cloning necessary at top level, but we nevertheless
214 -- add the Ids to the environment. This makes sure that
215 -- info carried on the Id (such as arity info) gets propagated
218 -- This may seem optional, but I found an occasion when it Really matters.
219 -- Consider foo{n} = ...foo...
222 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
223 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
224 -- thing: baz*{n} = ...baz...
226 -- Sure we could have made the indirection-shorting a bit cleverer, but
227 -- propagating pragma info is a Good Idea anyway.
229 env1 = extendIdEnvWithClones env binders ids
231 simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) ->
232 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
233 returnSmpl (Rec bind' : binds')
235 binders = map fst pairs
236 ids = map fst binders
239 %************************************************************************
241 \subsection[Simplify-simplExpr]{The main function: simplExpr}
243 %************************************************************************
247 simplExpr :: SimplEnv
248 -> InExpr -> [OutArg]
249 -> OutType -- Type of (e args); i.e. type of overall result
253 The expression returned has the same meaning as the input expression
254 applied to the specified arguments.
259 Check if there's a macro-expansion, and if so rattle on. Otherwise do
260 the more sophisticated stuff.
263 simplExpr env (Var v) args result_ty
264 = case (runEager $ lookupId env v) of
265 LitArg lit -- A boring old literal
266 -> ASSERT( null args )
269 VarArg var -- More interesting! An id!
270 -> completeVar env var args result_ty
271 -- Either Id is in the local envt, or it's a global.
272 -- In either case we don't need to apply the type
273 -- environment to it.
280 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
282 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
286 Primitive applications are simple.
287 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
289 NB: Prim expects an empty argument list! (Because it should be
290 saturated and not higher-order. ADR)
293 simplExpr env (Prim op prim_args) args result_ty
295 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
296 simpl_op op `appEager` \ op' ->
297 completePrim env op' prim_args'
299 -- PrimOps just need any types in them renamed.
301 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
302 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
303 simplTy env result_ty `appEager` \ result_ty' ->
304 returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
306 simpl_op other_op = returnEager other_op
309 Constructor applications
310 ~~~~~~~~~~~~~~~~~~~~~~~~
311 Nothing to try here. We only reuse constructors when they appear as the
312 rhs of a let binding (see completeLetBinding).
315 simplExpr env (Con con con_args) args result_ty
316 = ASSERT( null args )
317 mapEager (simplArg env) con_args `appEager` \ con_args' ->
318 returnSmpl (Con con con_args')
322 Applications are easy too:
323 ~~~~~~~~~~~~~~~~~~~~~~~~~~
324 Just stuff 'em in the arg stack
327 simplExpr env (App fun arg) args result_ty
328 = simplArg env arg `appEager` \ arg' ->
329 simplExpr env fun (arg' : args) result_ty
335 First the case when it's applied to an argument.
338 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
339 = -- ASSERT(not (isPrimType ty))
340 tick TyBetaReduction `thenSmpl_`
341 simplExpr (extendTyEnv env tyvar ty) body args result_ty
345 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
346 = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
348 new_ty = mkTyVarTy tyvar'
349 new_env = extendTyEnv env tyvar new_ty
350 new_result_ty = applyTy result_ty new_ty
352 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
353 returnSmpl (Lam (TyBinder tyvar') body')
356 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
357 = panic "simplExpr:TyLam with non-TyArg"
365 There's a complication with lambdas that aren't saturated.
370 If we did nothing, x is used inside the \y, so would be marked
371 as dangerous to dup. But in the common case where the abstraction
372 is applied to two arguments this is over-pessimistic.
373 So instead we don't take account of the \y when dealing with x's usage;
374 instead, the simplifier is careful when partially applying lambdas.
377 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
378 = go 0 env expr orig_args
380 go n env (Lam (ValBinder binder) body) (val_arg : args)
381 | isValArg val_arg -- The lambda has an argument
382 = tick BetaReduction `thenSmpl_`
383 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
385 go n env expr@(Lam (ValBinder binder) body) args
386 -- The lambda is un-saturated, so we must zap the occurrence info
387 -- on the arguments we've already beta-reduced into the body of the lambda
388 = ASSERT( null args ) -- Value lambda must match value argument!
390 new_env = markDangerousOccs env (take n orig_args)
392 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
393 `thenSmpl` \ (expr', arity) ->
396 go n env non_val_lam_expr args -- The lambda had enough arguments
397 = simplExpr env non_val_lam_expr args result_ty
405 simplExpr env (Let bind body) args result_ty
406 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
413 simplExpr env expr@(Case scrut alts) args result_ty
414 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
421 simplExpr env (Coerce coercion ty body) args result_ty
422 = simplCoerce env coercion ty body args result_ty
429 1) Eliminating nested sccs ...
430 We must be careful to maintain the scc counts ...
433 simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
434 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
435 -- eliminate inner scc if no call counts and same cc as outer
436 = simplExpr env (SCC cc1 expr) args result_ty
438 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
439 -- eliminate outer scc if no call counts associated with either ccs
440 = simplExpr env (SCC cc2 expr) args result_ty
443 2) Moving sccs inside lambdas ...
446 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
447 | not (isSccCountCostCentre cc)
448 -- move scc inside lambda only if no call counts
449 = simplExpr env (Lam binder (SCC cc body)) args result_ty
451 simplExpr env (SCC cc (Lam binder body)) args result_ty
452 -- always ok to move scc inside type/usage lambda
453 = simplExpr env (Lam binder (SCC cc body)) args result_ty
456 3) Eliminating dict sccs ...
459 simplExpr env (SCC cc expr) args result_ty
460 | squashableDictishCcExpr cc expr
461 -- eliminate dict cc if trivial dict expression
462 = simplExpr env expr args result_ty
465 4) Moving arguments inside the body of an scc ...
466 This moves the cost of doing the application inside the scc
467 (which may include the cost of extracting methods etc)
470 simplExpr env (SCC cost_centre body) args result_ty
472 new_env = setEnclosingCC env cost_centre
474 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
475 returnSmpl (SCC cost_centre body')
478 %************************************************************************
480 \subsection{Simplify RHS of a Let/Letrec}
482 %************************************************************************
484 simplRhsExpr does arity-expansion. That is, given:
486 * a right hand side /\ tyvars -> \a1 ... an -> e
487 * the information (stored in BinderInfo) that the function will always
488 be applied to at least k arguments
490 it transforms the rhs to
492 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
494 This is a Very Good Thing!
501 -> OutId -- The new binder (used only for its type)
502 -> SmplM (OutExpr, ArityInfo)
505 First a special case for variable right-hand sides
507 It's OK to simplify the RHS, but it's often a waste of time. Often
508 these v = w things persist because v is exported, and w is used
509 elsewhere. So if we're not careful we'll eta expand the rhs, only
510 to eta reduce it in competeNonRec.
512 If we leave the binding unchanged, we will certainly replace v by w at
513 every occurrence of v, which is good enough.
515 In fact, it's *better* to replace v by w than to inline w in v's rhs,
516 even if this is the only occurrence of w. Why? Because w might have
517 IdInfo (like strictness) that v doesn't.
518 Furthermore, there might be other uses of w; if so, inlining w in
519 v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
521 HOWEVER, we have to be careful if w is something that *must* be
522 inlined. In particular, its binding may have been dropped. Here's
523 an example that actually happened:
524 let x = let y = e in y
526 The "let y" was floated out, and then (since y occurs once in a
527 definitely inlinable position) the binding was dropped, leaving
528 {y=e} let x = y in f x
529 But now using the reasoning of this little section,
530 y wasn't inlined, because it was a let x=y form.
533 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
534 | maybeToBool maybe_stop_at_var
535 = returnSmpl (Var the_var, getIdArity the_var)
538 = case (runEager $ lookupId env v) of
539 VarArg v' | not (must_unfold v') -> Just v'
542 Just the_var = maybe_stop_at_var
544 must_unfold v' = idMustBeINLINEd v'
545 || case lookupOutIdEnv env v' of
546 Just (_, _, InUnfolding _ _) -> True
551 simplRhsExpr env binder@(id,occ_info) rhs new_id
552 | maybeToBool (maybeAppDataTyCon rhs_ty)
553 -- Deal with the data type case, in which case the elaborate
554 -- eta-expansion nonsense is really quite a waste of time.
555 = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
556 returnSmpl (rhs', ArityExactly 0)
558 | otherwise -- OK, use the big hammer
559 = -- Deal with the big lambda part
560 ASSERT( null uvars ) -- For now
562 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
564 new_tys = mkTyVarTys tyvars'
565 body_ty = foldl applyTy rhs_ty new_tys
566 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
568 -- Deal with the little lambda part
569 -- Note that we call simplLam even if there are no binders,
570 -- in case it can do arity expansion.
571 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
573 -- Put on the big lambdas, trying to float out any bindings caught inside
574 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
576 returnSmpl (rhs', arity)
578 rhs_ty = idType new_id
579 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
580 = switchOffInlining env1 -- See comments with switchOffInlining
584 -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
585 -- for the rhs of top level defs is "OST_CENTRE". Consider
587 -- g = \y -> let v = f y in scc "x" (v ...)
588 -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
589 -- want to inline "v" since its CC is dynamically determined.
591 current_cc = getEnclosingCC env
592 env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
595 (uvars, tyvars, body) = collectUsageAndTyBinders rhs
599 %************************************************************************
601 \subsection{Simplify a lambda abstraction}
603 %************************************************************************
605 Simplify (\binders -> body) trying eta expansion and reduction, given that
606 the abstraction will always be applied to at least min_no_of_args.
609 simplValLam env expr min_no_of_args expr_ty
610 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
612 exprIsTrivial expr || -- or it's a trivial RHS
613 -- No eta expansion for trivial RHSs
614 -- It's rather a Bad Thing to expand
617 -- g = \a b c -> f alpha beta a b c
619 -- The original RHS is "trivial" (exprIsTrivial), because it generates
620 -- no code (renames f to g). But the new RHS isn't.
622 null potential_extra_binder_tys || -- or ain't a function
623 no_of_extra_binders <= 0 -- or no extra binders needed
624 = cloneIds env binders `thenSmpl` \ binders' ->
626 new_env = extendIdEnvWithClones env binders binders'
628 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
629 returnSmpl (mkValLam binders' body', final_arity)
631 | otherwise -- Eta expansion possible
632 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
633 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
634 pprTrace "simplValLam" (vcat [ppr PprDebug expr,
635 ppr PprDebug expr_ty,
636 ppr PprDebug binders,
637 int no_of_extra_binders,
638 ppr PprDebug potential_extra_binder_tys])
641 tick EtaExpansion `thenSmpl_`
642 cloneIds env binders `thenSmpl` \ binders' ->
644 new_env = extendIdEnvWithClones env binders binders'
646 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
647 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
649 mkValLam (binders' ++ extra_binders') body',
654 (binders,body) = collectValBinders expr
655 no_of_binders = length binders
656 (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty
657 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
658 pprTrace "simplValLam" (vcat [ppr PprDebug expr,
659 ppr PprDebug expr_ty,
660 ppr PprDebug binders])
662 drop no_of_binders arg_tys
663 body_ty = mkFunTys potential_extra_binder_tys res_ty
665 -- Note: it's possible that simplValLam will be applied to something
666 -- with a forall type. Eg when being applied to the rhs of
668 -- where wurble has a forall-type, but no big lambdas at the top.
669 -- We could be clever an insert new big lambdas, but we don't bother.
671 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
672 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
673 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
675 no_of_extra_binders = -- First, use the info about how many args it's
676 -- always applied to in its scope; but ignore this
677 -- info for thunks. To see why we ignore it for thunks,
678 -- consider let f = lookup env key in (f 1, f 2)
679 -- We'd better not eta expand f just because it is
681 (min_no_of_args - no_of_binders)
683 -- Next, try seeing if there's a lambda hidden inside
685 -- etaExpandCount can reuturn a huge number (like 10000!) if
686 -- it finds that the body is a call to "error"; hence
687 -- the use of "min" here.
689 (etaExpandCount body `min` length potential_extra_binder_tys)
691 -- Finally, see if it's a state transformer, in which
692 -- case we eta-expand on principle! This can waste work,
693 -- but usually doesn't
695 case potential_extra_binder_tys of
696 [ty] | ty `eqTy` realWorldStateTy -> 1
702 %************************************************************************
704 \subsection[Simplify-coerce]{Coerce expressions}
706 %************************************************************************
709 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
710 simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
711 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
713 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
714 simplCoerce env coercion ty (Let bind body) args result_ty
715 = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
718 simplCoerce env coercion ty expr args result_ty
719 = simplTy env ty `appEager` \ ty' ->
720 simplTy env expr_ty `appEager` \ expr_ty' ->
721 simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
722 returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
724 expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
726 -- Try cancellation; we do this "on the way up" because
727 -- I think that's where it'll bite best
728 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
729 mkCoerce coercion ty body = Coerce coercion ty body
733 %************************************************************************
735 \subsection[Simplify-bind]{Binding groups}
737 %************************************************************************
740 simplBind :: SimplEnv
742 -> (SimplEnv -> SmplM OutExpr)
746 simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
747 simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
751 %************************************************************************
753 \subsection[Simplify-let]{Let-expressions}
755 %************************************************************************
759 The booleans controlling floating have to be set with a little care.
760 Here's one performance bug I found:
762 let x = let y = let z = case a# +# 1 of {b# -> E1}
767 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
768 Before case_floating_ok included float_exposes_hnf, the case expression was floated
769 *one level per simplifier iteration* outwards. So it made th s
772 Floating case from let
773 ~~~~~~~~~~~~~~~~~~~~~~
774 When floating cases out of lets, remember this:
776 let x* = case e of alts
779 where x* is sure to be demanded or e is a cheap operation that cannot
780 fail, e.g. unboxed addition. Here we should be prepared to duplicate
781 <small expr>. A good example:
790 p1 -> foldr c n (build e1)
791 p2 -> foldr c n (build e2)
793 NEW: We use the same machinery that we use for case-of-case to
794 *always* do case floating from let, that is we let bind and abstract
795 the original let body, and let the occurrence analyser later decide
796 whether the new let should be inlined or not. The example above
800 let join_body x' = foldr c n x'
802 p1 -> let x* = build e1
804 p2 -> let x* = build e2
807 note that join_body is a let-no-escape.
808 In this particular example join_body will later be inlined,
809 achieving the same effect.
810 ToDo: check this is OK with andy
813 Let to case: two points
816 Point 1. We defer let-to-case for all data types except single-constructor
817 ones. Suppose we change
823 It can be the case that we find that b ultimately contains ...(case x of ..)....
824 and this is the only occurrence of x. Then if we've done let-to-case
825 we can't inline x, which is a real pain. On the other hand, we lose no
826 transformations by not doing this transformation, because the relevant
827 case-of-X transformations are also implemented by simpl_bind.
829 If x is a single-constructor type, then we go ahead anyway, giving
831 case e of (y,z) -> let x = (y,z) in b
833 because now we can squash case-on-x wherever they occur in b.
835 We do let-to-case on multi-constructor types in the tidy-up phase
836 (tidyCoreExpr) mainly so that the code generator doesn't need to
837 spot the demand-flag.
840 Point 2. It's important to try let-to-case before doing the
841 strict-let-of-case transformation, which happens in the next equation
844 let a*::Int = case v of {p1->e1; p2->e2}
847 (The * means that a is sure to be demanded.)
848 If we do case-floating first we get this:
852 p1-> let a*=e1 in k a
853 p2-> let a*=e2 in k a
855 Now watch what happens if we do let-to-case first:
857 case (case v of {p1->e1; p2->e2}) of
858 Int a# -> let a*=I# a# in b
860 let k = \a# -> let a*=I# a# in b
862 p1 -> case e1 of I# a# -> k a#
863 p1 -> case e2 of I# a# -> k a#
865 The latter is clearly better. (Remember the reboxing let-decl for a
866 is likely to go away, because after all b is strict in a.)
868 We do not do let to case for WHNFs, e.g.
874 as this is less efficient. but we don't mind doing let-to-case for
875 "bottom", as that will allow us to remove more dead code, if anything:
879 case error of x -> ...
883 Notice that let to case occurs only if x is used strictly in its body
888 -- Dead code is now discarded by the occurrence analyser,
890 simplNonRec env binder@(id,occ_info) rhs body_c body_ty
891 | inlineUnconditionally ok_to_dup occ_info
892 = -- The binder is used in definitely-inline way in the body
893 -- So add it to the environment, drop the binding, and continue
894 body_c (extendEnvGivenInlining env id occ_info rhs)
896 | idWantsToBeINLINEd id
897 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
902 -- Try let-to-case; see notes below about let-to-case
903 simpl_bind env rhs | try_let_to_case &&
907 singleConstructorType rhs_ty
908 -- Only do let-to-case for single constructor types.
909 -- For other types we defer doing it until the tidy-up phase at
910 -- the end of simplification.
912 = tick Let2Case `thenSmpl_`
913 simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
914 (\env rhs -> complete_bind env rhs) body_ty
915 -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
916 -- NB: it's tidier to call complete_bind not simpl_bind, else
917 -- we nearly end up in a loop. Consider:
919 -- ==> case rhs of (p,q) -> let x=(p,q) in b
920 -- This effectively what the above simplCase call does.
921 -- Now, the inner let is a let-to-case target again! Actually, since
922 -- the RHS is in WHNF it won't happen, but it's a close thing!
925 simpl_bind env (Let bind rhs) | let_floating_ok
926 = tick LetFloatFromLet `thenSmpl_`
927 simplBind env (fix_up_demandedness will_be_demanded bind)
928 (\env -> simpl_bind env rhs) body_ty
930 -- Try case-from-let; this deals with a strict let of error too
931 simpl_bind env (Case scrut alts) | case_floating_ok scrut
932 = tick CaseFloatFromLet `thenSmpl_`
934 -- First, bind large let-body if necessary
935 if ok_to_dup || isSingleton (nonErrorRHSs alts)
937 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
939 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
941 body_c' = \env -> simplExpr env new_body [] body_ty
942 case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
944 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
945 returnSmpl (Let extra_binding case_expr)
947 -- None of the above; simplify rhs and tidy up
948 simpl_bind env rhs = complete_bind env rhs
950 complete_bind env rhs
951 = cloneId env binder `thenSmpl` \ new_id ->
952 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
953 completeNonRec env binder
954 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
955 body_c new_env `thenSmpl` \ body' ->
956 returnSmpl (mkCoLetsAny binds body')
959 -- All this stuff is computed at the start of the simpl_bind loop
960 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
961 float_primops = switchIsSet env SimplOkToFloatPrimOps
962 ok_to_dup = switchIsSet env SimplOkToDupCode
963 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
964 try_let_to_case = switchIsSet env SimplLetToCase
965 no_float = switchIsSet env SimplNoLetFromStrictLet
967 demand_info = getIdDemandInfo id
968 will_be_demanded = willBeDemanded demand_info
971 form = mkFormSummary rhs
972 rhs_is_bot = case form of
975 rhs_is_whnf = case form of
980 float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
982 let_floating_ok = (will_be_demanded && not no_float) ||
983 always_float_let_from_let ||
986 case_floating_ok scrut = (will_be_demanded && not no_float) ||
987 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
992 @completeNonRec@ looks at the simplified post-floating RHS of the
993 let-expression, and decides what to do. There's one interesting
994 aspect to this, namely constructor reuse. Consider
1000 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1001 bit on the compiler technology, but in general I believe not. For
1002 example, here's some code from a real program:
1004 const.Int.max.wrk{-s2516-} =
1005 \ upk.s3297# upk.s3298# ->
1009 a.s3299 = I#! upk.s3297#
1011 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1012 _LT -> I#! upk.s3298#
1017 The a.s3299 really isn't doing much good. We'd be better off inlining
1018 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1020 So the current strategy is to inline all known-form constructors, and
1021 only do the reverse (turn a constructor application back into a
1022 variable) when we find a let-expression:
1026 ... (let y = C a1 .. an in ...) ...
1028 where it is always good to ditch the binding for y, and replace y by
1029 x. That's just what completeLetBinding does.
1034 The trouble is that we keep transforming
1042 and counting a couple of ticks for this non-transformation
1044 -- We want to ensure that all let-bound Coerces have
1045 -- atomic bodies, so they can freely be inlined.
1046 completeNonRec env binder new_id (Coerce coercion ty rhs)
1047 | not (is_atomic rhs)
1048 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1050 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1051 -- Dangerous occ because, like constructor args,
1052 -- it can be duplicated easily
1054 atomic_rhs = case runEager $ lookupId env1 inner_id of
1058 completeNonRec env1 binder new_id
1059 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1061 returnSmpl (env2, binds1 ++ binds2)
1065 -- Right hand sides that are constructors
1068 --- ...(let w = C same-args in ...)...
1069 -- Then use v instead of w. This may save
1070 -- re-constructing an existing constructor.
1071 completeNonRec env binder new_id rhs@(Con con con_args)
1072 | switchIsSet env SimplReuseCon &&
1073 maybeToBool maybe_existing_con &&
1074 not (isExported new_id) -- Don't bother for exported things
1075 -- because we won't be able to drop
1077 = tick ConReused `thenSmpl_`
1078 returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
1080 maybe_existing_con = lookForConstructor env con con_args
1081 Just it = maybe_existing_con
1085 -- Check for atomic right-hand sides.
1086 -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
1087 -- than it's worth. For a top-level binding a = b, where a is exported,
1088 -- we can't drop the binding, so we get repeated AtomicRhs ticks
1089 completeNonRec env binder@(id,occ_info) new_id new_rhs
1090 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1091 = returnSmpl (atomic_env , [NonRec new_id eta'd_rhs])
1093 | otherwise -- Non atomic rhs (don't eta after all)
1094 = returnSmpl (non_atomic_env , [NonRec new_id new_rhs])
1096 atomic_env = extendIdEnvWithAtom env binder the_arg
1098 non_atomic_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
1099 occ_info new_id new_rhs
1101 eta'd_rhs = etaCoreExpr new_rhs
1102 the_arg = case eta'd_rhs of
1107 %************************************************************************
1109 \subsection[Simplify-letrec]{Letrec-expressions}
1111 %************************************************************************
1115 Here's the game plan
1117 1. Float any let(rec)s out of the RHSs
1118 2. Clone all the Ids and extend the envt with these clones
1119 3. Simplify one binding at a time, adding each binding to the
1120 environment once it's done.
1122 This relies on the occurrence analyser to
1123 a) break all cycles with an Id marked MustNotBeInlined
1124 b) sort the decls into topological order
1125 The former prevents infinite inlinings, and the latter means
1126 that we get maximum benefit from working top to bottom.
1130 simplRec env pairs body_c body_ty
1131 = -- Do floating, if necessary
1132 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1134 binders = map fst pairs'
1136 cloneIds env binders `thenSmpl` \ ids' ->
1138 env_w_clones = extendIdEnvWithClones env binders ids'
1140 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1142 body_c new_env `thenSmpl` \ body' ->
1144 returnSmpl (Let (Rec pairs') body')
1148 -- The env passed to simplRecursiveGroup already has
1149 -- bindings that clone the variables of the group.
1150 simplRecursiveGroup env new_ids []
1151 = returnSmpl ([], env)
1153 simplRecursiveGroup env (new_id : new_ids) ((binder@(_, occ_info), rhs) : pairs)
1154 | inlineUnconditionally ok_to_dup occ_info
1155 = -- Single occurrence, so drop binding and extend env with the inlining
1157 new_env = extendEnvGivenInlining env new_id occ_info rhs
1159 simplRecursiveGroup new_env new_ids pairs
1162 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1164 new_id' = new_id `withArity` arity
1166 -- ToDo: this next bit could usefully share code with completeNonRec
1169 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1172 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1173 = extendIdEnvWithAtom env binder the_arg
1175 | otherwise -- Non-atomic
1176 = extendEnvGivenBinding env occ_info new_id new_rhs
1177 -- Don't eta if it doesn't eliminate the binding
1179 eta'd_rhs = etaCoreExpr new_rhs
1180 the_arg = case eta'd_rhs of
1184 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1185 returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
1187 ok_to_dup = switchIsSet env SimplOkToDupCode
1193 floatBind :: SimplEnv
1194 -> Bool -- True <=> Top level
1196 -> SmplM [InBinding]
1198 floatBind env top_level bind
1204 = tickN LetFloatFromLet n_extras `thenSmpl_`
1205 -- It's important to increment the tick counts if we
1206 -- do any floating. A situation where this turns out
1207 -- to be important is this:
1208 -- Float in produces:
1209 -- letrec x = let y = Ey in Ex
1211 -- Now floating gives this:
1215 --- We now want to iterate once more in case Ey doesn't
1216 -- mention x, in which case the y binding can be pulled
1217 -- out as an enclosing let(rec), which in turn gives
1218 -- the strictness analyser more chance.
1222 (binds', _, n_extras) = fltBind bind
1224 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1225 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1227 -- fltBind guarantees not to return leaky floats
1228 -- and all the binders of the floats have had their demand-info zapped
1229 fltBind (NonRec bndr rhs)
1230 = (binds ++ [NonRec (un_demandify bndr) rhs'],
1234 (binds, rhs') = fltRhs rhs
1239 binders `zip` rhss')],
1240 and (zipWith leakFree binders rhss'),
1245 (binders, rhss) = unzip pairs
1246 (binds_s, rhss') = mapAndUnzip fltRhs rhss
1247 extras = concat (map get_pairs (concat binds_s))
1249 get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
1250 get_pairs (Rec pairs) = pairs
1252 -- fltRhs has same invariant as fltBind
1254 | (always_float_let_from_let ||
1255 floatExposesHNF True False False rhs)
1262 -- fltExpr has same invariant as fltBind
1263 fltExpr (Let bind body)
1264 | not top_level || binds_wont_leak
1265 -- fltExpr guarantees not to return leaky floats
1266 = (binds' ++ body_binds, body')
1268 (body_binds, body') = fltExpr body
1269 (binds', binds_wont_leak, _) = fltBind bind
1271 fltExpr expr = ([], expr)
1273 -- Crude but effective
1274 leakFree (id,_) rhs = case getIdArity id of
1275 ArityAtLeast n | n > 0 -> True
1276 ArityExactly n | n > 0 -> True
1277 other -> whnfOrBottom rhs
1281 %************************************************************************
1283 \subsection[Simplify-atoms]{Simplifying atoms}
1285 %************************************************************************
1288 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1290 simplArg env (LitArg lit) = returnEager (LitArg lit)
1291 simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
1292 returnEager (TyArg ty')
1293 simplArg env (VarArg id) = lookupId env id
1296 %************************************************************************
1298 \subsection[Simplify-quickies]{Some local help functions}
1300 %************************************************************************
1304 -- fix_up_demandedness switches off the willBeDemanded Info field
1305 -- for bindings floated out of a non-demanded let
1306 fix_up_demandedness True {- Will be demanded -} bind
1307 = bind -- Simple; no change to demand info needed
1308 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1309 = NonRec (un_demandify binder) rhs
1310 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1311 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1313 un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1315 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1316 is_cheap_prim_app other = False
1318 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1319 computeResultType env expr_ty orig_args
1320 = simplTy env expr_ty `appEager` \ expr_ty' ->
1323 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1324 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1325 Just (_, res_ty) -> go res_ty args
1327 pprPanic "computeResultType" (vcat [
1328 ppr PprDebug (a:args),
1329 ppr PprDebug orig_args,
1330 ppr PprDebug expr_ty',
1333 go expr_ty' orig_args
1336 var `withArity` UnknownArity = var
1337 var `withArity` arity = var `addIdArity` arity
1339 is_atomic (Var v) = True
1340 is_atomic (Lit l) = not (isNoRepLit l)
1341 is_atomic other = False