----------------------------------
-\begin{code}
-simplType :: InType -> SimplM OutType
-simplType ty
- = getSubst `thenSmpl` \ subst ->
- let
- new_ty = substTy subst ty
- in
- seqType new_ty `seq`
- returnSmpl new_ty
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Binding}
-%* *
-%************************************************************************
-
-@simplBeta@ is used for non-recursive lets in expressions,
-as well as true beta reduction.
-
-Very similar to @simplLazyBind@, but not quite the same.
-
-\begin{code}
-simplBeta :: InId -- Binder
- -> InExpr -> SubstEnv -- Arg, with its subst-env
- -> OutType -- Type of thing computed by the context
- -> SimplM OutExprStuff -- The body
- -> SimplM OutExprStuff
-#ifdef DEBUG
-simplBeta bndr rhs rhs_se cont_ty thing_inside
- | isTyVar bndr
- = pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
-#endif
-
-simplBeta bndr rhs rhs_se cont_ty thing_inside
- | preInlineUnconditionally False {- not black listed -} bndr
- = tick (PreInlineUnconditionally bndr) `thenSmpl_`
- extendSubst bndr (ContEx rhs_se rhs) thing_inside
-
- | otherwise
- = -- Simplify the RHS
- simplBinder bndr $ \ bndr' ->
- let
- bndr_ty' = idType bndr'
- is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
- in
- simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->
-
- -- Now complete the binding and simplify the body
- if needsCaseBinding bndr_ty' rhs' then
- addCaseBind bndr' rhs' thing_inside
- else
- completeBinding bndr bndr' False False rhs' thing_inside
-\end{code}
-
-
-\begin{code}
-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 never has postInlineUnconditionally 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
- -- 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 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}
-
-
-