- | otherwise
- = simplRhs False {- Not top level -}
- True {- OK to float unboxed -}
- arg_ty arg arg_se
- thing_inside
-\end{code}
-
-
-completeBinding
- - deals only with Ids, not TyVars
- - take an already-simplified RHS
-
-It does *not* attempt to do let-to-case. Why? Because they are used for
-
- - top-level bindings
- (when let-to-case is impossible)
-
- - many situations where the "rhs" is known to be a WHNF
- (so let-to-case is inappropriate).
-
-\begin{code}
-completeBinding :: InId -- Binder
- -> OutId -- New binder
- -> Bool -- True <=> top level
- -> Bool -- True <=> black-listed; don't inline
- -> OutExpr -- Simplified RHS
- -> SimplM (OutStuff a) -- Thing inside
- -> SimplM (OutStuff a)
-
-completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
- | isDeadOcc occ_info -- This happens; for example, the case_bndr during case of
- -- known constructor: case (a,b) of x { (p,q) -> ... }
- -- Here x isn't mentioned in the RHS, so we don't want to
- -- create the (dead) let-binding let x = (a,b) in ...
- = thing_inside
-
- | trivial_rhs && not must_keep_binding
- -- We're looking at a binding with a trivial RHS, so
- -- perhaps we can discard it altogether!
- --
- -- NB: a loop breaker has must_keep_binding = True
- -- and non-loop-breakers only have *forward* references
- -- Hence, it's safe to discard the binding
- --
- -- NOTE: This isn't our last opportunity to inline.
- -- We're at the binding site right now, and
- -- we'll get another opportunity when we get to the ocurrence(s)
-
- -- Note that we do this unconditional inlining only for trival RHSs.
- -- Don't inline even WHNFs inside lambdas; doing so may
- -- simply increase allocation when the function is called
- -- This isn't the last chance; see NOTE above.
- --
- -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
- -- Why? Because we don't even want to inline them into the
- -- RHS of constructor arguments. See NOTE above
- --
- -- NB: Even NOINLINEis ignored here: if the rhs is trivial
- -- it's best to inline it anyway. We often get a=E; b=a
- -- from desugaring, with both a and b marked NOINLINE.
- = -- Drop the binding
- extendSubst old_bndr (DoneEx new_rhs) $
- -- Use the substitution to make quite, quite sure that the substitution
- -- will happen, since we are going to discard the binding
- tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
- thing_inside
-
- | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs,
- not trivial_rhs && not (isUnLiftedType inner_ty)
- -- x = coerce t e ==> c = e; x = inline_me (coerce t c)
- -- Now x can get inlined, which moves the coercion
- -- to the usage site. This is a bit like worker/wrapper stuff,
- -- but it's useful to do it very promptly, so that
- -- x = coerce T (I# 3)
- -- get's w/wd to
- -- c = I# 3
- -- x = coerce T c
- -- This in turn means that
- -- case (coerce Int x) of ...
- -- will inline x.
- -- Also the full-blown w/w thing isn't set up for non-functions
- --
- -- The (not (isUnLiftedType inner_ty)) avoids the nasty case of
- -- x::Int = coerce Int Int# (foo y)
- -- ==>
- -- v::Int# = foo y
- -- x::Int = coerce Int Int# v
- -- which would be bogus because then v will be evaluated strictly.
- -- How can this arise? Via
- -- x::Int = case (foo y) of { ... }
- -- followed by case elimination.
- --
- -- The inline_me note is so that the simplifier doesn't
- -- just substitute c back inside x's rhs! (Typically, x will
- -- get substituted away, but not if it's exported.)
- = newId SLIT("c") inner_ty $ \ c_id ->
- completeBinding c_id c_id top_lvl False inner_rhs $
- completeBinding old_bndr new_bndr top_lvl black_listed
- (Note InlineMe (Note coercion (Var c_id))) $
- thing_inside
-
- | otherwise
- = getSubst `thenSmpl` \ subst ->
- let
- -- We make new IdInfo for the new binder by starting from the old binder,
- -- doing appropriate substitutions.
- -- Then we add arity and unfolding info to get the new binder
- new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
- `setArityInfo` arity_info
-
- -- Add the unfolding *only* for non-loop-breakers
- -- Making loop breakers not have an unfolding at all
- -- means that we can avoid tests in exprIsConApp, for example.
- -- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing, then we can get into an infinite loop
- info_w_unf | loop_breaker = new_bndr_info
- | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
-
- final_id = new_bndr `setIdInfo` info_w_unf
- in
- -- These seqs forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- final_id `seq`
- addLetBind (NonRec final_id new_rhs) $
- modifyInScope new_bndr final_id thing_inside
-
- where
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
- loop_breaker = isLoopBreaker occ_info
- trivial_rhs = exprIsTrivial new_rhs
- must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
- arity_info = atLeastArity (exprArity new_rhs)
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{simplLazyBind}
-%* *
-%************************************************************************
-
-simplLazyBind basically just simplifies the RHS of a let(rec).
-It does two important optimisations though:
-
- * It floats let(rec)s out of the RHS, even if they
- are hidden by big lambdas
-
- * It does eta expansion
-
-\begin{code}
-simplLazyBind :: Bool -- True <=> top level
- -> InId -> OutId
- -> InExpr -- The RHS
- -> SimplM (OutStuff a) -- The body of the binding
- -> SimplM (OutStuff a)
--- When called, the subst env is correct for the entire let-binding
--- and hence right for the RHS.
--- Also the binder has already been simplified, and hence is in scope
-
-simplLazyBind top_lvl bndr bndr' rhs thing_inside
- = getBlackList `thenSmpl` \ black_list_fn ->
- let
- black_listed = black_list_fn bndr
- in
-
- if preInlineUnconditionally black_listed bndr then
- -- Inline unconditionally
- tick (PreInlineUnconditionally bndr) `thenSmpl_`
- getSubstEnv `thenSmpl` \ rhs_se ->
- (extendSubst bndr (ContEx rhs_se rhs) thing_inside)
- else
-
- -- Simplify the RHS
- getSubstEnv `thenSmpl` \ rhs_se ->
- simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
- (idType bndr')
- rhs rhs_se $ \ rhs' ->
-
- -- Now compete the binding and simplify the body
- completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside
-\end{code}
-
-
-
-\begin{code}
-simplRhs :: Bool -- True <=> Top level
- -> Bool -- True <=> OK to float unboxed (speculative) bindings
- -- False for (a) recursive and (b) top-level bindings
- -> OutType -- Type of RHS; used only occasionally
- -> InExpr -> SubstEnv
- -> (OutExpr -> SimplM (OutStuff a))
- -> SimplM (OutStuff a)
-simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
- = -- Simplify it
- setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) `thenSmpl` \ (floats1, (rhs_in_scope, rhs1)) ->
- let
- (floats2, rhs2) = splitFloats float_ubx floats1 rhs1
- in
- -- There's a subtlety here. There may be a binding (x* = e) in the
- -- floats, where the '*' means 'will be demanded'. So is it safe
- -- to float it out? Answer no, but it won't matter because
- -- we only float if arg' is a WHNF,
- -- and so there can't be any 'will be demanded' bindings in the floats.
- -- Hence the assert
- WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) )
-
- -- Transform the RHS
- -- It's important that we do eta expansion on function *arguments* (which are
- -- simplified with simplRhs), as well as let-bound right-hand sides.
- -- Otherwise we find that things like
- -- f (\x -> case x of I# x' -> coerce T (\ y -> ...))
- -- get right through to the code generator as two separate lambdas,
- -- which is a Bad Thing
- tryRhsTyLam rhs2 `thenSmpl` \ (floats3, rhs3) ->
- tryEtaExpansion rhs3 rhs_ty `thenSmpl` \ (floats4, rhs4) ->
-
- -- Float lets if (a) we're at the top level
- -- or (b) the resulting RHS is one we'd like to expose
- if (top_lvl || exprIsCheap rhs4) then
- (if (isNilOL floats2 && null floats3 && null floats4) then
- returnSmpl ()
- else
- tick LetFloatFromLet) `thenSmpl_`
-
- addFloats floats2 rhs_in_scope $
- addAuxiliaryBinds floats3 $
- addAuxiliaryBinds floats4 $
- thing_inside rhs4
- else
- -- Don't do the float
- thing_inside (wrapFloats floats1 rhs1)