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, idWantsToBeINLINEd, idMustNotBeINLINEd, addIdArity, getIdArity,
28 getIdDemandInfo, addIdDemandInfo,
29 GenId{-instance NamedThing-}
31 import Name ( isExported )
32 import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
33 atLeastArity, unknownArity )
34 import Literal ( isNoRepLit )
35 import Maybes ( maybeToBool )
36 import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} )
37 #if __GLASGOW_HASKELL__ <= 30
38 import PprCore ( GenCoreArg, GenCoreExpr )
40 import TyVar ( GenTyVar {- instance Eq -} )
41 import Pretty --( ($$) )
42 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
43 import SimplCase ( simplCase, bindLargeRhs )
46 import SimplVar ( completeVar )
47 import Unique ( Unique )
49 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys,
50 splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy
52 import TysWiredIn ( realWorldStateTy )
53 import Outputable ( PprStyle(..), Outputable(..) )
54 import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
55 isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
58 The controlling flags, and what they do
59 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
63 -fsimplify = run the simplifier
64 -ffloat-inwards = runs the float lets inwards pass
65 -ffloat = runs the full laziness pass
66 (ToDo: rename to -ffull-laziness)
67 -fupdate-analysis = runs update analyser
68 -fstrictness = runs strictness analyser
69 -fsaturate-apps = saturates applications (eta expansion)
73 -ffloat-past-lambda = OK to do full laziness.
74 (ToDo: remove, as the full laziness pass is
75 useless without this flag, therefore
76 it is unnecessary. Just -ffull-laziness
79 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
80 let is strict or if the floating will expose
83 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
84 is a primop that cannot fail [simplifier].
86 -fcode-duplication-ok = allows the previous option to work on cases with
87 multiple branches [simplifier].
89 -flet-to-case = does let-to-case transformation [simplifier].
91 -fcase-of-case = does case of case transformation [simplifier].
93 -fpedantic-bottoms = does not allow:
94 case x of y -> e ===> e[x/y]
95 (which may turn bottom into non-bottom)
101 Inlining is one of the delicate aspects of the simplifier. By
102 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
103 the RHS of x's definition. Thus
105 let x = e in ...x... ===> let x = e in ...e...
107 We have two mechanisms for inlining:
109 1. Unconditional. The occurrence analyser has pinned an (OneOcc
110 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
111 certainly safe to inline this variable, and to drop its binding''.
112 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
113 happy to be duplicating code...) When it encounters such a beast, the
114 simplifer binds the variable to its RHS (in the id_env) and continues.
115 It doesn't even look at the RHS at that stage. It also drops the
118 2. Conditional. In all other situations, the simplifer simplifies
119 the RHS anyway, and keeps the new binding. It also binds the new
120 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
122 Here, ``suitable'' might mean NoUnfolding (if the occurrence
123 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
124 the variable has an INLINE pragma on it). The idea is that anything
125 in the UnfoldEnv is safe to use, but also has an enclosing binding if
126 you decide not to use it.
130 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
133 At one time I thought it would be OK to put non-HNF unfoldings in for
134 variables which occur only once [if they got inlined at that
135 occurrence the RHS of the binding would become dead, so no duplication
136 would occur]. But consider:
139 f = \y -> ...y...y...y...
142 Now, it seems that @x@ appears only once, but even so it is NOT safe
143 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
144 duplicate the references to @x@.
146 Because of this, the "unconditional-inline" mechanism above is the
147 only way in which non-HNFs can get inlined.
152 When a variable has an INLINE pragma on it --- which includes wrappers
153 produced by the strictness analyser --- we treat it rather carefully.
155 For a start, we are careful not to substitute into its RHS, because
156 that might make it BIG, and the user said "inline exactly this", not
157 "inline whatever you get after inlining other stuff inside me". For
161 in {-# INLINE y #-} y = f 3
164 Here we don't want to substitute BIG for the (single) occurrence of f,
165 because then we'd duplicate BIG when we inline'd y. (Exception:
166 things in the UnfoldEnv with UnfoldAlways flags, which originated in
167 other INLINE pragmas.)
169 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
170 going into such an RHS.
172 What about imports? They don't really matter much because we only
173 inline relatively small things via imports.
175 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
176 INLINE pragma. We also do this for the RHSs of recursive decls,
177 before looking at the recursive decls. That way we achieve the effect
178 of inlining a wrapper in the body of its worker, in the case of a
179 mutually-recursive worker/wrapper split.
182 %************************************************************************
184 \subsection[Simplify-simplExpr]{The main function: simplExpr}
186 %************************************************************************
188 At the top level things are a little different.
190 * No cloning (not allowed for exported Ids, unnecessary for the others)
191 * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
194 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
196 -- Dead code is now discarded by the occurrence analyser,
198 simplTopBinds env binds
199 = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
200 simpl_top_binds env (concat binds_s)
202 simpl_top_binds env [] = returnSmpl []
204 simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
205 = --- No cloning necessary at top level
206 simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) ->
207 completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
208 simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
209 returnSmpl (binds1' ++ binds2')
211 simpl_top_binds env (Rec pairs : binds)
212 = -- No cloning necessary at top level, but we nevertheless
213 -- add the Ids to the environment. This makes sure that
214 -- info carried on the Id (such as arity info) gets propagated
217 -- This may seem optional, but I found an occasion when it Really matters.
218 -- Consider foo{n} = ...foo...
221 -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
222 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
223 -- thing: baz*{n} = ...baz...
225 -- Sure we could have made the indirection-shorting a bit cleverer, but
226 -- propagating pragma info is a Good Idea anyway.
228 env1 = extendIdEnvWithClones env binders ids
230 simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) ->
231 simpl_top_binds new_env binds `thenSmpl` \ binds' ->
232 returnSmpl (Rec bind' : binds')
234 binders = map fst pairs
235 ids = map fst binders
238 %************************************************************************
240 \subsection[Simplify-simplExpr]{The main function: simplExpr}
242 %************************************************************************
246 simplExpr :: SimplEnv
247 -> InExpr -> [OutArg]
248 -> OutType -- Type of (e args); i.e. type of overall result
252 The expression returned has the same meaning as the input expression
253 applied to the specified arguments.
258 Check if there's a macro-expansion, and if so rattle on. Otherwise do
259 the more sophisticated stuff.
262 simplExpr env (Var v) args result_ty
263 = case (runEager $ lookupId env v) of
264 LitArg lit -- A boring old literal
265 -> ASSERT( null args )
268 VarArg var -- More interesting! An id!
269 -> completeVar env var args result_ty
270 -- Either Id is in the local envt, or it's a global.
271 -- In either case we don't need to apply the type
272 -- environment to it.
279 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
281 simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
285 Primitive applications are simple.
286 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
288 NB: Prim expects an empty argument list! (Because it should be
289 saturated and not higher-order. ADR)
292 simplExpr env (Prim op prim_args) args result_ty
294 mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
295 simpl_op op `appEager` \ op' ->
296 completePrim env op' prim_args'
298 -- PrimOps just need any types in them renamed.
300 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
301 = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
302 simplTy env result_ty `appEager` \ result_ty' ->
303 returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
305 simpl_op other_op = returnEager other_op
308 Constructor applications
309 ~~~~~~~~~~~~~~~~~~~~~~~~
310 Nothing to try here. We only reuse constructors when they appear as the
311 rhs of a let binding (see completeLetBinding).
314 simplExpr env (Con con con_args) args result_ty
315 = ASSERT( null args )
316 mapEager (simplArg env) con_args `appEager` \ con_args' ->
317 returnSmpl (Con con con_args')
321 Applications are easy too:
322 ~~~~~~~~~~~~~~~~~~~~~~~~~~
323 Just stuff 'em in the arg stack
326 simplExpr env (App fun arg) args result_ty
327 = simplArg env arg `appEager` \ arg' ->
328 simplExpr env fun (arg' : args) result_ty
334 First the case when it's applied to an argument.
337 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
338 = -- ASSERT(not (isPrimType ty))
339 tick TyBetaReduction `thenSmpl_`
340 simplExpr (extendTyEnv env tyvar ty) body args result_ty
344 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
345 = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
347 new_ty = mkTyVarTy tyvar'
348 new_env = extendTyEnv env tyvar new_ty
349 new_result_ty = applyTy result_ty new_ty
351 simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
352 returnSmpl (Lam (TyBinder tyvar') body')
355 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
356 = panic "simplExpr:TyLam with non-TyArg"
364 There's a complication with lambdas that aren't saturated.
369 If we did nothing, x is used inside the \y, so would be marked
370 as dangerous to dup. But in the common case where the abstraction
371 is applied to two arguments this is over-pessimistic.
372 So instead we don't take account of the \y when dealing with x's usage;
373 instead, the simplifier is careful when partially applying lambdas.
376 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
377 = go 0 env expr orig_args
379 go n env (Lam (ValBinder binder) body) (val_arg : args)
380 | isValArg val_arg -- The lambda has an argument
381 = tick BetaReduction `thenSmpl_`
382 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
384 go n env expr@(Lam (ValBinder binder) body) args
385 -- The lambda is un-saturated, so we must zap the occurrence info
386 -- on the arguments we've already beta-reduced into the body of the lambda
387 = ASSERT( null args ) -- Value lambda must match value argument!
389 new_env = markDangerousOccs env (take n orig_args)
391 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
392 `thenSmpl` \ (expr', arity) ->
395 go n env non_val_lam_expr args -- The lambda had enough arguments
396 = simplExpr env non_val_lam_expr args result_ty
404 simplExpr env (Let bind body) args result_ty
405 = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
412 simplExpr env expr@(Case scrut alts) args result_ty
413 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
420 simplExpr env (Coerce coercion ty body) args result_ty
421 = simplCoerce env coercion ty body args result_ty
428 1) Eliminating nested sccs ...
429 We must be careful to maintain the scc counts ...
432 simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
433 | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
434 -- eliminate inner scc if no call counts and same cc as outer
435 = simplExpr env (SCC cc1 expr) args result_ty
437 | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
438 -- eliminate outer scc if no call counts associated with either ccs
439 = simplExpr env (SCC cc2 expr) args result_ty
442 2) Moving sccs inside lambdas ...
445 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
446 | not (isSccCountCostCentre cc)
447 -- move scc inside lambda only if no call counts
448 = simplExpr env (Lam binder (SCC cc body)) args result_ty
450 simplExpr env (SCC cc (Lam binder body)) args result_ty
451 -- always ok to move scc inside type/usage lambda
452 = simplExpr env (Lam binder (SCC cc body)) args result_ty
455 3) Eliminating dict sccs ...
458 simplExpr env (SCC cc expr) args result_ty
459 | squashableDictishCcExpr cc expr
460 -- eliminate dict cc if trivial dict expression
461 = simplExpr env expr args result_ty
464 4) Moving arguments inside the body of an scc ...
465 This moves the cost of doing the application inside the scc
466 (which may include the cost of extracting methods etc)
469 simplExpr env (SCC cost_centre body) args result_ty
471 new_env = setEnclosingCC env cost_centre
473 simplExpr new_env body args result_ty `thenSmpl` \ body' ->
474 returnSmpl (SCC cost_centre body')
477 %************************************************************************
479 \subsection{Simplify RHS of a Let/Letrec}
481 %************************************************************************
483 simplRhsExpr does arity-expansion. That is, given:
485 * a right hand side /\ tyvars -> \a1 ... an -> e
486 * the information (stored in BinderInfo) that the function will always
487 be applied to at least k arguments
489 it transforms the rhs to
491 /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
493 This is a Very Good Thing!
500 -> OutId -- The new binder (used only for its type)
501 -> SmplM (OutExpr, ArityInfo)
503 -- First a special case for variable right-hand sides
505 -- It's OK to simplify the RHS, but it's often a waste of time. Often
506 -- these v = w things persist because v is exported, and w is used
507 -- elsewhere. So if we're not careful we'll eta expand the rhs, only
508 -- to eta reduce it in competeNonRec.
510 -- If we leave the binding unchanged, we will certainly replace v by w at
511 -- every occurrence of v, which is good enough.
513 -- In fact, it's better to replace v by w than to inline w in v's rhs,
514 -- even if this is the only occurrence of w. Why? Because w might have
515 -- IdInfo (like strictness) that v doesn't.
517 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
518 = case (runEager $ lookupId env v) of
519 LitArg lit -> returnSmpl (Lit lit, ArityExactly 0)
520 VarArg v' -> returnSmpl (Var v', getIdArity v')
522 simplRhsExpr env binder@(id,occ_info) rhs new_id
523 = -- Deal with the big lambda part
524 ASSERT( null uvars ) -- For now
526 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
528 rhs_ty = idType new_id
529 new_tys = mkTyVarTys tyvars'
530 body_ty = foldl applyTy rhs_ty new_tys
531 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
533 -- Deal with the little lambda part
534 -- Note that we call simplLam even if there are no binders,
535 -- in case it can do arity expansion.
536 simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
538 -- Put on the big lambdas, trying to float out any bindings caught inside
539 mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
541 returnSmpl (rhs', arity)
543 rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
544 = switchOffInlining env1 -- See comments with switchOffInlining
548 -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
549 -- for the rhs of top level defs is "OST_CENTRE". Consider
551 -- g = \y -> let v = f y in scc "x" (v ...)
552 -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
553 -- want to inline "v" since its CC is dynamically determined.
555 current_cc = getEnclosingCC env
556 env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
559 (uvars, tyvars, body) = collectUsageAndTyBinders rhs
563 %************************************************************************
565 \subsection{Simplify a lambda abstraction}
567 %************************************************************************
569 Simplify (\binders -> body) trying eta expansion and reduction, given that
570 the abstraction will always be applied to at least min_no_of_args.
573 simplValLam env expr min_no_of_args expr_ty
574 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
576 exprIsTrivial expr || -- or it's a trivial RHS
577 -- No eta expansion for trivial RHSs
578 -- It's rather a Bad Thing to expand
581 -- g = \a b c -> f alpha beta a b c
583 -- The original RHS is "trivial" (exprIsTrivial), because it generates
584 -- no code (renames f to g). But the new RHS isn't.
586 null potential_extra_binder_tys || -- or ain't a function
587 no_of_extra_binders <= 0 -- or no extra binders needed
588 = cloneIds env binders `thenSmpl` \ binders' ->
590 new_env = extendIdEnvWithClones env binders binders'
592 simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
593 returnSmpl (mkValLam binders' body', final_arity)
595 | otherwise -- Eta expansion possible
596 = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
597 (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
598 pprTrace "simplValLam" (vcat [ppr PprDebug expr,
599 ppr PprDebug expr_ty,
600 ppr PprDebug binders,
601 int no_of_extra_binders,
602 ppr PprDebug potential_extra_binder_tys])
605 tick EtaExpansion `thenSmpl_`
606 cloneIds env binders `thenSmpl` \ binders' ->
608 new_env = extendIdEnvWithClones env binders binders'
610 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
611 simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
613 mkValLam (binders' ++ extra_binders') body',
618 (binders,body) = collectValBinders expr
619 no_of_binders = length binders
620 (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty
621 potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
622 pprTrace "simplValLam" (vcat [ppr PprDebug expr,
623 ppr PprDebug expr_ty,
624 ppr PprDebug binders])
626 drop no_of_binders arg_tys
627 body_ty = mkFunTys potential_extra_binder_tys res_ty
629 -- Note: it's possible that simplValLam will be applied to something
630 -- with a forall type. Eg when being applied to the rhs of
632 -- where wurble has a forall-type, but no big lambdas at the top.
633 -- We could be clever an insert new big lambdas, but we don't bother.
635 etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
636 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
637 final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
639 no_of_extra_binders = -- First, use the info about how many args it's
640 -- always applied to in its scope; but ignore this
641 -- info for thunks. To see why we ignore it for thunks,
642 -- consider let f = lookup env key in (f 1, f 2)
643 -- We'd better not eta expand f just because it is
645 (min_no_of_args - no_of_binders)
647 -- Next, try seeing if there's a lambda hidden inside
649 -- etaExpandCount can reuturn a huge number (like 10000!) if
650 -- it finds that the body is a call to "error"; hence
651 -- the use of "min" here.
653 (etaExpandCount body `min` length potential_extra_binder_tys)
655 -- Finally, see if it's a state transformer, in which
656 -- case we eta-expand on principle! This can waste work,
657 -- but usually doesn't
659 case potential_extra_binder_tys of
660 [ty] | ty `eqTy` realWorldStateTy -> 1
666 %************************************************************************
668 \subsection[Simplify-coerce]{Coerce expressions}
670 %************************************************************************
673 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
674 simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
675 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
677 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
678 simplCoerce env coercion ty (Let bind body) args result_ty
679 = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
682 simplCoerce env coercion ty expr args result_ty
683 = simplTy env ty `appEager` \ ty' ->
684 simplTy env expr_ty `appEager` \ expr_ty' ->
685 simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
686 returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
688 expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
690 -- Try cancellation; we do this "on the way up" because
691 -- I think that's where it'll bite best
692 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
693 mkCoerce coercion ty body = Coerce coercion ty body
697 %************************************************************************
699 \subsection[Simplify-let]{Let-expressions}
701 %************************************************************************
704 simplBind :: SimplEnv
706 -> (SimplEnv -> SmplM OutExpr)
711 When floating cases out of lets, remember this:
713 let x* = case e of alts
716 where x* is sure to be demanded or e is a cheap operation that cannot
717 fail, e.g. unboxed addition. Here we should be prepared to duplicate
718 <small expr>. A good example:
727 p1 -> foldr c n (build e1)
728 p2 -> foldr c n (build e2)
730 NEW: We use the same machinery that we use for case-of-case to
731 *always* do case floating from let, that is we let bind and abstract
732 the original let body, and let the occurrence analyser later decide
733 whether the new let should be inlined or not. The example above
737 let join_body x' = foldr c n x'
739 p1 -> let x* = build e1
741 p2 -> let x* = build e2
744 note that join_body is a let-no-escape.
745 In this particular example join_body will later be inlined,
746 achieving the same effect.
747 ToDo: check this is OK with andy
752 -- Dead code is now discarded by the occurrence analyser,
754 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
755 | idWantsToBeINLINEd id
756 = complete_bind env rhs -- Don't mess about with floating or let-to-case on
761 -- Try let-to-case; see notes below about let-to-case
762 simpl_bind env rhs | try_let_to_case &&
766 singleConstructorType rhs_ty
767 -- Only do let-to-case for single constructor types.
768 -- For other types we defer doing it until the tidy-up phase at
769 -- the end of simplification.
771 = tick Let2Case `thenSmpl_`
772 simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
773 (\env rhs -> complete_bind env rhs) body_ty
774 -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
775 -- NB: it's tidier to call complete_bind not simpl_bind, else
776 -- we nearly end up in a loop. Consider:
778 -- ==> case rhs of (p,q) -> let x=(p,q) in b
779 -- This effectively what the above simplCase call does.
780 -- Now, the inner let is a let-to-case target again! Actually, since
781 -- the RHS is in WHNF it won't happen, but it's a close thing!
784 simpl_bind env (Let bind rhs) | let_floating_ok
785 = tick LetFloatFromLet `thenSmpl_`
786 simplBind env (fix_up_demandedness will_be_demanded bind)
787 (\env -> simpl_bind env rhs) body_ty
789 -- Try case-from-let; this deals with a strict let of error too
790 simpl_bind env (Case scrut alts) | case_floating_ok scrut
791 = tick CaseFloatFromLet `thenSmpl_`
793 -- First, bind large let-body if necessary
794 if ok_to_dup || isSingleton (nonErrorRHSs alts)
796 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
798 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
800 body_c' = \env -> simplExpr env new_body [] body_ty
801 case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
803 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
804 returnSmpl (Let extra_binding case_expr)
806 -- None of the above; simplify rhs and tidy up
807 simpl_bind env rhs = complete_bind env rhs
809 complete_bind env rhs
810 = cloneId env binder `thenSmpl` \ new_id ->
811 simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
812 completeNonRec env binder
813 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
814 body_c new_env `thenSmpl` \ body' ->
815 returnSmpl (mkCoLetsAny binds body')
818 -- All this stuff is computed at the start of the simpl_bind loop
819 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
820 float_primops = switchIsSet env SimplOkToFloatPrimOps
821 ok_to_dup = switchIsSet env SimplOkToDupCode
822 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
823 try_let_to_case = switchIsSet env SimplLetToCase
824 no_float = switchIsSet env SimplNoLetFromStrictLet
826 demand_info = getIdDemandInfo id
827 will_be_demanded = willBeDemanded demand_info
830 form = mkFormSummary rhs
831 rhs_is_bot = case form of
834 rhs_is_whnf = case form of
839 float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
841 let_floating_ok = (will_be_demanded && not no_float) ||
842 always_float_let_from_let ||
845 case_floating_ok scrut = (will_be_demanded && not no_float) ||
846 (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
852 The booleans controlling floating have to be set with a little care.
853 Here's one performance bug I found:
855 let x = let y = let z = case a# +# 1 of {b# -> E1}
860 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
861 Before case_floating_ok included float_exposes_hnf, the case expression was floated
862 *one level per simplifier iteration* outwards. So it made th s
864 Let to case: two points
867 Point 1. We defer let-to-case for all data types except single-constructor
868 ones. Suppose we change
874 It can be the case that we find that b ultimately contains ...(case x of ..)....
875 and this is the only occurrence of x. Then if we've done let-to-case
876 we can't inline x, which is a real pain. On the other hand, we lose no
877 transformations by not doing this transformation, because the relevant
878 case-of-X transformations are also implemented by simpl_bind.
880 If x is a single-constructor type, then we go ahead anyway, giving
882 case e of (y,z) -> let x = (y,z) in b
884 because now we can squash case-on-x wherever they occur in b.
886 We do let-to-case on multi-constructor types in the tidy-up phase
887 (tidyCoreExpr) mainly so that the code generator doesn't need to
888 spot the demand-flag.
891 Point 2. It's important to try let-to-case before doing the
892 strict-let-of-case transformation, which happens in the next equation
895 let a*::Int = case v of {p1->e1; p2->e2}
898 (The * means that a is sure to be demanded.)
899 If we do case-floating first we get this:
903 p1-> let a*=e1 in k a
904 p2-> let a*=e2 in k a
906 Now watch what happens if we do let-to-case first:
908 case (case v of {p1->e1; p2->e2}) of
909 Int a# -> let a*=I# a# in b
911 let k = \a# -> let a*=I# a# in b
913 p1 -> case e1 of I# a# -> k a#
914 p1 -> case e2 of I# a# -> k a#
916 The latter is clearly better. (Remember the reboxing let-decl for a
917 is likely to go away, because after all b is strict in a.)
919 We do not do let to case for WHNFs, e.g.
925 as this is less efficient. but we don't mind doing let-to-case for
926 "bottom", as that will allow us to remove more dead code, if anything:
930 case error of x -> ...
934 Notice that let to case occurs only if x is used strictly in its body
941 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
942 on and it'll expose a HNF), and bang the whole resulting mess together
945 1. Any "macros" should be expanded. The main application of this
954 Here we would like the single call to g to be inlined.
956 We can spot this easily, because g will be tagged as having just one
957 occurrence. The "inlineUnconditionally" predicate is just what we want.
959 A worry: could this lead to non-termination? For example:
968 Here, f and g call each other (just once) and neither is used elsewhere.
971 * the occurrence analyser will drop any (sub)-group that isn't used at
974 * If the group is used outside itself (ie in the "in" part), then there
977 ** IMPORTANT: check that NewOccAnal has the property that a group of
978 bindings like the above has f&g dropped.! ***
981 2. We'd also like to pull out any top-level let(rec)s from the
985 f = let h = ... in \x -> ....h...f...h...
991 f = \x -> ....h...f...h...
995 But floating cases is less easy? (Don't for now; ToDo?)
998 3. We'd like to arrange that the RHSs "know" about members of the
999 group that are bound to constructors. For example:
1003 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
1004 /= a b = unpack tuple a, unpack tuple b, call f
1007 here, by knowing about d.Eq in f's rhs, one could get rid of
1008 the case (and break out the recursion completely).
1009 [This occurred with more aggressive inlining threshold (4),
1010 nofib/spectral/knights]
1013 1: we simplify constructor rhss first.
1014 2: we record the "known constructors" in the environment
1015 3: we simplify the other rhss, with the knowledge about the constructors
1020 simplBind env (Rec pairs) body_c body_ty
1021 = -- Do floating, if necessary
1022 floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
1024 binders = map fst pairs'
1026 cloneIds env binders `thenSmpl` \ ids' ->
1028 env_w_clones = extendIdEnvWithClones env binders ids'
1030 simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
1032 body_c new_env `thenSmpl` \ body' ->
1034 returnSmpl (Let (Rec pairs') body')
1038 -- The env passed to simplRecursiveGroup already has
1039 -- bindings that clone the variables of the group.
1040 simplRecursiveGroup env new_ids []
1041 = returnSmpl ([], env)
1043 simplRecursiveGroup env (new_id : new_ids) ((binder@(_, occ_info), rhs) : pairs)
1044 = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
1046 new_id' = new_id `withArity` arity
1048 -- ToDo: this next bit could usefully share code with completeNonRec
1051 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
1054 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1055 = extendIdEnvWithAtom env binder the_arg
1057 | otherwise -- Non-atomic
1058 = extendEnvGivenBinding env occ_info new_id new_rhs
1059 -- Don't eta if it doesn't eliminate the binding
1061 eta'd_rhs = etaCoreExpr new_rhs
1062 the_arg = case eta'd_rhs of
1066 simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
1067 returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
1071 @completeLet@ looks at the simplified post-floating RHS of the
1072 let-expression, and decides what to do. There's one interesting
1073 aspect to this, namely constructor reuse. Consider
1079 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1080 bit on the compiler technology, but in general I believe not. For
1081 example, here's some code from a real program:
1083 const.Int.max.wrk{-s2516-} =
1084 \ upk.s3297# upk.s3298# ->
1088 a.s3299 = I#! upk.s3297#
1090 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1091 _LT -> I#! upk.s3298#
1096 The a.s3299 really isn't doing much good. We'd be better off inlining
1097 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1099 So the current strategy is to inline all known-form constructors, and
1100 only do the reverse (turn a constructor application back into a
1101 variable) when we find a let-expression:
1105 ... (let y = C a1 .. an in ...) ...
1107 where it is always good to ditch the binding for y, and replace y by
1108 x. That's just what completeLetBinding does.
1113 The trouble is that we keep transforming
1121 and counting a couple of ticks for this non-transformation
1123 -- We want to ensure that all let-bound Coerces have
1124 -- atomic bodies, so they can freely be inlined.
1125 completeNonRec env binder new_id (Coerce coercion ty rhs)
1126 | not (is_atomic rhs)
1127 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1129 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1130 -- Dangerous occ because, like constructor args,
1131 -- it can be duplicated easily
1133 atomic_rhs = case runEager $ lookupId env1 inner_id of
1137 completeNonRec env1 binder new_id
1138 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1140 returnSmpl (env2, binds1 ++ binds2)
1144 -- Right hand sides that are constructors
1147 --- ...(let w = C same-args in ...)...
1148 -- Then use v instead of w. This may save
1149 -- re-constructing an existing constructor.
1150 completeNonRec env binder new_id rhs@(Con con con_args)
1151 | switchIsSet env SimplReuseCon &&
1152 maybeToBool maybe_existing_con &&
1153 not (isExported new_id) -- Don't bother for exported things
1154 -- because we won't be able to drop
1156 = tick ConReused `thenSmpl_`
1157 returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
1159 maybe_existing_con = lookForConstructor env con con_args
1160 Just it = maybe_existing_con
1164 -- Check for atomic right-hand sides.
1165 -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
1166 -- than it's worth. For a top-level binding a = b, where a is exported,
1167 -- we can't drop the binding, so we get repeated AtomicRhs ticks
1168 completeNonRec env binder@(id,occ_info) new_id new_rhs
1169 | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
1170 = returnSmpl (atomic_env , [NonRec new_id eta'd_rhs])
1172 | otherwise -- Non atomic rhs (don't eta after all)
1173 = returnSmpl (non_atomic_env , [NonRec new_id new_rhs])
1175 atomic_env = extendIdEnvWithAtom env binder the_arg
1177 non_atomic_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
1178 occ_info new_id new_rhs
1180 eta'd_rhs = etaCoreExpr new_rhs
1181 the_arg = case eta'd_rhs of
1188 floatBind :: SimplEnv
1189 -> Bool -- True <=> Top level
1191 -> SmplM [InBinding]
1193 floatBind env top_level bind
1199 = tickN LetFloatFromLet n_extras `thenSmpl_`
1200 -- It's important to increment the tick counts if we
1201 -- do any floating. A situation where this turns out
1202 -- to be important is this:
1203 -- Float in produces:
1204 -- letrec x = let y = Ey in Ex
1206 -- Now floating gives this:
1210 --- We now want to iterate once more in case Ey doesn't
1211 -- mention x, in which case the y binding can be pulled
1212 -- out as an enclosing let(rec), which in turn gives
1213 -- the strictness analyser more chance.
1217 (binds', _, n_extras) = fltBind bind
1219 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
1220 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1222 -- fltBind guarantees not to return leaky floats
1223 -- and all the binders of the floats have had their demand-info zapped
1224 fltBind (NonRec bndr rhs)
1225 = (binds ++ [NonRec (un_demandify bndr) rhs'],
1229 (binds, rhs') = fltRhs rhs
1234 binders `zip` rhss')],
1235 and (zipWith leakFree binders rhss'),
1240 (binders, rhss) = unzip pairs
1241 (binds_s, rhss') = mapAndUnzip fltRhs rhss
1242 extras = concat (map get_pairs (concat binds_s))
1244 get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
1245 get_pairs (Rec pairs) = pairs
1247 -- fltRhs has same invariant as fltBind
1249 | (always_float_let_from_let ||
1250 floatExposesHNF True False False rhs)
1257 -- fltExpr has same invariant as fltBind
1258 fltExpr (Let bind body)
1259 | not top_level || binds_wont_leak
1260 -- fltExpr guarantees not to return leaky floats
1261 = (binds' ++ body_binds, body')
1263 (body_binds, body') = fltExpr body
1264 (binds', binds_wont_leak, _) = fltBind bind
1266 fltExpr expr = ([], expr)
1268 -- Crude but effective
1269 leakFree (id,_) rhs = case getIdArity id of
1270 ArityAtLeast n | n > 0 -> True
1271 ArityExactly n | n > 0 -> True
1272 other -> whnfOrBottom rhs
1276 %************************************************************************
1278 \subsection[Simplify-atoms]{Simplifying atoms}
1280 %************************************************************************
1283 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1285 simplArg env (LitArg lit) = returnEager (LitArg lit)
1286 simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
1287 returnEager (TyArg ty')
1288 simplArg env (VarArg id) = lookupId env id
1291 %************************************************************************
1293 \subsection[Simplify-quickies]{Some local help functions}
1295 %************************************************************************
1299 -- fix_up_demandedness switches off the willBeDemanded Info field
1300 -- for bindings floated out of a non-demanded let
1301 fix_up_demandedness True {- Will be demanded -} bind
1302 = bind -- Simple; no change to demand info needed
1303 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1304 = NonRec (un_demandify binder) rhs
1305 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1306 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1308 un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1310 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1311 is_cheap_prim_app other = False
1313 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1314 computeResultType env expr_ty orig_args
1315 = simplTy env expr_ty `appEager` \ expr_ty' ->
1318 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1319 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1320 Just (_, res_ty) -> go res_ty args
1322 pprPanic "computeResultType" (vcat [
1323 ppr PprDebug (a:args),
1324 ppr PprDebug orig_args,
1325 ppr PprDebug expr_ty',
1328 go expr_ty' orig_args
1331 var `withArity` UnknownArity = var
1332 var `withArity` arity = var `addIdArity` arity
1334 is_atomic (Var v) = True
1335 is_atomic (Lit l) = not (isNoRepLit l)
1336 is_atomic other = False