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, FormSummary(..) )
19 import CostCentre ( isSccCountCostCentre, cmpCostCentre )
21 import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
22 unTagBinders, squashableDictishCcExpr
24 import Id ( idType, idWantsToBeINLINEd, addIdArity,
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 Name ( isExported )
34 import PprStyle ( PprStyle(..) )
35 import PprType ( GenType{-instance Outputable-} )
36 import Pretty ( ppAbove )
37 import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
38 import SimplCase ( simplCase, bindLargeRhs )
41 import SimplVar ( completeVar )
43 import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
44 splitFunTy, getFunTy_maybe, eqTy
46 import TysWiredIn ( realWorldStateTy )
47 import Util ( isSingleton, zipEqual, zipWithEqual, panic, pprPanic, assertPanic )
50 The controlling flags, and what they do
51 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
55 -fsimplify = run the simplifier
56 -ffloat-inwards = runs the float lets inwards pass
57 -ffloat = runs the full laziness pass
58 (ToDo: rename to -ffull-laziness)
59 -fupdate-analysis = runs update analyser
60 -fstrictness = runs strictness analyser
61 -fsaturate-apps = saturates applications (eta expansion)
65 -ffloat-past-lambda = OK to do full laziness.
66 (ToDo: remove, as the full laziness pass is
67 useless without this flag, therefore
68 it is unnecessary. Just -ffull-laziness
71 -ffloat-lets-ok = OK to float lets out of lets if the enclosing
72 let is strict or if the floating will expose
75 -ffloat-primops-ok = OK to float out of lets cases whose scrutinee
76 is a primop that cannot fail [simplifier].
78 -fcode-duplication-ok = allows the previous option to work on cases with
79 multiple branches [simplifier].
81 -flet-to-case = does let-to-case transformation [simplifier].
83 -fcase-of-case = does case of case transformation [simplifier].
85 -fpedantic-bottoms = does not allow:
86 case x of y -> e ===> e[x/y]
87 (which may turn bottom into non-bottom)
93 Inlining is one of the delicate aspects of the simplifier. By
94 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
95 the RHS of x's definition. Thus
97 let x = e in ...x... ===> let x = e in ...e...
99 We have two mechanisms for inlining:
101 1. Unconditional. The occurrence analyser has pinned an (OneOcc
102 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
103 certainly safe to inline this variable, and to drop its binding''.
104 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
105 happy to be duplicating code...) When it encounters such a beast, the
106 simplifer binds the variable to its RHS (in the id_env) and continues.
107 It doesn't even look at the RHS at that stage. It also drops the
110 2. Conditional. In all other situations, the simplifer simplifies
111 the RHS anyway, and keeps the new binding. It also binds the new
112 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
114 Here, ``suitable'' might mean NoUnfolding (if the occurrence
115 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
116 the variable has an INLINE pragma on it). The idea is that anything
117 in the UnfoldEnv is safe to use, but also has an enclosing binding if
118 you decide not to use it.
122 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
125 At one time I thought it would be OK to put non-HNF unfoldings in for
126 variables which occur only once [if they got inlined at that
127 occurrence the RHS of the binding would become dead, so no duplication
128 would occur]. But consider:
131 f = \y -> ...y...y...y...
134 Now, it seems that @x@ appears only once, but even so it is NOT safe
135 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
136 duplicate the references to @x@.
138 Because of this, the "unconditional-inline" mechanism above is the
139 only way in which non-HNFs can get inlined.
144 When a variable has an INLINE pragma on it --- which includes wrappers
145 produced by the strictness analyser --- we treat it rather carefully.
147 For a start, we are careful not to substitute into its RHS, because
148 that might make it BIG, and the user said "inline exactly this", not
149 "inline whatever you get after inlining other stuff inside me". For
153 in {-# INLINE y #-} y = f 3
156 Here we don't want to substitute BIG for the (single) occurrence of f,
157 because then we'd duplicate BIG when we inline'd y. (Exception:
158 things in the UnfoldEnv with UnfoldAlways flags, which originated in
159 other INLINE pragmas.)
161 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
162 going into such an RHS.
164 What about imports? They don't really matter much because we only
165 inline relatively small things via imports.
167 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
168 INLINE pragma. We also do this for the RHSs of recursive decls,
169 before looking at the recursive decls. That way we achieve the effect
170 of inlining a wrapper in the body of its worker, in the case of a
171 mutually-recursive worker/wrapper split.
174 %************************************************************************
176 \subsection[Simplify-simplExpr]{The main function: simplExpr}
178 %************************************************************************
180 At the top level things are a little different.
182 * No cloning (not allowed for exported Ids, unnecessary for the others)
184 * No floating. Case floating is obviously out. Let floating is
185 theoretically OK, but dangerous because of space leaks.
186 The long-distance let-floater lifts these lets.
189 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
191 simplTopBinds env [] = returnSmpl []
193 -- Dead code is now discarded by the occurrence analyser,
195 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
196 = -- No cloning necessary at top level
197 -- Process the binding
198 simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) ->
199 completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
201 -- Process the other bindings
202 simplTopBinds new_env binds `thenSmpl` \ binds2' ->
204 -- Glue together and return ...
205 returnSmpl (binds1' ++ binds2')
207 simplTopBinds env (Rec pairs : binds)
208 = simplRecursiveGroup env ids pairs `thenSmpl` \ (bind', new_env) ->
210 -- Process the other bindings
211 simplTopBinds new_env binds `thenSmpl` \ binds' ->
213 -- Glue together and return
214 returnSmpl (bind' : binds')
216 ids = [id | (binder@(id,_), rhs) <- pairs] -- No cloning necessary at top level
219 %************************************************************************
221 \subsection[Simplify-simplExpr]{The main function: simplExpr}
223 %************************************************************************
227 simplExpr :: SimplEnv
228 -> InExpr -> [OutArg]
232 The expression returned has the same meaning as the input expression
233 applied to the specified arguments.
238 Check if there's a macro-expansion, and if so rattle on. Otherwise do
239 the more sophisticated stuff.
242 simplExpr env (Var v) args
243 = case (lookupId env v) of
244 LitArg lit -- A boring old literal
245 -> ASSERT( null args )
248 VarArg var -- More interesting! An id!
249 -> completeVar env var args
250 -- Either Id is in the local envt, or it's a global.
251 -- In either case we don't need to apply the type
252 -- environment to it.
259 simplExpr env (Lit l) [] = returnSmpl (Lit l)
261 simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
265 Primitive applications are simple.
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
268 NB: Prim expects an empty argument list! (Because it should be
269 saturated and not higher-order. ADR)
272 simplExpr env (Prim op prim_args) args
275 prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
278 completePrim env op' prim_args'
280 -- PrimOps just need any types in them renamed.
282 simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
284 arg_tys' = map (simplTy env) arg_tys
285 result_ty' = simplTy env result_ty
287 CCallOp label is_asm may_gc arg_tys' result_ty'
289 simpl_op other_op = other_op
292 Constructor applications
293 ~~~~~~~~~~~~~~~~~~~~~~~~
294 Nothing to try here. We only reuse constructors when they appear as the
295 rhs of a let binding (see completeLetBinding).
298 simplExpr env (Con con con_args) args
299 = ASSERT( null args )
300 returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
304 Applications are easy too:
305 ~~~~~~~~~~~~~~~~~~~~~~~~~~
306 Just stuff 'em in the arg stack
309 simplExpr env (App fun arg) args
310 = simplExpr env fun (simplArg env arg : args)
316 We only eta-reduce a type lambda if all type arguments in the body can
317 be eta-reduced. This requires us to collect up all tyvar parameters so
318 we can pass them all to @mkTyLamTryingEta@.
321 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
322 = -- ASSERT(not (isPrimType ty))
323 tick TyBetaReduction `thenSmpl_`
324 simplExpr (extendTyEnv env tyvar ty) body args
326 simplExpr env tylam@(Lam (TyBinder tyvar) body) []
327 = do_tylambdas env [] tylam
329 do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
330 = -- Clone the type variable
331 cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
333 new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
335 do_tylambdas new_env (tyvar':tyvars') body
337 do_tylambdas env tyvars' body
338 = simplExpr env body [] `thenSmpl` \ body' ->
340 (if switchIsSet env SimplDoEtaReduction
341 then mkTyLamTryingEta
342 else mkTyLam) (reverse tyvars') body'
346 simplExpr env (Lam (TyBinder _) _) (_ : _)
347 = panic "simplExpr:TyLam with non-TyArg"
355 There's a complication with lambdas that aren't saturated.
360 If we did nothing, x is used inside the \y, so would be marked
361 as dangerous to dup. But in the common case where the abstraction
362 is applied to two arguments this is over-pessimistic.
363 So instead we don't take account of the \y when dealing with x's usage;
364 instead, the simplifier is careful when partially applying lambdas.
367 simplExpr env expr@(Lam (ValBinder binder) body) orig_args
368 = go 0 env expr orig_args
370 go n env (Lam (ValBinder binder) body) (val_arg : args)
371 | isValArg val_arg -- The lambda has an argument
372 = tick BetaReduction `thenSmpl_`
373 go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
375 go n env expr@(Lam (ValBinder binder) body) args
376 -- The lambda is un-saturated, so we must zap the occurrence info
377 -- on the arguments we've already beta-reduced into the body of the lambda
378 = ASSERT( null args ) -- Value lambda must match value argument!
380 new_env = markDangerousOccs env (take n orig_args)
382 simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
383 `thenSmpl` \ (expr', arity) ->
386 go n env non_val_lam_expr args -- The lambda had enough arguments
387 = simplExpr env non_val_lam_expr args
395 simplExpr env (Let bind body) args
396 = simplBind env bind (\env -> simplExpr env body args)
397 (computeResultType env body args)
404 simplExpr env expr@(Case scrut alts) args
405 = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
406 (computeResultType env expr args)
413 simplExpr env (Coerce coercion ty body) args
414 = simplCoerce env coercion ty body args
421 1) Eliminating nested sccs ...
422 We must be careful to maintain the scc counts ...
425 simplExpr env (SCC cc1 (SCC cc2 expr)) args
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
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
435 2) Moving sccs inside lambdas ...
438 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args
439 | not (isSccCountCostCentre cc)
440 -- move scc inside lambda only if no call counts
441 = simplExpr env (Lam binder (SCC cc body)) args
443 simplExpr env (SCC cc (Lam binder body)) args
444 -- always ok to move scc inside type/usage lambda
445 = simplExpr env (Lam binder (SCC cc body)) args
448 3) Eliminating dict sccs ...
451 simplExpr env (SCC cc expr) args
452 | squashableDictishCcExpr cc expr
453 -- eliminate dict cc if trivial dict expression
454 = simplExpr env expr args
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
464 new_env = setEnclosingCC env cost_centre
466 simplExpr new_env body args `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 -> SmplM (OutExpr, ArityInfo)
495 simplRhsExpr env binder@(id,occ_info) rhs
496 | dont_eta_expand rhs
497 = simplExpr rhs_env rhs [] `thenSmpl` \ rhs' ->
498 returnSmpl (rhs', unknownArity)
500 | otherwise -- Have a go at eta expansion
501 = -- Deal with the big lambda part
502 ASSERT( null uvars ) -- For now
504 mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
506 lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
508 -- Deal with the little lambda part
509 -- Note that we call simplLam even if there are no binders,
510 -- in case it can do arity expansion.
511 simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ (lambda', arity) ->
513 -- Put it back together
515 (if switchIsSet env SimplDoEtaReduction
516 then mkTyLamTryingEta
517 else mkTyLam) tyvars' lambda',
522 rhs_env | -- not (switchIsSet env IgnoreINLINEPragma) &&
523 -- No! Don't ever inline in a INLINE thing's rhs, because
524 -- doing so will inline a worker straight back into its wrapper!
525 idWantsToBeINLINEd id
526 = switchOffInlining env
530 -- Switch off all inlining in the RHS of things that have an INLINE pragma.
531 -- They are going to be inlined wherever they are used, and then all the
532 -- inlining will take effect. Meanwhile, there isn't
533 -- much point in doing anything to the as-yet-un-INLINEd rhs.
534 -- It's very important to switch off inlining! Consider:
536 -- let f = \pq -> BIG
538 -- let g = \y -> f y y
540 -- in ...g...g...g...g...g...
542 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
543 -- and thence copied multiple times when g is inlined.
545 -- Andy disagrees! Example:
546 -- all xs = foldr (&&) True xs
547 -- any p = all . map p {-# INLINE any #-}
549 -- Problem: any won't get deforested, and so if it's exported and
550 -- the importer doesn't use the inlining, (eg passes it as an arg)
551 -- then we won't get deforestation at all.
552 -- We havn't solved this problem yet!
554 (uvars, tyvars, body) = collectUsageAndTyBinders rhs
556 -- dont_eta_expand prevents eta expansion in silly situations.
557 -- For example, consider the defn
559 -- It would be silly to eta expand the "y", because it would just
560 -- get eta-reduced back to y. Furthermore, if this was a top level defn,
561 -- and x was exported, then the defn won't be eliminated, so this
562 -- silly expand/reduce cycle will happen every time, which makes the
564 -- The solution is to not even try eta expansion unless the rhs looks
566 dont_eta_expand (Lit _) = True
567 dont_eta_expand (Var _) = True
568 dont_eta_expand (Con _ _) = True
569 dont_eta_expand (App f a)
570 | notValArg a = dont_eta_expand f
571 dont_eta_expand (Lam x b)
572 | notValBinder x = dont_eta_expand b
573 dont_eta_expand _ = False
577 %************************************************************************
579 \subsection{Simplify a lambda abstraction}
581 %************************************************************************
583 Simplify (\binders -> body) trying eta expansion and reduction, given that
584 the abstraction will always be applied to at least min_no_of_args.
587 simplValLam env expr min_no_of_args
588 | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
590 -- We used to disable eta expansion for thunks, but I don't see why.
591 -- null binders || -- or it's a thunk
593 null potential_extra_binder_tys || -- or ain't a function
594 no_of_extra_binders <= 0 -- or no extra binders needed
595 = cloneIds env binders `thenSmpl` \ binders' ->
597 new_env = extendIdEnvWithClones env binders binders'
599 simplExpr new_env body [] `thenSmpl` \ body' ->
601 (if switchIsSet new_env SimplDoEtaReduction
602 then mkValLamTryingEta
603 else mkValLam) binders' body',
604 atLeastArity no_of_binders
607 | otherwise -- Eta expansion possible
608 = tick EtaExpansion `thenSmpl_`
609 cloneIds env binders `thenSmpl` \ binders' ->
611 new_env = extendIdEnvWithClones env binders binders'
613 newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
614 simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
616 (if switchIsSet new_env SimplDoEtaReduction
617 then mkValLamTryingEta
618 else mkValLam) (binders' ++ extra_binders') body',
619 atLeastArity (no_of_binders + no_of_extra_binders)
623 (binders,body) = collectValBinders expr
624 no_of_binders = length binders
625 (potential_extra_binder_tys, res_ty)
626 = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
627 -- Note: it's possible that simplValLam will be applied to something
628 -- with a forall type. Eg when being applied to the rhs of
630 -- where wurble has a forall-type, but no big lambdas at the top.
631 -- We could be clever an insert new big lambdas, but we don't bother.
633 extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
635 no_of_extra_binders = -- First, use the info about how many args it's
636 -- always applied to in its scope; but ignore this
637 -- if it's a thunk! To see why we ignore it for thunks,
638 -- consider let f = lookup env key in (f 1, f 2)
639 -- We'd better not eta expand f just because it is
643 else min_no_of_args - no_of_binders)
645 -- Next, try seeing if there's a lambda hidden inside
650 -- Finally, see if it's a state transformer, in which
651 -- case we eta-expand on principle! This can waste work,
652 -- but usually doesn't
654 case potential_extra_binder_tys of
655 [ty] | ty `eqTy` realWorldStateTy -> 1
661 %************************************************************************
663 \subsection[Simplify-coerce]{Coerce expressions}
665 %************************************************************************
668 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
669 simplCoerce env coercion ty expr@(Case scrut alts) args
670 = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
671 (computeResultType env expr args)
673 -- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
674 simplCoerce env coercion ty (Let bind body) args
675 = simplBind env bind (\env -> simplCoerce env coercion ty body args)
676 (computeResultType env body args)
679 simplCoerce env coercion ty expr args
680 = simplExpr env expr [] `thenSmpl` \ expr' ->
681 returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
684 -- Try cancellation; we do this "on the way up" because
685 -- I think that's where it'll bite best
686 mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
687 mkCoerce coercion ty body = Coerce coercion ty body
691 %************************************************************************
693 \subsection[Simplify-let]{Let-expressions}
695 %************************************************************************
698 simplBind :: SimplEnv
700 -> (SimplEnv -> SmplM OutExpr)
705 When floating cases out of lets, remember this:
707 let x* = case e of alts
710 where x* is sure to be demanded or e is a cheap operation that cannot
711 fail, e.g. unboxed addition. Here we should be prepared to duplicate
712 <small expr>. A good example:
721 p1 -> foldr c n (build e1)
722 p2 -> foldr c n (build e2)
724 NEW: We use the same machinery that we use for case-of-case to
725 *always* do case floating from let, that is we let bind and abstract
726 the original let body, and let the occurrence analyser later decide
727 whether the new let should be inlined or not. The example above
731 let join_body x' = foldr c n x'
733 p1 -> let x* = build e1
735 p2 -> let x* = build e2
738 note that join_body is a let-no-escape.
739 In this particular example join_body will later be inlined,
740 achieving the same effect.
741 ToDo: check this is OK with andy
746 -- Dead code is now discarded by the occurrence analyser,
748 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
749 | idWantsToBeINLINEd id
750 = complete_bind env rhs -- Don't messa bout with floating or let-to-case on
755 -- Try let-to-case; see notes below about let-to-case
756 simpl_bind env rhs | will_be_demanded &&
758 type_ok_for_let_to_case rhs_ty &&
759 not rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
760 = tick Let2Case `thenSmpl_`
761 mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
762 simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty
763 -- NB: it's tidier to call complete_bind not simpl_bind, else
764 -- we nearly end up in a loop. Consider:
766 -- ==> case rhs of (p,q) -> let x=(p,q) in b
767 -- This effectively what the above simplCase call does.
768 -- Now, the inner let is a let-to-case target again! Actually, since
769 -- the RHS is in WHNF it won't happen, but it's a close thing!
772 simpl_bind env (Let bind rhs) | let_floating_ok
773 = tick LetFloatFromLet `thenSmpl_`
774 simplBind env (fix_up_demandedness will_be_demanded bind)
775 (\env -> simpl_bind env rhs) body_ty
777 -- Try case-from-let; this deals with a strict let of error too
778 simpl_bind env (Case scrut alts) | will_be_demanded ||
779 (float_primops && is_cheap_prim_app scrut)
780 = tick CaseFloatFromLet `thenSmpl_`
782 -- First, bind large let-body if necessary
783 if ok_to_dup || isSingleton (nonErrorRHSs alts)
785 simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
787 bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
789 body_c' = \env -> simplExpr env new_body []
790 case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
792 simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
793 returnSmpl (Let extra_binding case_expr)
795 -- None of the above; simplify rhs and tidy up
796 simpl_bind env rhs = complete_bind env rhs
798 complete_bind env rhs
799 = simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) ->
800 cloneId env binder `thenSmpl` \ new_id ->
801 completeNonRec env binder
802 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
803 body_c new_env `thenSmpl` \ body' ->
804 returnSmpl (mkCoLetsAny binds body')
807 -- All this stuff is computed at the start of the simpl_bind loop
808 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
809 float_primops = switchIsSet env SimplOkToFloatPrimOps
810 ok_to_dup = switchIsSet env SimplOkToDupCode
811 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
812 try_let_to_case = switchIsSet env SimplLetToCase
813 no_float = switchIsSet env SimplNoLetFromStrictLet
815 will_be_demanded = willBeDemanded (getIdDemandInfo id)
818 rhs_is_whnf = case mkFormSummary rhs of
823 let_floating_ok = (will_be_demanded && not no_float) ||
824 always_float_let_from_let ||
825 floatExposesHNF float_lets float_primops ok_to_dup rhs
830 It's important to try let-to-case before floating. Consider
832 let a*::Int = case v of {p1->e1; p2->e2}
835 (The * means that a is sure to be demanded.)
836 If we do case-floating first we get this:
840 p1-> let a*=e1 in k a
841 p2-> let a*=e2 in k a
843 Now watch what happens if we do let-to-case first:
845 case (case v of {p1->e1; p2->e2}) of
846 Int a# -> let a*=I# a# in b
848 let k = \a# -> let a*=I# a# in b
850 p1 -> case e1 of I# a# -> k a#
851 p1 -> case e1 of I# a# -> k a#
853 The latter is clearly better. (Remember the reboxing let-decl for a
854 is likely to go away, because after all b is strict in a.)
856 We do not do let to case for WHNFs, e.g.
862 as this is less efficient. but we don't mind doing let-to-case for
863 "bottom", as that will allow us to remove more dead code, if anything:
867 case error of x -> ...
871 Notice that let to case occurs only if x is used strictly in its body
878 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
879 on and it'll expose a HNF), and bang the whole resulting mess together
882 1. Any "macros" should be expanded. The main application of this
891 Here we would like the single call to g to be inlined.
893 We can spot this easily, because g will be tagged as having just one
894 occurrence. The "inlineUnconditionally" predicate is just what we want.
896 A worry: could this lead to non-termination? For example:
905 Here, f and g call each other (just once) and neither is used elsewhere.
908 * the occurrence analyser will drop any (sub)-group that isn't used at
911 * If the group is used outside itself (ie in the "in" part), then there
914 ** IMPORTANT: check that NewOccAnal has the property that a group of
915 bindings like the above has f&g dropped.! ***
918 2. We'd also like to pull out any top-level let(rec)s from the
922 f = let h = ... in \x -> ....h...f...h...
928 f = \x -> ....h...f...h...
932 But floating cases is less easy? (Don't for now; ToDo?)
935 3. We'd like to arrange that the RHSs "know" about members of the
936 group that are bound to constructors. For example:
940 f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
941 /= a b = unpack tuple a, unpack tuple b, call f
944 here, by knowing about d.Eq in f's rhs, one could get rid of
945 the case (and break out the recursion completely).
946 [This occurred with more aggressive inlining threshold (4),
947 nofib/spectral/knights]
950 1: we simplify constructor rhss first.
951 2: we record the "known constructors" in the environment
952 3: we simplify the other rhss, with the knowledge about the constructors
957 simplBind env (Rec pairs) body_c body_ty
958 = -- Do floating, if necessary
960 floated_pairs | do_floating = float_pairs pairs
963 ticks | do_floating = length floated_pairs - length pairs
966 binders = map fst floated_pairs
968 tickN LetFloatFromLet ticks `thenSmpl_`
969 -- It's important to increment the tick counts if we
970 -- do any floating. A situation where this turns out
971 -- to be important is this:
972 -- Float in produces:
973 -- letrec x = let y = Ey in Ex
975 -- Now floating gives this:
979 --- We now want to iterate once more in case Ey doesn't
980 -- mention x, in which case the y binding can be pulled
981 -- out as an enclosing let(rec), which in turn gives
982 -- the strictness analyser more chance.
984 cloneIds env binders `thenSmpl` \ ids' ->
986 env_w_clones = extendIdEnvWithClones env binders ids'
988 simplRecursiveGroup env_w_clones ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
990 body_c new_env `thenSmpl` \ body' ->
992 returnSmpl (Let binding body')
995 ------------ Floating stuff -------------------
997 float_lets = switchIsSet env SimplFloatLetsExposingWHNF
998 always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
999 do_floating = float_lets || always_float_let_from_let
1001 float_pairs pairs = concat (map float_pair pairs)
1003 float_pair (binder, rhs)
1004 | always_float_let_from_let ||
1005 floatExposesHNF True False False rhs
1006 = (binder,rhs') : pairs'
1011 (pairs', rhs') = do_float rhs
1013 -- Float just pulls out any top-level let(rec) bindings
1014 do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
1015 do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
1017 (pairs', body') = do_float body
1018 do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
1020 (pairs', body') = do_float body
1021 do_float other = ([], other)
1024 -- The env passed to simplRecursiveGroup already has
1025 -- bindings that clone the variables of the group.
1026 simplRecursiveGroup env new_ids pairs
1027 = -- Add unfoldings to the new_ids corresponding to their RHS
1029 binders = map fst pairs
1030 occs = map snd binders
1031 new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
1032 rhs_env = foldl extendEnvForRecBinding
1036 mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss_w_arities ->
1039 new_pairs = zipWithEqual "simplRecGp" mk_new_pair new_ids new_rhss_w_arities
1040 mk_new_pair id (rhs,arity) = (id `withArity` arity, rhs)
1041 -- NB: the new arity isn't used when processing its own
1042 -- right hand sides, nor in the subsequent code
1043 -- The latter is something of a pity, and not hard to fix; but
1044 -- the info will percolate on the next iteration anyway
1046 {- THE NEXT FEW LINES ARE PLAIN WRONG
1047 occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
1048 new_env = foldl add_binding env occs_w_new_pairs
1050 add_binding env (occ_info,(new_id,new_rhs))
1051 = extendEnvGivenBinding env occ_info new_id new_rhs
1053 Here's why it's wrong: consider
1054 let f x = ...f x'...
1058 If the RHS is small we'll inline f in the body of the let, then
1059 again, then again...URK
1062 returnSmpl (Rec new_pairs, rhs_env)
1066 @completeLet@ looks at the simplified post-floating RHS of the
1067 let-expression, and decides what to do. There's one interesting
1068 aspect to this, namely constructor reuse. Consider
1074 Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
1075 bit on the compiler technology, but in general I believe not. For
1076 example, here's some code from a real program:
1078 const.Int.max.wrk{-s2516-} =
1079 \ upk.s3297# upk.s3298# ->
1083 a.s3299 = I#! upk.s3297#
1085 case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1086 _LT -> I#! upk.s3298#
1091 The a.s3299 really isn't doing much good. We'd be better off inlining
1092 it. (Actually, let-no-escapery means it isn't as bad as it looks.)
1094 So the current strategy is to inline all known-form constructors, and
1095 only do the reverse (turn a constructor application back into a
1096 variable) when we find a let-expression:
1100 ... (let y = C a1 .. an in ...) ...
1102 where it is always good to ditch the binding for y, and replace y by
1103 x. That's just what completeLetBinding does.
1107 -- We want to ensure that all let-bound Coerces have
1108 -- atomic bodies, so they can freely be inlined.
1109 completeNonRec env binder new_id (Coerce coercion ty rhs)
1110 | not (is_atomic rhs)
1111 = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
1113 (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1114 -- Dangerous occ because, like constructor args,
1115 -- it can be duplicated easily
1117 atomic_rhs = case lookupId env1 inner_id of
1121 completeNonRec env1 binder new_id
1122 (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
1124 returnSmpl (env2, binds1 ++ binds2)
1126 is_atomic (Var v) = True
1127 is_atomic (Lit l) = not (isNoRepLit l)
1128 is_atomic other = False
1130 -- Atomic right-hand sides.
1131 -- We used to have a "tick AtomicRhs" in here, but it causes more trouble
1132 -- than it's worth. For a top-level binding a = b, where a is exported,
1133 -- we can't drop the binding, so we get repeated AtomicRhs ticks
1134 completeNonRec env binder new_id rhs@(Var v)
1135 = returnSmpl (extendIdEnvWithAtom env binder (VarArg v), [NonRec new_id rhs])
1137 completeNonRec env binder new_id rhs@(Lit lit)
1138 | not (isNoRepLit lit)
1139 = returnSmpl (extendIdEnvWithAtom env binder (LitArg lit), [NonRec new_id rhs])
1141 -- Right hand sides that are constructors
1144 --- ...(let w = C same-args in ...)...
1145 -- Then use v instead of w. This may save
1146 -- re-constructing an existing constructor.
1147 completeNonRec env binder new_id rhs@(Con con con_args)
1148 | switchIsSet env SimplReuseCon &&
1149 maybeToBool maybe_existing_con &&
1150 not (isExported new_id) -- Don't bother for exported things
1151 -- because we won't be able to drop
1153 = tick ConReused `thenSmpl_`
1154 returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
1156 maybe_existing_con = lookForConstructor env con con_args
1157 Just it = maybe_existing_con
1160 completeNonRec env binder@(id,occ_info) new_id rhs
1161 = returnSmpl (new_env, [NonRec new_id rhs])
1163 env1 = extendIdEnvWithClone env binder new_id
1164 new_env = extendEnvGivenBinding env1 occ_info new_id rhs
1167 %************************************************************************
1169 \subsection[Simplify-atoms]{Simplifying atoms}
1171 %************************************************************************
1174 simplArg :: SimplEnv -> InArg -> OutArg
1176 simplArg env (LitArg lit) = LitArg lit
1177 simplArg env (TyArg ty) = TyArg (simplTy env ty)
1178 simplArg env (VarArg id) = lookupId env id
1181 %************************************************************************
1183 \subsection[Simplify-quickies]{Some local help functions}
1185 %************************************************************************
1189 -- fix_up_demandedness switches off the willBeDemanded Info field
1190 -- for bindings floated out of a non-demanded let
1191 fix_up_demandedness True {- Will be demanded -} bind
1192 = bind -- Simple; no change to demand info needed
1193 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1194 = NonRec (un_demandify binder) rhs
1195 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1196 = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1198 un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1200 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1201 is_cheap_prim_app other = False
1203 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
1204 computeResultType env expr args
1207 expr_ty = coreExprType (unTagBinders expr)
1208 expr_ty' = simplTy env expr_ty
1211 go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1212 go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1213 Just (_, res_ty) -> go res_ty args
1214 Nothing -> panic "computeResultType"
1216 var `withArity` UnknownArity = var
1217 var `withArity` arity = var `addIdArity` arity