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-}
)
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 )
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}
-> 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)
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}
%************************************************************************
%* *
-\subsection[Simplify-let]{Let-expressions}
+\subsection[Simplify-bind]{Binding groups}
%* *
%************************************************************************
-> (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
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
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)
-- 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
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
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
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}
projects / ghc-hetmet.git / blobdiff