X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=91e1c779cf749304856962c93d6da1acec97e495;hb=afc7564e0bcd27ff98775648bb2308b25710d20f;hp=bbd0e944c29b0a37f4c658b632fff4ad67730df4;hpb=d08b0747c9573fd2c3bd05c82430b02bf0bcfc5f;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index bbd0e94..91e1c77 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -8,20 +8,27 @@ module Simplify ( simplTopBinds, simplExpr, simplBind ) where +IMPORT_1_3(List(partition)) + IMP_Ubiq(){-uitous-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 IMPORT_DELOOPER(SmplLoop) -- paranoia checking -IMPORT_1_3(List(partition)) +#endif import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import ConFold ( completePrim ) -import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, exprIsTrivial, whnfOrBottom, FormSummary(..) ) -import CostCentre ( isSccCountCostCentre, cmpCostCentre ) +import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary, + exprIsTrivial, whnfOrBottom, inlineUnconditionally, + FormSummary(..) + ) +import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre ) import CoreSyn import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, unTagBinders, squashableDictishCcExpr ) -import Id ( idType, idWantsToBeINLINEd, idMustNotBeINLINEd, addIdArity, getIdArity, +import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, + addIdArity, getIdArity, getIdDemandInfo, addIdDemandInfo, GenId{-instance NamedThing-} ) @@ -30,8 +37,6 @@ import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), atLeastArity, unknownArity ) import Literal ( isNoRepLit ) import Maybes ( maybeToBool ) ---import Name ( isExported ) -import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} ) #if __GLASGOW_HASKELL__ <= 30 import PprCore ( GenCoreArg, GenCoreExpr ) @@ -45,11 +50,11 @@ import SimplMonad import SimplVar ( completeVar ) import Unique ( Unique ) import SimplUtils -import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, +import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon, splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy ) import TysWiredIn ( realWorldStateTy ) -import Outputable ( Outputable(..) ) +import Outputable ( PprStyle(..), Outputable(..) ) import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager, isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace ) \end{code} @@ -498,33 +503,23 @@ simplRhsExpr -> InExpr -> OutId -- The new binder (used only for its type) -> SmplM (OutExpr, ArityInfo) +\end{code} --- First a special case for variable right-hand sides --- v = w --- It's OK to simplify the RHS, but it's often a waste of time. Often --- these v = w things persist because v is exported, and w is used --- elsewhere. So if we're not careful we'll eta expand the rhs, only --- to eta reduce it in competeNonRec. --- --- If we leave the binding unchanged, we will certainly replace v by w at --- every occurrence of v, which is good enough. --- --- In fact, it's better to replace v by w than to inline w in v's rhs, --- even if this is the only occurrence of w. Why? Because w might have --- IdInfo (like strictness) that v doesn't. - -simplRhsExpr env binder@(id,occ_info) (Var v) new_id - = case (runEager $ lookupId env v) of - LitArg lit -> returnSmpl (Lit lit, ArityExactly 0) - VarArg v' -> returnSmpl (Var v', getIdArity v') +\begin{code} simplRhsExpr env binder@(id,occ_info) rhs new_id + | maybeToBool (maybeAppDataTyCon rhs_ty) + -- Deal with the data type case, in which case the elaborate + -- eta-expansion nonsense is really quite a waste of time. + = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' -> + returnSmpl (rhs', ArityExactly 0) + + | otherwise -- OK, use the big hammer = -- Deal with the big lambda part ASSERT( null uvars ) -- For now mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' -> let - rhs_ty = idType new_id new_tys = mkTyVarTys tyvars' body_ty = foldl applyTy rhs_ty new_tys lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys) @@ -539,41 +534,95 @@ simplRhsExpr env binder@(id,occ_info) rhs new_id returnSmpl (rhs', arity) where - rhs_env | -- Don't ever inline in a INLINE thing's rhs, because - -- doing so will inline a worker straight back into its wrapper! - idWantsToBeINLINEd id - = switchOffInlining env + rhs_ty = idType new_id + rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs + = switchOffInlining env1 -- See comments with switchOffInlining | otherwise - = env + = env1 - -- Switch off all inlining in the RHS of things that have an INLINE pragma. - -- They are going to be inlined wherever they are used, and then all the - -- inlining will take effect. Meanwhile, there isn't - -- much point in doing anything to the as-yet-un-INLINEd rhs. - -- It's very important to switch off inlining! Consider: - -- - -- let f = \pq -> BIG - -- in - -- let g = \y -> f y y - -- {-# INLINE g #-} - -- in ...g...g...g...g...g... - -- - -- Now, if that's the ONLY occurrence of f, it will be inlined inside g, - -- and thence copied multiple times when g is inlined. + -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC + -- for the rhs of top level defs is "OST_CENTRE". Consider + -- f = \x -> e + -- g = \y -> let v = f y in scc "x" (v ...) + -- Here we want to inline "f", since its CC is SUBSUMED, but we don't + -- want to inline "v" since its CC is dynamically determined. - -- Andy disagrees! Example: - -- all xs = foldr (&&) True xs - -- any p = all . map p {-# INLINE any #-} - -- - -- Problem: any won't get deforested, and so if it's exported and - -- the importer doesn't use the inlining, (eg passes it as an arg) - -- then we won't get deforestation at all. - -- We havn't solved this problem yet! + current_cc = getEnclosingCC env + env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre + | otherwise = env (uvars, tyvars, body) = collectUsageAndTyBinders rhs \end{code} +---------------------------------------------------------------- + An old special case that is now nuked. + +First a special case for variable right-hand sides + v = w +It's OK to simplify the RHS, but it's often a waste of time. Often +these v = w things persist because v is exported, and w is used +elsewhere. So if we're not careful we'll eta expand the rhs, only +to eta reduce it in competeNonRec. + +If we leave the binding unchanged, we will certainly replace v by w at +every occurrence of v, which is good enough. + +In fact, it's *better* to replace v by w than to inline w in v's rhs, +even if this is the only occurrence of w. Why? Because w might have +IdInfo (such as strictness) that v doesn't. + +Furthermore, there might be other uses of w; if so, inlining w in +v's rhs will duplicate w's rhs, whereas replacing v by w doesn't. + +HOWEVER, we have to be careful if w is something that *must* be +inlined. In particular, its binding may have been dropped. Here's +an example that actually happened: + let x = let y = e in y + in f x +The "let y" was floated out, and then (since y occurs once in a +definitely inlinable position) the binding was dropped, leaving + {y=e} let x = y in f x +But now using the reasoning of this little section, +y wasn't inlined, because it was a let x=y form. + + + HOWEVER + +This "optimisation" turned out to be a bad idea. If there's are +top-level exported bindings like + + y = I# 3# + x = y + +then y wasn't getting inlined in x's rhs, and we were getting +bad code. So I've removed the special case from here, and +instead we only try eta reduction and constructor reuse +in completeNonRec if the thing is *not* exported. + + +\begin{pseudocode} +simplRhsExpr env binder@(id,occ_info) (Var v) new_id + | maybeToBool maybe_stop_at_var + = returnSmpl (Var the_var, getIdArity the_var) + where + maybe_stop_at_var + = case (runEager $ lookupId env v) of + VarArg v' | not (must_unfold v') -> Just v' + other -> Nothing + + Just the_var = maybe_stop_at_var + + must_unfold v' = idMustBeINLINEd v' + || case lookupOutIdEnv env v' of + Just (_, _, InUnfolding _ _) -> True + other -> False +\end{pseudocode} + + End of old, nuked, special case. +------------------------------------------------------------------ + + %************************************************************************ %* * \subsection{Simplify a lambda abstraction} @@ -710,7 +759,7 @@ simplCoerce env coercion ty expr args result_ty %************************************************************************ %* * -\subsection[Simplify-let]{Let-expressions} +\subsection[Simplify-bind]{Binding groups} %* * %************************************************************************ @@ -720,8 +769,35 @@ simplBind :: SimplEnv -> (SimplEnv -> SmplM OutExpr) -> OutType -> SmplM OutExpr + +simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty +simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty \end{code} + +%************************************************************************ +%* * +\subsection[Simplify-let]{Let-expressions} +%* * +%************************************************************************ + +Float switches +~~~~~~~~~~~~~~ +The booleans controlling floating have to be set with a little care. +Here's one performance bug I found: + + let x = let y = let z = case a# +# 1 of {b# -> E1} + in E2 + in E3 + in E4 + +Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding. +Before case_floating_ok included float_exposes_hnf, the case expression was floated +*one level per simplifier iteration* outwards. So it made th s + + +Floating case from let +~~~~~~~~~~~~~~~~~~~~~~ When floating cases out of lets, remember this: let x* = case e of alts @@ -761,35 +837,109 @@ achieving the same effect. ToDo: check this is OK with andy +Let to case: two points +~~~~~~~~~~~ + +Point 1. We defer let-to-case for all data types except single-constructor +ones. Suppose we change + + let x* = e in b +to + case e of x -> b + +It can be the case that we find that b ultimately contains ...(case x of ..).... +and this is the only occurrence of x. Then if we've done let-to-case +we can't inline x, which is a real pain. On the other hand, we lose no +transformations by not doing this transformation, because the relevant +case-of-X transformations are also implemented by simpl_bind. + +If x is a single-constructor type, then we go ahead anyway, giving + + case e of (y,z) -> let x = (y,z) in b + +because now we can squash case-on-x wherever they occur in b. + +We do let-to-case on multi-constructor types in the tidy-up phase +(tidyCoreExpr) mainly so that the code generator doesn't need to +spot the demand-flag. + + +Point 2. It's important to try let-to-case before doing the +strict-let-of-case transformation, which happens in the next equation +for simpl_bind. + + let a*::Int = case v of {p1->e1; p2->e2} + in b + +(The * means that a is sure to be demanded.) +If we do case-floating first we get this: + + let k = \a* -> b + in case v of + p1-> let a*=e1 in k a + p2-> let a*=e2 in k a + +Now watch what happens if we do let-to-case first: + + case (case v of {p1->e1; p2->e2}) of + Int a# -> let a*=I# a# in b +===> + let k = \a# -> let a*=I# a# in b + in case v of + p1 -> case e1 of I# a# -> k a# + p1 -> case e2 of I# a# -> k a# + +The latter is clearly better. (Remember the reboxing let-decl for a +is likely to go away, because after all b is strict in a.) + +We do not do let to case for WHNFs, e.g. + + let x = a:b in ... + =/=> + case a:b of x in ... + +as this is less efficient. but we don't mind doing let-to-case for +"bottom", as that will allow us to remove more dead code, if anything: + + let x = error in ... + ===> + case error of x -> ... + ===> + error + +Notice that let to case occurs only if x is used strictly in its body +(obviously). + \begin{code} -- Dead code is now discarded by the occurrence analyser, -simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty +simplNonRec env binder@(id,occ_info) rhs body_c body_ty + | inlineUnconditionally ok_to_dup id occ_info + = -- The binder is used in definitely-inline way in the body + -- So add it to the environment, drop the binding, and continue + body_c (extendEnvGivenInlining env id occ_info rhs) + | idWantsToBeINLINEd id = complete_bind env rhs -- Don't mess about with floating or let-to-case on -- INLINE things | otherwise = simpl_bind env rhs where - -- Try for strict let of error - simpl_bind env rhs | will_be_demanded && maybeToBool maybe_error_app - = returnSmpl retyped_error_app - where - maybe_error_app = maybeErrorApp rhs (Just body_ty) - Just retyped_error_app = maybe_error_app - -- Try let-to-case; see notes below about let-to-case - simpl_bind env rhs | will_be_demanded && - try_let_to_case && - singleConstructorType rhs_ty && + simpl_bind env rhs | try_let_to_case && + will_be_demanded && + (rhs_is_bot || + not rhs_is_whnf && + singleConstructorType rhs_ty -- Only do let-to-case for single constructor types. -- For other types we defer doing it until the tidy-up phase at -- the end of simplification. - not rhs_is_whnf -- note: WHNF, but not bottom, (comment below) + ) = tick Let2Case `thenSmpl_` - mkIdentityAlts rhs_ty demand_info `thenSmpl` \ id_alts -> - simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty + simplCase env rhs (AlgAlts [] (BindDefault binder (Var id))) + (\env rhs -> complete_bind env rhs) body_ty + -- OLD COMMENT: [now the new RHS is only "x" so there's less worry] -- NB: it's tidier to call complete_bind not simpl_bind, else -- we nearly end up in a loop. Consider: -- let x = rhs in b @@ -816,7 +966,7 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) -> let body_c' = \env -> simplExpr env new_body [] body_ty - case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty + case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty in simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr -> returnSmpl (Let extra_binding case_expr) @@ -865,177 +1015,173 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty -- See note below \end{code} -Float switches -~~~~~~~~~~~~~~ -The booleans controlling floating have to be set with a little care. -Here's one performance bug I found: - let x = let y = let z = case a# +# 1 of {b# -> E1} - in E2 - in E3 - in E4 +@completeNonRec@ looks at the simplified post-floating RHS of the +let-expression, with a view to turning + x = e +into + x = y +where y is just a variable. Now we can eliminate the binding +altogether, and replace x by y throughout. -Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding. -Before case_floating_ok included float_exposes_hnf, the case expression was floated -*one level per simplifier iteration* outwards. So it made th s - -Let to case: two points -~~~~~~~~~~~ - -Point 1. We defer let-to-case for all data types except single-constructor -ones. Suppose we change - - let x* = e in b -to - case e of x -> b - -It can be the case that we find that b ultimately contains ...(case x of ..).... -and this is the only occurrence of x. Then if we've done let-to-case -we can't inline x, which is a real pain. On the other hand, we lose no -transformations by not doing this transformation, because the relevant -case-of-X transformations are also implemented by simpl_bind. - -If x is a single-constructor type, then we go ahead anyway, giving - - case e of (y,z) -> let x = (y,z) in b - -because now we can squash case-on-x wherever they occur in b. - -We do let-to-case on multi-constructor types in the tidy-up phase -(tidyCoreExpr) mainly so that the code generator doesn't need to -spot the demand-flag. +There are two cases when we can do this: + * When e is a constructor application, and we have + another variable in scope bound to the same + constructor application. [This is just a special + case of common-subexpression elimination.] -Point 2. It's important to try let-to-case before doing the -strict-let-of-case transformation, which happens in the next equation -for simpl_bind. + * When e can be eta-reduced to a variable. E.g. + x = \a b -> y a b - let a*::Int = case v of {p1->e1; p2->e2} - in b -(The * means that a is sure to be demanded.) -If we do case-floating first we get this: +HOWEVER, if x is exported, we don't attempt this at all. Why not? +Because then we can't remove the x=y binding, in which case we +have just made things worse, perhaps a lot worse. - let k = \a* -> b - in case v of - p1-> let a*=e1 in k a - p2-> let a*=e2 in k a +\begin{code} + -- Right hand sides that are constructors + -- let v = C args + -- in + --- ...(let w = C same-args in ...)... + -- Then use v instead of w. This may save + -- re-constructing an existing constructor. +completeNonRec env binder new_id new_rhs + | not (isExported new_id) -- Don't bother for exported things + -- because we won't be able to drop + -- its binding. + && maybeToBool maybe_atomic_rhs + = tick tick_type `thenSmpl_` + returnSmpl (extendIdEnvWithAtom env binder rhs_arg, []) + where + Just (rhs_arg, tick_type) = maybe_atomic_rhs + maybe_atomic_rhs + = -- Try first for an existing constructor application + case maybe_con new_rhs of { + Just con -> Just (VarArg con, ConReused); + + Nothing -> -- No good; try eta-reduction + case etaCoreExpr new_rhs of { + Var v -> Just (VarArg v, AtomicRhs); + Lit l -> Just (LitArg l, AtomicRhs); + + other -> Nothing -- Neither worked, so return Nothing + }} + -Now watch what happens if we do let-to-case first: + maybe_con (Con con con_args) | switchIsSet env SimplReuseCon + = lookForConstructor env con con_args + maybe_con other_rhs = Nothing - case (case v of {p1->e1; p2->e2}) of - Int a# -> let a*=I# a# in b -===> - let k = \a# -> let a*=I# a# in b - in case v of - p1 -> case e1 of I# a# -> k a# - p1 -> case e2 of I# a# -> k a# +completeNonRec env binder@(id,occ_info) new_id new_rhs + = returnSmpl (new_env , [NonRec new_id new_rhs]) + where + new_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id) + occ_info new_id new_rhs +\end{code} -The latter is clearly better. (Remember the reboxing let-decl for a -is likely to go away, because after all b is strict in a.) +---------------------------------------------------------------------------- + A digression on constructor CSE -We do not do let to case for WHNFs, e.g. +Consider +@ + f = \x -> case x of + (y:ys) -> y:ys + [] -> ... +@ +Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a +bit on the compiler technology, but in general I believe not. For +example, here's some code from a real program: +@ +const.Int.max.wrk{-s2516-} = + \ upk.s3297# upk.s3298# -> + let { + a.s3299 :: Int + _N_ {-# U(P) #-} + a.s3299 = I#! upk.s3297# + } in + case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of { + _LT -> I#! upk.s3298# + _EQ -> a.s3299 + _GT -> a.s3299 + } +@ +The a.s3299 really isn't doing much good. We'd be better off inlining +it. (Actually, let-no-escapery means it isn't as bad as it looks.) - let x = a:b in ... - =/=> - case a:b of x in ... +So the current strategy is to inline all known-form constructors, and +only do the reverse (turn a constructor application back into a +variable) when we find a let-expression: +@ + let x = C a1 .. an + in + ... (let y = C a1 .. an in ...) ... +@ +where it is always good to ditch the binding for y, and replace y by +x. + End of digression +---------------------------------------------------------------------------- + +---------------------------------------------------------------------------- + A digression on "optimising" coercions + + The trouble is that we kept transforming + let x = coerce e + y = coerce x + in ... + to + let x' = coerce e + y' = coerce x' + in ... + and counting a couple of ticks for this non-transformation +\begin{pseudocode} + -- We want to ensure that all let-bound Coerces have + -- atomic bodies, so they can freely be inlined. +completeNonRec env binder new_id (Coerce coercion ty rhs) + | not (is_atomic rhs) + = newId (coreExprType rhs) `thenSmpl` \ inner_id -> + completeNonRec env + (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) -> + -- Dangerous occ because, like constructor args, + -- it can be duplicated easily + let + atomic_rhs = case runEager $ lookupId env1 inner_id of + LitArg l -> Lit l + VarArg v -> Var v + in + completeNonRec env1 binder new_id + (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) -> -as this is less efficient. but we don't mind doing let-to-case for -"bottom", as that will allow us to remove more dead code, if anything: + returnSmpl (env2, binds1 ++ binds2) +\end{pseudocode} +---------------------------------------------------------------------------- - let x = error in ... - ===> - case error of x -> ... - ===> - error -Notice that let to case occurs only if x is used strictly in its body -(obviously). +%************************************************************************ +%* * +\subsection[Simplify-letrec]{Letrec-expressions} +%* * +%************************************************************************ Letrec expressions ~~~~~~~~~~~~~~~~~~ +Here's the game plan -Simplify each RHS, float any let(recs) from the RHSs (if let-floating is -on and it'll expose a HNF), and bang the whole resulting mess together -into a huge letrec. - -1. Any "macros" should be expanded. The main application of this -macro-expansion is: - - letrec - f = ....g... - g = ....f... - in - ....f... - -Here we would like the single call to g to be inlined. - -We can spot this easily, because g will be tagged as having just one -occurrence. The "inlineUnconditionally" predicate is just what we want. - -A worry: could this lead to non-termination? For example: - - letrec - f = ...g... - g = ...f... - h = ...h... - in - ..h.. - -Here, f and g call each other (just once) and neither is used elsewhere. -But it's OK: - -* the occurrence analyser will drop any (sub)-group that isn't used at - all. - -* If the group is used outside itself (ie in the "in" part), then there - can't be a cyle. - -** IMPORTANT: check that NewOccAnal has the property that a group of - bindings like the above has f&g dropped.! *** - - -2. We'd also like to pull out any top-level let(rec)s from the -rhs of the defns: - - letrec - f = let h = ... in \x -> ....h...f...h... - in - ...f... -====> - letrec - h = ... - f = \x -> ....h...f...h... - in - ...f... - -But floating cases is less easy? (Don't for now; ToDo?) - - -3. We'd like to arrange that the RHSs "know" about members of the -group that are bound to constructors. For example: - - let rec - d.Eq = (==,/=) - f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y) - /= a b = unpack tuple a, unpack tuple b, call f - in d.Eq - -here, by knowing about d.Eq in f's rhs, one could get rid of -the case (and break out the recursion completely). -[This occurred with more aggressive inlining threshold (4), -nofib/spectral/knights] - -How to do it? - 1: we simplify constructor rhss first. - 2: we record the "known constructors" in the environment - 3: we simplify the other rhss, with the knowledge about the constructors +1. Float any let(rec)s out of the RHSs +2. Clone all the Ids and extend the envt with these clones +3. Simplify one binding at a time, adding each binding to the + environment once it's done. +This relies on the occurrence analyser to + a) break all cycles with an Id marked MustNotBeInlined + b) sort the decls into topological order +The former prevents infinite inlinings, and the latter means +that we get maximum benefit from working top to bottom. \begin{code} -simplBind env (Rec pairs) body_c body_ty +simplRec env pairs body_c body_ty = -- Do floating, if necessary floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] -> let @@ -1058,7 +1204,22 @@ simplBind env (Rec pairs) body_c body_ty simplRecursiveGroup env new_ids [] = returnSmpl ([], env) -simplRecursiveGroup env (new_id : new_ids) ((binder@(_, occ_info), rhs) : pairs) +simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs) + | inlineUnconditionally ok_to_dup id occ_info + = -- Single occurrence, so drop binding and extend env with the inlining + -- This is a little delicate, because what if the unique occurrence + -- is *before* this binding? This'll never happen, because + -- either it'll be marked "never inline" or else its occurrence will + -- occur after its binding in the group. + -- + -- If these claims aren't right Core Lint will spot an unbound + -- variable. A quick fix is to delete this clause for simplRecursiveGroup + let + new_env = extendEnvGivenInlining env new_id occ_info rhs + in + simplRecursiveGroup new_env new_ids pairs + + | otherwise = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) -> let new_id' = new_id `withArity` arity @@ -1083,112 +1244,12 @@ simplRecursiveGroup env (new_id : new_ids) ((binder@(_, occ_info), rhs) : pairs) in simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) -> returnSmpl ((new_id', new_rhs) : new_pairs, final_env) -\end{code} - - -@completeLet@ looks at the simplified post-floating RHS of the -let-expression, and decides what to do. There's one interesting -aspect to this, namely constructor reuse. Consider -@ - f = \x -> case x of - (y:ys) -> y:ys - [] -> ... -@ -Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a -bit on the compiler technology, but in general I believe not. For -example, here's some code from a real program: -@ -const.Int.max.wrk{-s2516-} = - \ upk.s3297# upk.s3298# -> - let { - a.s3299 :: Int - _N_ {-# U(P) #-} - a.s3299 = I#! upk.s3297# - } in - case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of { - _LT -> I#! upk.s3298# - _EQ -> a.s3299 - _GT -> a.s3299 - } -@ -The a.s3299 really isn't doing much good. We'd be better off inlining -it. (Actually, let-no-escapery means it isn't as bad as it looks.) - -So the current strategy is to inline all known-form constructors, and -only do the reverse (turn a constructor application back into a -variable) when we find a let-expression: -@ - let x = C a1 .. an - in - ... (let y = C a1 .. an in ...) ... -@ -where it is always good to ditch the binding for y, and replace y by -x. That's just what completeLetBinding does. - - -\begin{code} - -- We want to ensure that all let-bound Coerces have - -- atomic bodies, so they can freely be inlined. -completeNonRec env binder new_id (Coerce coercion ty rhs) - | not (is_atomic rhs) - = newId (coreExprType rhs) `thenSmpl` \ inner_id -> - completeNonRec env - (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) -> - -- Dangerous occ because, like constructor args, - -- it can be duplicated easily - let - atomic_rhs = case runEager $ lookupId env1 inner_id of - LitArg l -> Lit l - VarArg v -> Var v - in - completeNonRec env1 binder new_id - (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) -> - - returnSmpl (env2, binds1 ++ binds2) - - -- Right hand sides that are constructors - -- let v = C args - -- in - --- ...(let w = C same-args in ...)... - -- Then use v instead of w. This may save - -- re-constructing an existing constructor. -completeNonRec env binder new_id rhs@(Con con con_args) - | switchIsSet env SimplReuseCon && - maybeToBool maybe_existing_con && - not (isExported new_id) -- Don't bother for exported things - -- because we won't be able to drop - -- its binding. - = tick ConReused `thenSmpl_` - returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs]) where - maybe_existing_con = lookForConstructor env con con_args - Just it = maybe_existing_con - - - -- Default case - -- Check for atomic right-hand sides. - -- We used to have a "tick AtomicRhs" in here, but it causes more trouble - -- than it's worth. For a top-level binding a = b, where a is exported, - -- we can't drop the binding, so we get repeated AtomicRhs ticks -completeNonRec env binder@(id,occ_info) new_id new_rhs - | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic - = returnSmpl (atomic_env , [NonRec new_id eta'd_rhs]) - - | otherwise -- Non atomic rhs (don't eta after all) - = returnSmpl (non_atomic_env , [NonRec new_id new_rhs]) - where - atomic_env = extendIdEnvWithAtom env binder the_arg - - non_atomic_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id) - occ_info new_id new_rhs - - eta'd_rhs = etaCoreExpr new_rhs - the_arg = case eta'd_rhs of - Var v -> VarArg v - Lit l -> LitArg l + ok_to_dup = switchIsSet env SimplOkToDupCode \end{code} + \begin{code} floatBind :: SimplEnv -> Bool -- True <=> Top level @@ -1274,7 +1335,7 @@ floatBind env top_level bind leakFree (id,_) rhs = case getIdArity id of ArityAtLeast n | n > 0 -> True ArityExactly n | n > 0 -> True - other -> whnfOrBottom rhs + other -> whnfOrBottom (mkFormSummary rhs) \end{code}