2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[Simplify]{The main module of the simplifier}
7 #include "HsVersions.h"
9 module Simplify ( simplTopBinds, simplExpr, simplBind ) where
12 IMPORT_DELOOPER(SmplLoop) -- paranoia checking
13 IMPORT_1_3(List(partition))
16 import CmdLineOpts ( SimplifierSwitch(..) )
17 import ConFold ( completePrim )
18 import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, exprIsTrivial, whnfOrBottom, FormSummary(..) )
19 import CostCentre ( isSccCountCostCentre, cmpCostCentre )
21 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
22 unTagBinders, squashableDictishCcExpr
24 import Id ( idType, idWantsToBeINLINEd, idMustNotBeINLINEd, 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 #if __GLASGOW_HASKELL__ <= 30
35 import PprCore ( GenCoreArg, GenCoreExpr )
37 import TyVar ( GenTyVar {- instance Eq -} )
38 import Pretty --( ($$) )
39 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
40 import SimplCase ( simplCase, bindLargeRhs )
43 import SimplVar ( completeVar )
44 import Unique ( Unique )
46 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys,
47 splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy
49 import TysWiredIn ( realWorldStateTy )
50 import Outputable ( PprStyle(..), Outputable(..) )
51 import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
52 isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
55 The controlling flags, and what they do
56 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60 -fsimplify = run the simplifier
61 -ffloat-inwards = runs the float lets inwards pass
62 -ffloat = runs the full laziness pass
63 (ToDo: rename to -ffull-laziness)
64 -fupdate-analysis = runs update analyser
65 -fstrictness = runs strictness analyser
66 -fsaturate-apps = saturates applications (eta expansion)
70 -ffloat-past-lambda = OK to do full laziness.
71 (ToDo: remove, as the full laziness pass is
72 useless without this flag, therefore
73 it is unnecessary. Just -ffull-laziness
76 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
77 let is strict or if the floating will expose
80 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
81 is a primop that cannot fail [simplifier].
83 -fcode-duplication-ok = allows the previous option to work on cases with
84 multiple branches [simplifier].
86 -flet-to-case = does let-to-case transformation [simplifier].
88 -fcase-of-case = does case of case transformation [simplifier].
90 -fpedantic-bottoms = does not allow:
91 case x of y -> e ===> e[x/y]
92 (which may turn bottom into non-bottom)
98 Inlining is one of the delicate aspects of the simplifier. By
99 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
100 the RHS of x's definition. Thus
102 let x = e in ...x... ===> let x = e in ...e...
104 We have two mechanisms for inlining:
106 1. Unconditional. The occurrence analyser has pinned an (OneOcc
107 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
108 certainly safe to inline this variable, and to drop its binding''.
109 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
110 happy to be duplicating code...) When it encounters such a beast, the
111 simplifer binds the variable to its RHS (in the id_env) and continues.
112 It doesn't even look at the RHS at that stage. It also drops the
115 2. Conditional. In all other situations, the simplifer simplifies
116 the RHS anyway, and keeps the new binding. It also binds the new
117 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
119 Here, ``suitable'' might mean NoUnfolding (if the occurrence
120 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
121 the variable has an INLINE pragma on it). The idea is that anything
122 in the UnfoldEnv is safe to use, but also has an enclosing binding if
123 you decide not to use it.
127 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
130 At one time I thought it would be OK to put non-HNF unfoldings in for
131 variables which occur only once [if they got inlined at that
132 occurrence the RHS of the binding would become dead, so no duplication
133 would occur]. But consider:
136 f = \y -> ...y...y...y...
139 Now, it seems that @x@ appears only once, but even so it is NOT safe
140 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
141 duplicate the references to @x@.
143 Because of this, the "unconditional-inline" mechanism above is the
144 only way in which non-HNFs can get inlined.
149 When a variable has an INLINE pragma on it --- which includes wrappers
150 produced by the strictness analyser --- we treat it rather carefully.
152 For a start, we are careful not to substitute into its RHS, because
153 that might make it BIG, and the user said "inline exactly this", not
154 "inline whatever you get after inlining other stuff inside me". For
158 in {-# INLINE y #-} y = f 3
161 Here we don't want to substitute BIG for the (single) occurrence of f,
162 because then we'd duplicate BIG when we inline'd y. (Exception:
163 things in the UnfoldEnv with UnfoldAlways flags, which originated in
164 other INLINE pragmas.)
166 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
167 going into such an RHS.
169 What about imports? They don't really matter much because we only
170 inline relatively small things via imports.
172 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
173 INLINE pragma. We also do this for the RHSs of recursive decls,
174 before looking at the recursive decls. That way we achieve the effect
175 of inlining a wrapper in the body of its worker, in the case of a
176 mutually-recursive worker/wrapper split.
179 %************************************************************************
181 \subsection[Simplify-simplExpr]{The main function: simplExpr}
183 %************************************************************************
185 At the top level things are a little different.
187 * No cloning (not allowed for exported Ids, unnecessary for the others)
188 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
191 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
193 -- Dead code is now discarded by the occurrence analyser,
195 simplTopBinds env binds
196 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
197 simpl_top_binds env (concat binds_s)
199 simpl_top_binds env [] = returnSmpl []
201 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
202 = --- No cloning necessary at top level
203 simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) ->
204 completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
205 simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
206 returnSmpl (binds1' ++ binds2')
208 simpl_top_binds env (Rec pairs : binds)
209 = -- No cloning necessary at top level, but we nevertheless
210 -- add the Ids to the environment. This makes sure that
211 -- info carried on the Id (such as arity info) gets propagated
214 -- This may seem optional, but I found an occasion when it Really matters.
215 -- Consider foo{n} = ...foo...
218 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
219 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
220 -- thing: baz*{n} = ...baz...
222 -- Sure we could have made the indirection-shorting a bit cleverer, but
223 -- propagating pragma info is a Good Idea anyway.
225 env1 = extendIdEnvWithClones env binders ids
227 simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) ->
228 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
229 returnSmpl (Rec bind' : binds')
231 binders = map fst pairs
232 ids = map fst binders
235 %************************************************************************
237 \subsection[Simplify-simplExpr]{The main function: simplExpr}
239 %************************************************************************
243 simplExpr :: SimplEnv
244 -> InExpr -> [OutArg]
245 -> OutType -- Type of (e args); i.e. type of overall result
249 The expression returned has the same meaning as the input expression
250 applied to the specified arguments.
255 Check if there's a macro-expansion, and if so rattle on. Otherwise do
256 the more sophisticated stuff.
259 simplExpr env (Var v) args result_ty
260 = case (runEager $ lookupId env v) of
261 LitArg lit -- A boring old literal
262 -> ASSERT( null args )
265 VarArg var -- More interesting! An id!
266 -> completeVar env var args result_ty
267 -- Either Id is in the local envt, or it's a global.
268 -- In either case we don't need to apply the type
269 -- environment to it.
276 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
278 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
282 Primitive applications are simple.
283 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
285 NB: Prim expects an empty argument list! (Because it should be
286 saturated and not higher-order. ADR)
289 simplExpr env (Prim op prim_args) args result_ty
291 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
292 simpl_op op `appEager` \ op' ->
293 completePrim env op' prim_args'
295 -- PrimOps just need any types in them renamed.
297 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
298 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
299 simplTy env result_ty `appEager` \ result_ty' ->
300 returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
302 simpl_op other_op = returnEager other_op
305 Constructor applications
306 ~~~~~~~~~~~~~~~~~~~~~~~~
307 Nothing to try here. We only reuse constructors when they appear as the
308 rhs of a let binding (see completeLetBinding).
311 simplExpr env (Con con con_args) args result_ty
312 = ASSERT( null args )
313 mapEager (simplArg env) con_args `appEager` \ con_args' ->
314 returnSmpl (Con con con_args')
318 Applications are easy too:
319 ~~~~~~~~~~~~~~~~~~~~~~~~~~
320 Just stuff 'em in the arg stack
323 simplExpr env (App fun arg) args result_ty
324 = simplArg env arg `appEager` \ arg' ->
325 simplExpr env fun (arg' : args) result_ty
331 First the case when it's applied to an argument.
334 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
335 = -- ASSERT(not (isPrimType ty))
336 tick TyBetaReduction `thenSmpl_`
337 simplExpr (extendTyEnv env tyvar ty) body args result_ty
341 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
342 = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
344 new_ty = mkTyVarTy tyvar'
345 new_env = extendTyEnv env tyvar new_ty
346 new_result_ty = applyTy result_ty new_ty
348 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
349 returnSmpl (Lam (TyBinder tyvar') body')
352 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
353 = panic "simplExpr:TyLam with non-TyArg"
361 There's a complication with lambdas that aren't saturated.
366 If we did nothing, x is used inside the \y, so would be marked
367 as dangerous to dup. But in the common case where the abstraction
368 is applied to two arguments this is over-pessimistic.
369 So instead we don't take account of the \y when dealing with x's usage;
370 instead, the simplifier is careful when partially applying lambdas.
373 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
374 = go 0 env expr orig_args
376 go n env (Lam (ValBinder binder) body) (val_arg : args)
377 | isValArg val_arg -- The lambda has an argument
378 = tick BetaReduction `thenSmpl_`
379 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
381 go n env expr@(Lam (ValBinder binder) body) args
382 -- The lambda is un-saturated, so we must zap the occurrence info
383 -- on the arguments we've already beta-reduced into the body of the lambda
384 = ASSERT( null args ) -- Value lambda must match value argument!
386 new_env = markDangerousOccs env (take n orig_args)
388 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
389 `thenSmpl` \ (expr', arity) ->
392 go n env non_val_lam_expr args -- The lambda had enough arguments
393 = simplExpr env non_val_lam_expr args result_ty
401 simplExpr env (Let bind body) args result_ty
402 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
409 simplExpr env expr@(Case scrut alts) args result_ty
410 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
417 simplExpr env (Coerce coercion ty body) args result_ty
418 = simplCoerce env coercion ty body args result_ty
425 1) Eliminating nested sccs ...
426 We must be careful to maintain the scc counts ...
429 simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
430 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
431 -- eliminate inner scc if no call counts and same cc as outer
432 = simplExpr env (SCC cc1 expr) args result_ty
434 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
435 -- eliminate outer scc if no call counts associated with either ccs
436 = simplExpr env (SCC cc2 expr) args result_ty
439 2) Moving sccs inside lambdas ...
442 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
443 | not (isSccCountCostCentre cc)
444 -- move scc inside lambda only if no call counts
445 = simplExpr env (Lam binder (SCC cc body)) args result_ty
447 simplExpr env (SCC cc (Lam binder body)) args result_ty
448 -- always ok to move scc inside type/usage lambda
449 = simplExpr env (Lam binder (SCC cc body)) args result_ty
452 3) Eliminating dict sccs ...
455 simplExpr env (SCC cc expr) args result_ty
456 | squashableDictishCcExpr cc expr
457 -- eliminate dict cc if trivial dict expression
458 = simplExpr env expr args result_ty
461 4) Moving arguments inside the body of an scc ...
462 This moves the cost of doing the application inside the scc
463 (which may include the cost of extracting methods etc)
466 simplExpr env (SCC cost_centre body) args result_ty
468 new_env = setEnclosingCC env cost_centre
470 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
471 returnSmpl (SCC cost_centre body')
474 %************************************************************************
476 \subsection{Simplify RHS of a Let/Letrec}
478 %************************************************************************
480 simplRhsExpr does arity-expansion. That is, given:
482 * a right hand side /\ tyvars -> \a1 ... an -> e
483 * the information (stored in BinderInfo) that the function will always
484 be applied to at least k arguments
486 it transforms the rhs to
488 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
490 This is a Very Good Thing!
497 -> OutId -- The new binder (used only for its type)
498 -> SmplM (OutExpr, ArityInfo)
500 -- First a special case for variable right-hand sides
502 -- It's OK to simplify the RHS, but it's often a waste of time. Often
503 -- these v = w things persist because v is exported, and w is used
504 -- elsewhere. So if we're not careful we'll eta expand the rhs, only
505 -- to eta reduce it in competeNonRec.
507 -- If we leave the binding unchanged, we will certainly replace v by w at
508 -- every occurrence of v, which is good enough.
510 -- In fact, it's better to replace v by w than to inline w in v's rhs,
511 -- even if this is the only occurrence of w. Why? Because w might have
512 -- IdInfo (like strictness) that v doesn't.
514 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
515 = case (runEager $ lookupId env v) of
516 LitArg lit -> returnSmpl (Lit lit, ArityExactly 0)
517 VarArg v' -> returnSmpl (Var v', getIdArity v')
519 simplRhsExpr env binder@(id,occ_info) rhs new_id
520 = -- Deal with the big lambda part
521 ASSERT( null uvars ) -- For now
523 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
525 rhs_ty = idType new_id
526 new_tys = mkTyVarTys tyvars'
527 body_ty = foldl applyTy rhs_ty new_tys
528 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
530 -- Deal with the little lambda part
531 -- Note that we call simplLam even if there are no binders,
532 -- in case it can do arity expansion.
533 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
535 -- Put on the big lambdas, trying to float out any bindings caught inside
536 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
538 returnSmpl (rhs', arity)
540 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
541 = switchOffInlining env -- See comments with switchOffInlining
546 (uvars, tyvars, body) = collectUsageAndTyBinders rhs
550 %************************************************************************
552 \subsection{Simplify a lambda abstraction}
554 %************************************************************************
556 Simplify (\binders -> body) trying eta expansion and reduction, given that
557 the abstraction will always be applied to at least min_no_of_args.
560 simplValLam env expr min_no_of_args expr_ty
561 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
563 exprIsTrivial expr || -- or it's a trivial RHS
564 -- No eta expansion for trivial RHSs
565 -- It's rather a Bad Thing to expand
568 -- g = \a b c -> f alpha beta a b c
570 -- The original RHS is "trivial" (exprIsTrivial), because it generates
571 -- no code (renames f to g). But the new RHS isn't.
573 null potential_extra_binder_tys || -- or ain't a function
574 no_of_extra_binders <= 0 -- or no extra binders needed
575 = cloneIds env binders `thenSmpl` \ binders' ->
577 new_env = extendIdEnvWithClones env binders binders'
579 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
580 returnSmpl (mkValLam binders' body', final_arity)
582 | otherwise -- Eta expansion possible
583 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
584 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
585 pprTrace "simplValLam" (vcat [ppr PprDebug expr,
586 ppr PprDebug expr_ty,
587 ppr PprDebug binders,
588 int no_of_extra_binders,
589 ppr PprDebug potential_extra_binder_tys])
592 tick EtaExpansion `thenSmpl_`
593 cloneIds env binders `thenSmpl` \ binders' ->
595 new_env = extendIdEnvWithClones env binders binders'
597 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
598 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
600 mkValLam (binders' ++ extra_binders') body',
605 (binders,body) = collectValBinders expr
606 no_of_binders = length binders
607 (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty
608 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
609 pprTrace "simplValLam" (vcat [ppr PprDebug expr,
610 ppr PprDebug expr_ty,
611 ppr PprDebug binders])
613 drop no_of_binders arg_tys
614 body_ty = mkFunTys potential_extra_binder_tys res_ty
616 -- Note: it's possible that simplValLam will be applied to something
617 -- with a forall type. Eg when being applied to the rhs of
619 -- where wurble has a forall-type, but no big lambdas at the top.
620 -- We could be clever an insert new big lambdas, but we don't bother.
622 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
623 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
624 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
626 no_of_extra_binders = -- First, use the info about how many args it's
627 -- always applied to in its scope; but ignore this
628 -- info for thunks. To see why we ignore it for thunks,
629 -- consider let f = lookup env key in (f 1, f 2)
630 -- We'd better not eta expand f just because it is
632 (min_no_of_args - no_of_binders)
634 -- Next, try seeing if there's a lambda hidden inside
636 -- etaExpandCount can reuturn a huge number (like 10000!) if
637 -- it finds that the body is a call to "error"; hence
638 -- the use of "min" here.
640 (etaExpandCount body `min` length potential_extra_binder_tys)
642 -- Finally, see if it's a state transformer, in which
643 -- case we eta-expand on principle! This can waste work,
644 -- but usually doesn't
646 case potential_extra_binder_tys of
647 [ty] | ty `eqTy` realWorldStateTy -> 1
653 %************************************************************************
655 \subsection[Simplify-coerce]{Coerce expressions}
657 %************************************************************************
660 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
661 simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
662 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
664 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
665 simplCoerce env coercion ty (Let bind body) args result_ty
666 = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
669 simplCoerce env coercion ty expr args result_ty
670 = simplTy env ty `appEager` \ ty' ->
671 simplTy env expr_ty `appEager` \ expr_ty' ->
672 simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
673 returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
675 expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
677 -- Try cancellation; we do this "on the way up" because
678 -- I think that's where it'll bite best
679 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
680 mkCoerce coercion ty body = Coerce coercion ty body
684 %************************************************************************
686 \subsection[Simplify-let]{Let-expressions}
688 %************************************************************************
691 simplBind :: SimplEnv
693 -> (SimplEnv -> SmplM OutExpr)
698 When floating cases out of lets, remember this:
700 let x* = case e of alts
703 where x* is sure to be demanded or e is a cheap operation that cannot
704 fail, e.g. unboxed addition. Here we should be prepared to duplicate
705 <small expr>. A good example:
714 p1 -> foldr c n (build e1)
715 p2 -> foldr c n (build e2)
717 NEW: We use the same machinery that we use for case-of-case to
718 *always* do case floating from let, that is we let bind and abstract
719 the original let body, and let the occurrence analyser later decide
720 whether the new let should be inlined or not. The example above
724 let join_body x' = foldr c n x'
726 p1 -> let x* = build e1
728 p2 -> let x* = build e2
731 note that join_body is a let-no-escape.
732 In this particular example join_body will later be inlined,
733 achieving the same effect.
734 ToDo: check this is OK with andy
739 -- Dead code is now discarded by the occurrence analyser,
741 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
742 | idWantsToBeINLINEd id
743 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
748 -- Try for strict let of error
749 simpl_bind env rhs | will_be_demanded && maybeToBool maybe_error_app
750 = returnSmpl retyped_error_app
752 maybe_error_app = maybeErrorApp rhs (Just body_ty)
753 Just retyped_error_app = maybe_error_app
755 -- Try let-to-case; see notes below about let-to-case
756 simpl_bind env rhs | will_be_demanded &&
758 singleConstructorType rhs_ty &&
759 -- Only do let-to-case for single constructor types.
760 -- For other types we defer doing it until the tidy-up phase at
761 -- the end of simplification.
762 not rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
763 = tick Let2Case `thenSmpl_`
764 mkIdentityAlts rhs_ty demand_info `thenSmpl` \ id_alts ->
765 simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty
766 -- NB: it's tidier to call complete_bind not simpl_bind, else
767 -- we nearly end up in a loop. Consider:
769 -- ==> case rhs of (p,q) -> let x=(p,q) in b
770 -- This effectively what the above simplCase call does.
771 -- Now, the inner let is a let-to-case target again! Actually, since
772 -- the RHS is in WHNF it won't happen, but it's a close thing!
775 simpl_bind env (Let bind rhs) | let_floating_ok
776 = tick LetFloatFromLet `thenSmpl_`
777 simplBind env (fix_up_demandedness will_be_demanded bind)
778 (\env -> simpl_bind env rhs) body_ty
780 -- Try case-from-let; this deals with a strict let of error too
781 simpl_bind env (Case scrut alts) | case_floating_ok scrut
782 = tick CaseFloatFromLet `thenSmpl_`
784 -- First, bind large let-body if necessary
785 if ok_to_dup || isSingleton (nonErrorRHSs alts)
787 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
789 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
791 body_c' = \env -> simplExpr env new_body [] body_ty
792 case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
794 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
795 returnSmpl (Let extra_binding case_expr)
797 -- None of the above; simplify rhs and tidy up
798 simpl_bind env rhs = complete_bind env rhs
800 complete_bind env rhs
801 = cloneId env binder `thenSmpl` \ new_id ->
802 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
803 completeNonRec env binder
804 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
805 body_c new_env `thenSmpl` \ body' ->
806 returnSmpl (mkCoLetsAny binds body')
809 -- All this stuff is computed at the start of the simpl_bind loop
810 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
811 float_primops = switchIsSet env SimplOkToFloatPrimOps
812 ok_to_dup = switchIsSet env SimplOkToDupCode
813 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
814 try_let_to_case = switchIsSet env SimplLetToCase
815 no_float = switchIsSet env SimplNoLetFromStrictLet
817 demand_info = getIdDemandInfo id
818 will_be_demanded = willBeDemanded demand_info
821 form = mkFormSummary rhs
822 rhs_is_bot = case form of
825 rhs_is_whnf = case form of
830 float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
832 let_floating_ok = (will_be_demanded && not no_float) ||
833 always_float_let_from_let ||
836 case_floating_ok scrut = (will_be_demanded && not no_float) ||
837 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
843 The booleans controlling floating have to be set with a little care.
844 Here's one performance bug I found:
846 let x = let y = let z = case a# +# 1 of {b# -> E1}
851 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
852 Before case_floating_ok included float_exposes_hnf, the case expression was floated
853 *one level per simplifier iteration* outwards. So it made th s
855 Let to case: two points
858 Point 1. We defer let-to-case for all data types except single-constructor
859 ones. Suppose we change
865 It can be the case that we find that b ultimately contains ...(case x of ..)....
866 and this is the only occurrence of x. Then if we've done let-to-case
867 we can't inline x, which is a real pain. On the other hand, we lose no
868 transformations by not doing this transformation, because the relevant
869 case-of-X transformations are also implemented by simpl_bind.
871 If x is a single-constructor type, then we go ahead anyway, giving
873 case e of (y,z) -> let x = (y,z) in b
875 because now we can squash case-on-x wherever they occur in b.
877 We do let-to-case on multi-constructor types in the tidy-up phase
878 (tidyCoreExpr) mainly so that the code generator doesn't need to
879 spot the demand-flag.
882 Point 2. It's important to try let-to-case before doing the
883 strict-let-of-case transformation, which happens in the next equation
886 let a*::Int = case v of {p1->e1; p2->e2}
889 (The * means that a is sure to be demanded.)
890 If we do case-floating first we get this:
894 p1-> let a*=e1 in k a
895 p2-> let a*=e2 in k a
897 Now watch what happens if we do let-to-case first:
899 case (case v of {p1->e1; p2->e2}) of
900 Int a# -> let a*=I# a# in b
902 let k = \a# -> let a*=I# a# in b
904 p1 -> case e1 of I# a# -> k a#
905 p1 -> case e2 of I# a# -> k a#
907 The latter is clearly better. (Remember the reboxing let-decl for a
908 is likely to go away, because after all b is strict in a.)
910 We do not do let to case for WHNFs, e.g.
916 as this is less efficient. but we don't mind doing let-to-case for
917 "bottom", as that will allow us to remove more dead code, if anything:
921 case error of x -> ...
925 Notice that let to case occurs only if x is used strictly in its body
932 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
933 on and it'll expose a HNF), and bang the whole resulting mess together
936 1. Any "macros" should be expanded. The main application of this
945 Here we would like the single call to g to be inlined.
947 We can spot this easily, because g will be tagged as having just one
948 occurrence. The "inlineUnconditionally" predicate is just what we want.
950 A worry: could this lead to non-termination? For example:
959 Here, f and g call each other (just once) and neither is used elsewhere.
962 * the occurrence analyser will drop any (sub)-group that isn't used at
965 * If the group is used outside itself (ie in the "in" part), then there
968 ** IMPORTANT: check that NewOccAnal has the property that a group of
969 bindings like the above has f&g dropped.! ***
972 2. We'd also like to pull out any top-level let(rec)s from the
976 f = let h = ... in \x -> ....h...f...h...
982 f = \x -> ....h...f...h...
986 But floating cases is less easy? (Don't for now; ToDo?)
989 3. We'd like to arrange that the RHSs "know" about members of the
990 group that are bound to constructors. For example:
994 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
995 /= a b = unpack tuple a, unpack tuple b, call f
998 here, by knowing about d.Eq in f's rhs, one could get rid of
999 the case (and break out the recursion completely).
1000 [This occurred with more aggressive inlining threshold (4),
1001 nofib/spectral/knights]
1004 1: we simplify constructor rhss first.
1005 2: we record the "known constructors" in the environment
1006 3: we simplify the other rhss, with the knowledge about the constructors
1011 simplBind env (Rec pairs) body_c body_ty
1012 = -- Do floating, if necessary
1013 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1015 binders = map fst pairs'
1017 cloneIds env binders `thenSmpl` \ ids' ->
1019 env_w_clones = extendIdEnvWithClones env binders ids'
1021 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1023 body_c new_env `thenSmpl` \ body' ->
1025 returnSmpl (Let (Rec pairs') body')
1029 -- The env passed to simplRecursiveGroup already has
1030 -- bindings that clone the variables of the group.
1031 simplRecursiveGroup env new_ids []
1032 = returnSmpl ([], env)
1034 simplRecursiveGroup env (new_id : new_ids) ((binder@(_, occ_info), rhs) : pairs)
1035 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1037 new_id' = new_id `withArity` arity
1039 -- ToDo: this next bit could usefully share code with completeNonRec
1042 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1045 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1046 = extendIdEnvWithAtom env binder the_arg
1048 | otherwise -- Non-atomic
1049 = extendEnvGivenBinding env occ_info new_id new_rhs
1050 -- Don't eta if it doesn't eliminate the binding
1052 eta'd_rhs = etaCoreExpr new_rhs
1053 the_arg = case eta'd_rhs of
1057 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1058 returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
1062 @completeLet@ looks at the simplified post-floating RHS of the
1063 let-expression, and decides what to do. There's one interesting
1064 aspect to this, namely constructor reuse. Consider
1070 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1071 bit on the compiler technology, but in general I believe not. For
1072 example, here's some code from a real program:
1074 const.Int.max.wrk{-s2516-} =
1075 \ upk.s3297# upk.s3298# ->
1079 a.s3299 = I#! upk.s3297#
1081 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1082 _LT -> I#! upk.s3298#
1087 The a.s3299 really isn't doing much good. We'd be better off inlining
1088 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1090 So the current strategy is to inline all known-form constructors, and
1091 only do the reverse (turn a constructor application back into a
1092 variable) when we find a let-expression:
1096 ... (let y = C a1 .. an in ...) ...
1098 where it is always good to ditch the binding for y, and replace y by
1099 x. That's just what completeLetBinding does.
1103 -- We want to ensure that all let-bound Coerces have
1104 -- atomic bodies, so they can freely be inlined.
1105 completeNonRec env binder new_id (Coerce coercion ty rhs)
1106 | not (is_atomic rhs)
1107 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1109 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1110 -- Dangerous occ because, like constructor args,
1111 -- it can be duplicated easily
1113 atomic_rhs = case runEager $ lookupId env1 inner_id of
1117 completeNonRec env1 binder new_id
1118 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1120 returnSmpl (env2, binds1 ++ binds2)
1122 -- Right hand sides that are constructors
1125 --- ...(let w = C same-args in ...)...
1126 -- Then use v instead of w. This may save
1127 -- re-constructing an existing constructor.
1128 completeNonRec env binder new_id rhs@(Con con con_args)
1129 | switchIsSet env SimplReuseCon &&
1130 maybeToBool maybe_existing_con &&
1131 not (isExported new_id) -- Don't bother for exported things
1132 -- because we won't be able to drop
1134 = tick ConReused `thenSmpl_`
1135 returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
1137 maybe_existing_con = lookForConstructor env con con_args
1138 Just it = maybe_existing_con
1142 -- Check for atomic right-hand sides.
1143 -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
1144 -- than it's worth. For a top-level binding a = b, where a is exported,
1145 -- we can't drop the binding, so we get repeated AtomicRhs ticks
1146 completeNonRec env binder@(id,occ_info) new_id new_rhs
1147 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1148 = returnSmpl (atomic_env , [NonRec new_id eta'd_rhs])
1150 | otherwise -- Non atomic rhs (don't eta after all)
1151 = returnSmpl (non_atomic_env , [NonRec new_id new_rhs])
1153 atomic_env = extendIdEnvWithAtom env binder the_arg
1155 non_atomic_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
1156 occ_info new_id new_rhs
1158 eta'd_rhs = etaCoreExpr new_rhs
1159 the_arg = case eta'd_rhs of
1166 floatBind :: SimplEnv
1167 -> Bool -- True <=> Top level
1169 -> SmplM [InBinding]
1171 floatBind env top_level bind
1177 = tickN LetFloatFromLet n_extras `thenSmpl_`
1178 -- It's important to increment the tick counts if we
1179 -- do any floating. A situation where this turns out
1180 -- to be important is this:
1181 -- Float in produces:
1182 -- letrec x = let y = Ey in Ex
1184 -- Now floating gives this:
1188 --- We now want to iterate once more in case Ey doesn't
1189 -- mention x, in which case the y binding can be pulled
1190 -- out as an enclosing let(rec), which in turn gives
1191 -- the strictness analyser more chance.
1195 (binds', _, n_extras) = fltBind bind
1197 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1198 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1200 -- fltBind guarantees not to return leaky floats
1201 -- and all the binders of the floats have had their demand-info zapped
1202 fltBind (NonRec bndr rhs)
1203 = (binds ++ [NonRec (un_demandify bndr) rhs'],
1207 (binds, rhs') = fltRhs rhs
1212 binders `zip` rhss')],
1213 and (zipWith leakFree binders rhss'),
1218 (binders, rhss) = unzip pairs
1219 (binds_s, rhss') = mapAndUnzip fltRhs rhss
1220 extras = concat (map get_pairs (concat binds_s))
1222 get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
1223 get_pairs (Rec pairs) = pairs
1225 -- fltRhs has same invariant as fltBind
1227 | (always_float_let_from_let ||
1228 floatExposesHNF True False False rhs)
1235 -- fltExpr has same invariant as fltBind
1236 fltExpr (Let bind body)
1237 | not top_level || binds_wont_leak
1238 -- fltExpr guarantees not to return leaky floats
1239 = (binds' ++ body_binds, body')
1241 (body_binds, body') = fltExpr body
1242 (binds', binds_wont_leak, _) = fltBind bind
1244 fltExpr expr = ([], expr)
1246 -- Crude but effective
1247 leakFree (id,_) rhs = case getIdArity id of
1248 ArityAtLeast n | n > 0 -> True
1249 ArityExactly n | n > 0 -> True
1250 other -> whnfOrBottom rhs
1254 %************************************************************************
1256 \subsection[Simplify-atoms]{Simplifying atoms}
1258 %************************************************************************
1261 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1263 simplArg env (LitArg lit) = returnEager (LitArg lit)
1264 simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
1265 returnEager (TyArg ty')
1266 simplArg env (VarArg id) = lookupId env id
1269 %************************************************************************
1271 \subsection[Simplify-quickies]{Some local help functions}
1273 %************************************************************************
1277 -- fix_up_demandedness switches off the willBeDemanded Info field
1278 -- for bindings floated out of a non-demanded let
1279 fix_up_demandedness True {- Will be demanded -} bind
1280 = bind -- Simple; no change to demand info needed
1281 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1282 = NonRec (un_demandify binder) rhs
1283 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1284 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1286 un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1288 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1289 is_cheap_prim_app other = False
1291 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1292 computeResultType env expr_ty orig_args
1293 = simplTy env expr_ty `appEager` \ expr_ty' ->
1296 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1297 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1298 Just (_, res_ty) -> go res_ty args
1300 pprPanic "computeResultType" (vcat [
1301 ppr PprDebug (a:args),
1302 ppr PprDebug orig_args,
1303 ppr PprDebug expr_ty',
1306 go expr_ty' orig_args
1309 var `withArity` UnknownArity = var
1310 var `withArity` arity = var `addIdArity` arity
1312 is_atomic (Var v) = True
1313 is_atomic (Lit l) = not (isNoRepLit l)
1314 is_atomic other = False