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, applyTys,
42 mkFunTys, splitAlgTyConApp_maybe,
43 splitFunTys, splitFunTy_maybe, isUnpointedType
45 import TysPrim ( realWorldStatePrimTy )
46 import Util ( Eager, appEager, returnEager, runEager, mapEager,
47 isSingleton, zipEqual, zipWithEqual, mapAndUnzip
52 The controlling flags, and what they do
53 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
57 -fsimplify = run the simplifier
58 -ffloat-inwards = runs the float lets inwards pass
59 -ffloat = runs the full laziness pass
60 (ToDo: rename to -ffull-laziness)
61 -fupdate-analysis = runs update analyser
62 -fstrictness = runs strictness analyser
63 -fsaturate-apps = saturates applications (eta expansion)
67 -ffloat-past-lambda = OK to do full laziness.
68 (ToDo: remove, as the full laziness pass is
69 useless without this flag, therefore
70 it is unnecessary. Just -ffull-laziness
73 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
74 let is strict or if the floating will expose
77 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
78 is a primop that cannot fail [simplifier].
80 -fcode-duplication-ok = allows the previous option to work on cases with
81 multiple branches [simplifier].
83 -flet-to-case = does let-to-case transformation [simplifier].
85 -fcase-of-case = does case of case transformation [simplifier].
87 -fpedantic-bottoms = does not allow:
88 case x of y -> e ===> e[x/y]
89 (which may turn bottom into non-bottom)
95 Inlining is one of the delicate aspects of the simplifier. By
96 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
97 the RHS of x's definition. Thus
99 let x = e in ...x... ===> let x = e in ...e...
101 We have two mechanisms for inlining:
103 1. Unconditional. The occurrence analyser has pinned an (OneOcc
104 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
105 certainly safe to inline this variable, and to drop its binding''.
106 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
107 happy to be duplicating code...) When it encounters such a beast, the
108 simplifer binds the variable to its RHS (in the id_env) and continues.
109 It doesn't even look at the RHS at that stage. It also drops the
112 2. Conditional. In all other situations, the simplifer simplifies
113 the RHS anyway, and keeps the new binding. It also binds the new
114 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
116 Here, ``suitable'' might mean NoUnfolding (if the occurrence
117 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
118 the variable has an INLINE pragma on it). The idea is that anything
119 in the UnfoldEnv is safe to use, but also has an enclosing binding if
120 you decide not to use it.
124 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
127 At one time I thought it would be OK to put non-HNF unfoldings in for
128 variables which occur only once [if they got inlined at that
129 occurrence the RHS of the binding would become dead, so no duplication
130 would occur]. But consider:
133 f = \y -> ...y...y...y...
136 Now, it seems that @x@ appears only once, but even so it is NOT safe
137 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
138 duplicate the references to @x@.
140 Because of this, the "unconditional-inline" mechanism above is the
141 only way in which non-HNFs can get inlined.
146 When a variable has an INLINE pragma on it --- which includes wrappers
147 produced by the strictness analyser --- we treat it rather carefully.
149 For a start, we are careful not to substitute into its RHS, because
150 that might make it BIG, and the user said "inline exactly this", not
151 "inline whatever you get after inlining other stuff inside me". For
155 in {-# INLINE y #-} y = f 3
158 Here we don't want to substitute BIG for the (single) occurrence of f,
159 because then we'd duplicate BIG when we inline'd y. (Exception:
160 things in the UnfoldEnv with UnfoldAlways flags, which originated in
161 other INLINE pragmas.)
163 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
164 going into such an RHS.
166 What about imports? They don't really matter much because we only
167 inline relatively small things via imports.
169 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
170 INLINE pragma. We also do this for the RHSs of recursive decls,
171 before looking at the recursive decls. That way we achieve the effect
172 of inlining a wrapper in the body of its worker, in the case of a
173 mutually-recursive worker/wrapper split.
176 %************************************************************************
178 \subsection[Simplify-simplExpr]{The main function: simplExpr}
180 %************************************************************************
182 At the top level things are a little different.
184 * No cloning (not allowed for exported Ids, unnecessary for the others)
185 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
188 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
190 -- Dead code is now discarded by the occurrence analyser,
192 simplTopBinds env binds
193 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
194 simpl_top_binds env (concat binds_s)
196 simpl_top_binds env [] = returnSmpl []
198 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
199 = --- No cloning necessary at top level
200 simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) ->
201 completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
202 simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
203 returnSmpl (binds1' ++ binds2')
205 simpl_top_binds env (Rec pairs : binds)
206 = -- No cloning necessary at top level, but we nevertheless
207 -- add the Ids to the environment. This makes sure that
208 -- info carried on the Id (such as arity info) gets propagated
211 -- This may seem optional, but I found an occasion when it Really matters.
212 -- Consider foo{n} = ...foo...
215 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
216 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
217 -- thing: baz*{n} = ...baz...
219 -- Sure we could have made the indirection-shorting a bit cleverer, but
220 -- propagating pragma info is a Good Idea anyway.
222 env1 = extendIdEnvWithClones env binders ids
224 simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) ->
225 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
226 returnSmpl (Rec bind' : binds')
228 binders = map fst pairs
229 ids = map fst binders
232 %************************************************************************
234 \subsection[Simplify-simplExpr]{The main function: simplExpr}
236 %************************************************************************
240 simplExpr :: SimplEnv
241 -> InExpr -> [OutArg]
242 -> OutType -- Type of (e args); i.e. type of overall result
246 The expression returned has the same meaning as the input expression
247 applied to the specified arguments.
252 Check if there's a macro-expansion, and if so rattle on. Otherwise do
253 the more sophisticated stuff.
256 simplExpr env (Var v) args result_ty
257 = case (runEager $ lookupId env v) of
258 LitArg lit -- A boring old literal
259 -> ASSERT( null args )
262 VarArg var -- More interesting! An id!
263 -> completeVar env var args result_ty
264 -- Either Id is in the local envt, or it's a global.
265 -- In either case we don't need to apply the type
266 -- environment to it.
273 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
275 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
279 Primitive applications are simple.
280 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
282 NB: Prim expects an empty argument list! (Because it should be
283 saturated and not higher-order. ADR)
286 simplExpr env (Prim op prim_args) args result_ty
288 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
289 simpl_op op `appEager` \ op' ->
290 completePrim env op' prim_args'
292 -- PrimOps just need any types in them renamed.
294 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
295 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
296 simplTy env result_ty `appEager` \ result_ty' ->
297 returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
299 simpl_op other_op = returnEager other_op
302 Constructor applications
303 ~~~~~~~~~~~~~~~~~~~~~~~~
304 Nothing to try here. We only reuse constructors when they appear as the
305 rhs of a let binding (see completeLetBinding).
308 simplExpr env (Con con con_args) args result_ty
309 = ASSERT( null args )
310 mapEager (simplArg env) con_args `appEager` \ con_args' ->
311 returnSmpl (Con con con_args')
315 Applications are easy too:
316 ~~~~~~~~~~~~~~~~~~~~~~~~~~
317 Just stuff 'em in the arg stack
320 simplExpr env (App fun arg) args result_ty
321 = simplArg env arg `appEager` \ arg' ->
322 simplExpr env fun (arg' : args) result_ty
328 First the case when it's applied to an argument.
331 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
332 = tick TyBetaReduction `thenSmpl_`
333 simplExpr (extendTyEnv env tyvar ty) body args result_ty
337 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
338 = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
340 new_ty = mkTyVarTy tyvar'
341 new_env = extendTyEnv env tyvar new_ty
342 new_result_ty = applyTy result_ty new_ty
344 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
345 returnSmpl (Lam (TyBinder tyvar') body')
348 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
349 = panic "simplExpr:TyLam with non-TyArg"
357 There's a complication with lambdas that aren't saturated.
362 If we did nothing, x is used inside the \y, so would be marked
363 as dangerous to dup. But in the common case where the abstraction
364 is applied to two arguments this is over-pessimistic.
365 So instead we don't take account of the \y when dealing with x's usage;
366 instead, the simplifier is careful when partially applying lambdas.
369 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
370 = go 0 env expr orig_args
372 go n env (Lam (ValBinder binder) body) (val_arg : args)
373 | isValArg val_arg -- The lambda has an argument
374 = tick BetaReduction `thenSmpl_`
375 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
377 go n env expr@(Lam (ValBinder binder) body) args
378 -- The lambda is un-saturated, so we must zap the occurrence info
379 -- on the arguments we've already beta-reduced into the body of the lambda
380 = ASSERT( null args ) -- Value lambda must match value argument!
382 new_env = markDangerousOccs env (take n orig_args)
384 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
385 `thenSmpl` \ (expr', arity) ->
388 go n env non_val_lam_expr args -- The lambda had enough arguments
389 = simplExpr env non_val_lam_expr args result_ty
397 simplExpr env (Let bind body) args result_ty
398 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
405 simplExpr env expr@(Case scrut alts) args result_ty
406 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
413 simplExpr env (Coerce coercion ty body) args result_ty
414 = simplCoerce env coercion ty body args result_ty
421 1) Eliminating nested sccs ...
422 We must be careful to maintain the scc counts ...
425 simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
426 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
427 -- eliminate inner scc if no call counts and same cc as outer
428 = simplExpr env (SCC cc1 expr) args result_ty
430 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
431 -- eliminate outer scc if no call counts associated with either ccs
432 = simplExpr env (SCC cc2 expr) args result_ty
435 2) Moving sccs inside lambdas ...
438 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
439 | not (isSccCountCostCentre cc)
440 -- move scc inside lambda only if no call counts
441 = simplExpr env (Lam binder (SCC cc body)) args result_ty
443 simplExpr env (SCC cc (Lam binder body)) args result_ty
444 -- always ok to move scc inside type/usage lambda
445 = simplExpr env (Lam binder (SCC cc body)) args result_ty
448 3) Eliminating dict sccs ...
451 simplExpr env (SCC cc expr) args result_ty
452 | squashableDictishCcExpr cc expr
453 -- eliminate dict cc if trivial dict expression
454 = simplExpr env expr args result_ty
457 4) Moving arguments inside the body of an scc ...
458 This moves the cost of doing the application inside the scc
459 (which may include the cost of extracting methods etc)
462 simplExpr env (SCC cost_centre body) args result_ty
464 new_env = setEnclosingCC env cost_centre
466 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
467 returnSmpl (SCC cost_centre body')
470 %************************************************************************
472 \subsection{Simplify RHS of a Let/Letrec}
474 %************************************************************************
476 simplRhsExpr does arity-expansion. That is, given:
478 * a right hand side /\ tyvars -> \a1 ... an -> e
479 * the information (stored in BinderInfo) that the function will always
480 be applied to at least k arguments
482 it transforms the rhs to
484 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
486 This is a Very Good Thing!
493 -> OutId -- The new binder (used only for its type)
494 -> SmplM (OutExpr, ArityInfo)
499 simplRhsExpr env binder@(id,occ_info) rhs new_id
500 | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
501 -- Deal with the data type case, in which case the elaborate
502 -- eta-expansion nonsense is really quite a waste of time.
503 = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
504 returnSmpl (rhs', ArityExactly 0)
506 | otherwise -- OK, use the big hammer
507 = -- Deal with the big lambda part
508 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
510 new_tys = mkTyVarTys tyvars'
511 body_ty = applyTys rhs_ty new_tys
512 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
514 -- Deal with the little lambda part
515 -- Note that we call simplLam even if there are no binders,
516 -- in case it can do arity expansion.
517 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
519 -- Put on the big lambdas, trying to float out any bindings caught inside
520 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
522 returnSmpl (rhs', arity)
524 rhs_ty = idType new_id
525 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
526 = switchOffInlining env1 -- See comments with switchOffInlining
530 -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
531 -- for the rhs of top level defs is "OST_CENTRE". Consider
533 -- g = \y -> let v = f y in scc "x" (v ...)
534 -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
535 -- want to inline "v" since its CC is dynamically determined.
537 current_cc = getEnclosingCC env
538 env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
541 (tyvars, body) = collectTyBinders rhs
545 ----------------------------------------------------------------
546 An old special case that is now nuked.
548 First a special case for variable right-hand sides
550 It's OK to simplify the RHS, but it's often a waste of time. Often
551 these v = w things persist because v is exported, and w is used
552 elsewhere. So if we're not careful we'll eta expand the rhs, only
553 to eta reduce it in competeNonRec.
555 If we leave the binding unchanged, we will certainly replace v by w at
556 every occurrence of v, which is good enough.
558 In fact, it's *better* to replace v by w than to inline w in v's rhs,
559 even if this is the only occurrence of w. Why? Because w might have
560 IdInfo (such as strictness) that v doesn't.
562 Furthermore, there might be other uses of w; if so, inlining w in
563 v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
565 HOWEVER, we have to be careful if w is something that *must* be
566 inlined. In particular, its binding may have been dropped. Here's
567 an example that actually happened:
568 let x = let y = e in y
570 The "let y" was floated out, and then (since y occurs once in a
571 definitely inlinable position) the binding was dropped, leaving
572 {y=e} let x = y in f x
573 But now using the reasoning of this little section,
574 y wasn't inlined, because it was a let x=y form.
579 This "optimisation" turned out to be a bad idea. If there's are
580 top-level exported bindings like
585 then y wasn't getting inlined in x's rhs, and we were getting
586 bad code. So I've removed the special case from here, and
587 instead we only try eta reduction and constructor reuse
588 in completeNonRec if the thing is *not* exported.
592 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
593 | maybeToBool maybe_stop_at_var
594 = returnSmpl (Var the_var, getIdArity the_var)
597 = case (runEager $ lookupId env v) of
598 VarArg v' | not (must_unfold v') -> Just v'
601 Just the_var = maybe_stop_at_var
603 must_unfold v' = idMustBeINLINEd v'
604 || case lookupOutIdEnv env v' of
605 Just (_, _, InUnfolding _ _) -> True
609 End of old, nuked, special case.
610 ------------------------------------------------------------------
613 %************************************************************************
615 \subsection{Simplify a lambda abstraction}
617 %************************************************************************
619 Simplify (\binders -> body) trying eta expansion and reduction, given that
620 the abstraction will always be applied to at least min_no_of_args.
623 simplValLam env expr min_no_of_args expr_ty
624 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
626 exprIsTrivial expr || -- or it's a trivial RHS
627 -- No eta expansion for trivial RHSs
628 -- It's rather a Bad Thing to expand
631 -- g = \a b c -> f alpha beta a b c
633 -- The original RHS is "trivial" (exprIsTrivial), because it generates
634 -- no code (renames f to g). But the new RHS isn't.
636 null potential_extra_binder_tys || -- or ain't a function
637 no_of_extra_binders <= 0 -- or no extra binders needed
638 = cloneIds env binders `thenSmpl` \ binders' ->
640 new_env = extendIdEnvWithClones env binders binders'
642 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
643 returnSmpl (mkValLam binders' body', final_arity)
645 | otherwise -- Eta expansion possible
646 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
647 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
648 pprTrace "simplValLam" (vcat [ppr expr,
651 int no_of_extra_binders,
652 ppr potential_extra_binder_tys])
655 tick EtaExpansion `thenSmpl_`
656 cloneIds env binders `thenSmpl` \ binders' ->
658 new_env = extendIdEnvWithClones env binders binders'
660 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
661 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
663 mkValLam (binders' ++ extra_binders') body',
668 (binders,body) = collectValBinders expr
669 no_of_binders = length binders
670 (arg_tys, res_ty) = splitFunTys expr_ty
671 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
672 pprTrace "simplValLam" (vcat [ppr expr,
676 drop no_of_binders arg_tys
677 body_ty = mkFunTys potential_extra_binder_tys res_ty
679 -- Note: it's possible that simplValLam will be applied to something
680 -- with a forall type. Eg when being applied to the rhs of
682 -- where wurble has a forall-type, but no big lambdas at the top.
683 -- We could be clever an insert new big lambdas, but we don't bother.
685 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
686 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
687 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
689 no_of_extra_binders = -- First, use the info about how many args it's
690 -- always applied to in its scope; but ignore this
691 -- info for thunks. To see why we ignore it for thunks,
692 -- consider let f = lookup env key in (f 1, f 2)
693 -- We'd better not eta expand f just because it is
695 (min_no_of_args - no_of_binders)
697 -- Next, try seeing if there's a lambda hidden inside
699 -- etaExpandCount can reuturn a huge number (like 10000!) if
700 -- it finds that the body is a call to "error"; hence
701 -- the use of "min" here.
703 (etaExpandCount body `min` length potential_extra_binder_tys)
705 -- Finally, see if it's a state transformer, in which
706 -- case we eta-expand on principle! This can waste work,
707 -- but usually doesn't
709 case potential_extra_binder_tys of
710 [ty] | ty == realWorldStatePrimTy -> 1
716 %************************************************************************
718 \subsection[Simplify-coerce]{Coerce expressions}
720 %************************************************************************
723 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
724 simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
725 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
727 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
728 simplCoerce env coercion ty (Let bind body) args result_ty
729 = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
732 simplCoerce env coercion ty expr args result_ty
733 = simplTy env ty `appEager` \ ty' ->
734 simplTy env expr_ty `appEager` \ expr_ty' ->
735 simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
736 returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
738 expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
740 -- Try cancellation; we do this "on the way up" because
741 -- I think that's where it'll bite best
742 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
743 mkCoerce coercion ty body = Coerce coercion ty body
747 %************************************************************************
749 \subsection[Simplify-bind]{Binding groups}
751 %************************************************************************
754 simplBind :: SimplEnv
756 -> (SimplEnv -> SmplM OutExpr)
760 simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
761 simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
765 %************************************************************************
767 \subsection[Simplify-let]{Let-expressions}
769 %************************************************************************
773 The booleans controlling floating have to be set with a little care.
774 Here's one performance bug I found:
776 let x = let y = let z = case a# +# 1 of {b# -> E1}
781 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
782 Before case_floating_ok included float_exposes_hnf, the case expression was floated
783 *one level per simplifier iteration* outwards. So it made th s
786 Floating case from let
787 ~~~~~~~~~~~~~~~~~~~~~~
788 When floating cases out of lets, remember this:
790 let x* = case e of alts
793 where x* is sure to be demanded or e is a cheap operation that cannot
794 fail, e.g. unboxed addition. Here we should be prepared to duplicate
795 <small expr>. A good example:
804 p1 -> foldr c n (build e1)
805 p2 -> foldr c n (build e2)
807 NEW: We use the same machinery that we use for case-of-case to
808 *always* do case floating from let, that is we let bind and abstract
809 the original let body, and let the occurrence analyser later decide
810 whether the new let should be inlined or not. The example above
814 let join_body x' = foldr c n x'
816 p1 -> let x* = build e1
818 p2 -> let x* = build e2
821 note that join_body is a let-no-escape.
822 In this particular example join_body will later be inlined,
823 achieving the same effect.
824 ToDo: check this is OK with andy
827 Let to case: two points
830 Point 1. We defer let-to-case for all data types except single-constructor
831 ones. Suppose we change
837 It can be the case that we find that b ultimately contains ...(case x of ..)....
838 and this is the only occurrence of x. Then if we've done let-to-case
839 we can't inline x, which is a real pain. On the other hand, we lose no
840 transformations by not doing this transformation, because the relevant
841 case-of-X transformations are also implemented by simpl_bind.
843 If x is a single-constructor type, then we go ahead anyway, giving
845 case e of (y,z) -> let x = (y,z) in b
847 because now we can squash case-on-x wherever they occur in b.
849 We do let-to-case on multi-constructor types in the tidy-up phase
850 (tidyCoreExpr) mainly so that the code generator doesn't need to
851 spot the demand-flag.
854 Point 2. It's important to try let-to-case before doing the
855 strict-let-of-case transformation, which happens in the next equation
858 let a*::Int = case v of {p1->e1; p2->e2}
861 (The * means that a is sure to be demanded.)
862 If we do case-floating first we get this:
866 p1-> let a*=e1 in k a
867 p2-> let a*=e2 in k a
869 Now watch what happens if we do let-to-case first:
871 case (case v of {p1->e1; p2->e2}) of
872 Int a# -> let a*=I# a# in b
874 let k = \a# -> let a*=I# a# in b
876 p1 -> case e1 of I# a# -> k a#
877 p1 -> case e2 of I# a# -> k a#
879 The latter is clearly better. (Remember the reboxing let-decl for a
880 is likely to go away, because after all b is strict in a.)
882 We do not do let to case for WHNFs, e.g.
888 as this is less efficient. but we don't mind doing let-to-case for
889 "bottom", as that will allow us to remove more dead code, if anything:
893 case error of x -> ...
897 Notice that let to case occurs only if x is used strictly in its body
902 -- Dead code is now discarded by the occurrence analyser,
904 simplNonRec env binder@(id,occ_info) rhs body_c body_ty
905 | inlineUnconditionally ok_to_dup id occ_info
906 = -- The binder is used in definitely-inline way in the body
907 -- So add it to the environment, drop the binding, and continue
908 body_c (extendEnvGivenInlining env id occ_info rhs)
910 | idWantsToBeINLINEd id
911 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
914 -- Do let-to-case right away for unpointed types
915 -- These shouldn't occur much, but do occur right after desugaring,
916 -- because we havn't done dependency analysis at that point, so
917 -- we can't trivially do let-to-case (because there may be some unboxed
918 -- things bound in letrecs that aren't really recursive).
919 | isUnpointedType rhs_ty && not rhs_is_whnf
920 = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id)))
921 (\env rhs -> complete_bind env rhs) body_ty
923 -- Try let-to-case; see notes below about let-to-case
927 || (not rhs_is_whnf && singleConstructorType rhs_ty)
928 -- Don't do let-to-case if the RHS is a constructor application.
929 -- Even then only do it for single constructor types.
930 -- For other types we defer doing it until the tidy-up phase at
931 -- the end of simplification.
933 = tick Let2Case `thenSmpl_`
934 simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
935 (\env rhs -> complete_bind env rhs) body_ty
936 -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
937 -- NB: it's tidier to call complete_bind not simpl_bind, else
938 -- we nearly end up in a loop. Consider:
940 -- ==> case rhs of (p,q) -> let x=(p,q) in b
941 -- This effectively what the above simplCase call does.
942 -- Now, the inner let is a let-to-case target again! Actually, since
943 -- the RHS is in WHNF it won't happen, but it's a close thing!
949 simpl_bind env (Let bind rhs) | let_floating_ok
950 = tick LetFloatFromLet `thenSmpl_`
951 simplBind env (if will_be_demanded then bind
952 else un_demandify_bind bind)
953 (\env -> simpl_bind env rhs) body_ty
955 -- Try case-from-let; this deals with a strict let of error too
956 simpl_bind env (Case scrut alts) | case_floating_ok scrut
957 = tick CaseFloatFromLet `thenSmpl_`
959 -- First, bind large let-body if necessary
960 if ok_to_dup || isSingleton (nonErrorRHSs alts)
962 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
964 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
966 body_c' = \env -> simplExpr env new_body [] body_ty
967 case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
969 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
970 returnSmpl (Let extra_binding case_expr)
972 -- None of the above; simplify rhs and tidy up
973 simpl_bind env rhs = complete_bind env rhs
975 complete_bind env rhs
976 = cloneId env binder `thenSmpl` \ new_id ->
977 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
978 completeNonRec env binder
979 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
980 body_c new_env `thenSmpl` \ body' ->
981 returnSmpl (mkCoLetsAny binds body')
984 -- All this stuff is computed at the start of the simpl_bind loop
985 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
986 float_primops = switchIsSet env SimplOkToFloatPrimOps
987 ok_to_dup = switchIsSet env SimplOkToDupCode
988 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
989 try_let_to_case = switchIsSet env SimplLetToCase
990 no_float = switchIsSet env SimplNoLetFromStrictLet
992 demand_info = getIdDemandInfo id
993 will_be_demanded = willBeDemanded demand_info
996 form = mkFormSummary rhs
997 rhs_is_bot = case form of
1000 rhs_is_whnf = case form of
1005 float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
1007 let_floating_ok = (will_be_demanded && not no_float) ||
1008 always_float_let_from_let ||
1011 case_floating_ok scrut = (will_be_demanded && not no_float) ||
1012 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
1017 @completeNonRec@ looks at the simplified post-floating RHS of the
1018 let-expression, with a view to turning
1022 where y is just a variable. Now we can eliminate the binding
1023 altogether, and replace x by y throughout.
1025 There are two cases when we can do this:
1027 * When e is a constructor application, and we have
1028 another variable in scope bound to the same
1029 constructor application. [This is just a special
1030 case of common-subexpression elimination.]
1032 * When e can be eta-reduced to a variable. E.g.
1036 HOWEVER, if x is exported, we don't attempt this at all. Why not?
1037 Because then we can't remove the x=y binding, in which case we
1038 have just made things worse, perhaps a lot worse.
1041 -- Right hand sides that are constructors
1044 --- ...(let w = C same-args in ...)...
1045 -- Then use v instead of w. This may save
1046 -- re-constructing an existing constructor.
1047 completeNonRec env binder new_id new_rhs
1048 | not (isExported new_id) -- Don't bother for exported things
1049 -- because we won't be able to drop
1051 && maybeToBool maybe_atomic_rhs
1052 = tick tick_type `thenSmpl_`
1053 returnSmpl (extendIdEnvWithAtom env binder rhs_arg, [])
1055 Just (rhs_arg, tick_type) = maybe_atomic_rhs
1057 = -- Try first for an existing constructor application
1058 case maybe_con new_rhs of {
1059 Just con -> Just (VarArg con, ConReused);
1061 Nothing -> -- No good; try eta-reduction
1062 case etaCoreExpr new_rhs of {
1063 Var v -> Just (VarArg v, AtomicRhs);
1064 Lit l -> Just (LitArg l, AtomicRhs);
1066 other -> Nothing -- Neither worked, so return Nothing
1070 maybe_con (Con con con_args) | switchIsSet env SimplReuseCon
1071 = lookForConstructor env con con_args
1072 maybe_con other_rhs = Nothing
1074 completeNonRec env binder@(id,occ_info) new_id new_rhs
1075 = returnSmpl (new_env , [NonRec new_id new_rhs])
1077 new_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
1078 occ_info new_id new_rhs
1081 ----------------------------------------------------------------------------
1082 A digression on constructor CSE
1090 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1091 bit on the compiler technology, but in general I believe not. For
1092 example, here's some code from a real program:
1094 const.Int.max.wrk{-s2516-} =
1095 \ upk.s3297# upk.s3298# ->
1099 a.s3299 = I#! upk.s3297#
1101 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1102 _LT -> I#! upk.s3298#
1107 The a.s3299 really isn't doing much good. We'd be better off inlining
1108 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1110 So the current strategy is to inline all known-form constructors, and
1111 only do the reverse (turn a constructor application back into a
1112 variable) when we find a let-expression:
1116 ... (let y = C a1 .. an in ...) ...
1118 where it is always good to ditch the binding for y, and replace y by
1121 ----------------------------------------------------------------------------
1123 ----------------------------------------------------------------------------
1124 A digression on "optimising" coercions
1126 The trouble is that we kept transforming
1134 and counting a couple of ticks for this non-transformation
1136 -- We want to ensure that all let-bound Coerces have
1137 -- atomic bodies, so they can freely be inlined.
1138 completeNonRec env binder new_id (Coerce coercion ty rhs)
1139 | not (is_atomic rhs)
1140 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1142 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1143 -- Dangerous occ because, like constructor args,
1144 -- it can be duplicated easily
1146 atomic_rhs = case runEager $ lookupId env1 inner_id of
1150 completeNonRec env1 binder new_id
1151 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1153 returnSmpl (env2, binds1 ++ binds2)
1155 ----------------------------------------------------------------------------
1159 %************************************************************************
1161 \subsection[Simplify-letrec]{Letrec-expressions}
1163 %************************************************************************
1167 Here's the game plan
1169 1. Float any let(rec)s out of the RHSs
1170 2. Clone all the Ids and extend the envt with these clones
1171 3. Simplify one binding at a time, adding each binding to the
1172 environment once it's done.
1174 This relies on the occurrence analyser to
1175 a) break all cycles with an Id marked MustNotBeInlined
1176 b) sort the decls into topological order
1177 The former prevents infinite inlinings, and the latter means
1178 that we get maximum benefit from working top to bottom.
1182 simplRec env pairs body_c body_ty
1183 = -- Do floating, if necessary
1184 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1186 binders = map fst pairs'
1188 cloneIds env binders `thenSmpl` \ ids' ->
1190 env_w_clones = extendIdEnvWithClones env binders ids'
1192 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1194 body_c new_env `thenSmpl` \ body' ->
1196 returnSmpl (Let (Rec pairs') body')
1200 -- The env passed to simplRecursiveGroup already has
1201 -- bindings that clone the variables of the group.
1202 simplRecursiveGroup env new_ids []
1203 = returnSmpl ([], env)
1205 simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs)
1206 | inlineUnconditionally ok_to_dup id occ_info
1207 = -- Single occurrence, so drop binding and extend env with the inlining
1208 -- This is a little delicate, because what if the unique occurrence
1209 -- is *before* this binding? This'll never happen, because
1210 -- either it'll be marked "never inline" or else its occurrence will
1211 -- occur after its binding in the group.
1213 -- If these claims aren't right Core Lint will spot an unbound
1214 -- variable. A quick fix is to delete this clause for simplRecursiveGroup
1216 new_env = extendEnvGivenInlining env new_id occ_info rhs
1218 simplRecursiveGroup new_env new_ids pairs
1221 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1223 new_id' = new_id `withArity` arity
1225 -- ToDo: this next bit could usefully share code with completeNonRec
1228 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1231 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1232 = extendIdEnvWithAtom env binder the_arg
1234 | otherwise -- Non-atomic
1235 = extendEnvGivenBinding env occ_info new_id new_rhs
1236 -- Don't eta if it doesn't eliminate the binding
1238 eta'd_rhs = etaCoreExpr new_rhs
1239 the_arg = case eta'd_rhs of
1243 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1244 returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
1246 ok_to_dup = switchIsSet env SimplOkToDupCode
1252 floatBind :: SimplEnv
1253 -> Bool -- True <=> Top level
1255 -> SmplM [InBinding]
1257 floatBind env top_level bind
1263 = tickN LetFloatFromLet n_extras `thenSmpl_`
1264 -- It's important to increment the tick counts if we
1265 -- do any floating. A situation where this turns out
1266 -- to be important is this:
1267 -- Float in produces:
1268 -- letrec x = let y = Ey in Ex
1270 -- Now floating gives this:
1274 --- We now want to iterate once more in case Ey doesn't
1275 -- mention x, in which case the y binding can be pulled
1276 -- out as an enclosing let(rec), which in turn gives
1277 -- the strictness analyser more chance.
1281 binds' = fltBind bind
1282 n_extras = sum (map no_of_binds binds') - no_of_binds bind
1284 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1285 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1287 -- fltBind guarantees not to return leaky floats
1288 -- and all the binders of the floats have had their demand-info zapped
1289 fltBind (NonRec bndr rhs)
1290 = binds ++ [NonRec bndr rhs']
1292 (binds, rhs') = fltRhs rhs
1297 pairs' = concat [ let
1298 (binds, rhs') = fltRhs rhs
1300 foldr get_pairs [(bndr, rhs')] binds
1301 | (bndr, rhs) <- pairs
1304 get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest
1305 get_pairs (Rec pairs) rest = pairs ++ rest
1307 -- fltRhs has same invariant as fltBind
1309 | (always_float_let_from_let ||
1310 floatExposesHNF True False False rhs)
1317 -- fltExpr has same invariant as fltBind
1318 fltExpr (Let bind body)
1319 | not top_level || binds_wont_leak
1320 -- fltExpr guarantees not to return leaky floats
1321 = (binds' ++ body_binds, body')
1323 binds_wont_leak = all leakFreeBind binds'
1324 (body_binds, body') = fltExpr body
1325 binds' = fltBind (un_demandify_bind bind)
1327 fltExpr expr = ([], expr)
1329 -- Crude but effective
1330 no_of_binds (NonRec _ _) = 1
1331 no_of_binds (Rec pairs) = length pairs
1333 leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
1334 leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
1336 leakFree (id,_) rhs = case getIdArity id of
1337 ArityAtLeast n | n > 0 -> True
1338 ArityExactly n | n > 0 -> True
1339 other -> whnfOrBottom (mkFormSummary rhs)
1343 %************************************************************************
1345 \subsection[Simplify-atoms]{Simplifying atoms}
1347 %************************************************************************
1350 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1352 simplArg env (LitArg lit) = returnEager (LitArg lit)
1353 simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
1354 returnEager (TyArg ty')
1355 simplArg env (VarArg id) = lookupId env id
1358 %************************************************************************
1360 \subsection[Simplify-quickies]{Some local help functions}
1362 %************************************************************************
1366 -- un_demandify_bind switches off the willBeDemanded Info field
1367 -- for bindings floated out of a non-demanded let
1368 un_demandify_bind (NonRec binder rhs)
1369 = NonRec (un_demandify_bndr binder) rhs
1370 un_demandify_bind (Rec pairs)
1371 = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
1373 un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1375 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1376 is_cheap_prim_app other = False
1378 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1379 computeResultType env expr_ty orig_args
1380 = simplTy env expr_ty `appEager` \ expr_ty' ->
1383 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1384 go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
1385 Just (_, res_ty) -> go res_ty args
1387 pprPanic "computeResultType" (vcat [
1393 go expr_ty' orig_args
1396 var `withArity` UnknownArity = var
1397 var `withArity` arity = var `addIdArity` arity
1399 is_atomic (Var v) = True
1400 is_atomic (Lit l) = not (isNoRepLit l)
1401 is_atomic other = False