-simplTyArg :: InType -> SubstEnv -> SimplM OutType
-simplTyArg ty_arg se
- = getInScope `thenSmpl` \ in_scope ->
- let
- ty_arg' = substTy (mkSubst in_scope se) ty_arg
- in
- seqType ty_arg' `seq`
- returnSmpl ty_arg'
-
-simplValArg :: OutType -- rhs_ty: Type of arg; used only occasionally
- -> Bool -- True <=> evaluate eagerly
- -> InExpr -> SubstEnv
- -> OutType -- cont_ty: Type of thing computed by the context
- -> (OutExpr -> SimplM OutExprStuff)
- -- Takes an expression of type rhs_ty,
- -- returns an expression of type cont_ty
- -> SimplM OutExprStuff -- An expression of type cont_ty
-
-simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside
- | is_strict
- = getEnv `thenSmpl` \ env ->
- setSubstEnv arg_se $
- simplExprF arg (ArgOf NoDup cont_ty $ \ rhs' ->
- setAllExceptInScope env $
- thing_inside rhs')
-
- | 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
- = 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 = idInfo new_bndr `setArityInfo` arity
-
- -- 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 = 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
- getSubst `thenSmpl` \ rhs_subst ->
- let
- -- Substitute IdInfo on binder, in the light of earlier
- -- substitutions in this very letrec, and extend the in-scope
- -- env so that it can see the new thing
- bndr'' = simplIdInfo rhs_subst (idInfo bndr) bndr'
- in
- modifyInScope bndr'' bndr'' $
-
- simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
- (idType bndr')
- rhs (substEnv rhs_subst) $ \ 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
- -- 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
- --
- -- NB: the test used to say "exprIsCheap", but that caused a strictness bug.
- -- x = let y* = E in case (scc y) of { T -> F; F -> T}
- -- The case expression is 'cheap', but it's wrong to transform to
- -- y* = E; x = case (scc y) of {...}
- -- Either we must be careful not to float demanded non-values, or
- -- we must use exprIsValue for the test, which ensures that the
- -- thing is non-strict. I think. The WARN below tests for this
- if (top_lvl || exprIsValue rhs4) then
-
- -- 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 (filter demanded_float (fromOL floats2)) )
-
- (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)
-
-demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
- -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
-demanded_float (Rec _) = False
-
--- If float_ubx is true we float all the bindings, otherwise
--- we just float until we come across an unlifted one.
--- Remember that the unlifted bindings in the floats are all for
--- guaranteed-terminating non-exception-raising unlifted things,
--- which we are happy to do speculatively. However, we may still
--- not be able to float them out, because the context
--- is either a Rec group, or the top level, neither of which
--- can tolerate them.
-splitFloats float_ubx floats rhs
- | float_ubx = (floats, rhs) -- Float them all
- | otherwise = go (fromOL floats)
- where
- go [] = (nilOL, rhs)
- go (f:fs) | must_stay f = (nilOL, mkLets (f:fs) rhs)
- | otherwise = case go fs of
- (out, rhs') -> (f `consOL` out, rhs')
-
- must_stay (Rec prs) = False -- No unlifted bindings in here
- must_stay (NonRec b r) = isUnLiftedType (idType b)
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Variables}
-%* *
-%************************************************************************
-
-\begin{code}
-simplVar var cont
- = getSubst `thenSmpl` \ subst ->
- case lookupIdSubst subst var of
- DoneEx e -> zapSubstEnv (simplExprF e cont)
- ContEx env1 e -> setSubstEnv env1 (simplExprF e cont)
- DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1,