-@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' ->
- simplValArg (idType bndr') (idDemandInfo bndr)
- rhs rhs_se cont_ty $ \ rhs' ->
-
- -- Now complete the binding and simplify the body
- if needsCaseBinding (idType bndr') 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 -- Type of arg
- -> Demand -- Demand on the argument
- -> InExpr -> SubstEnv
- -> OutType -- Type of thing computed by the context
- -> (OutExpr -> SimplM OutExprStuff)
- -> SimplM OutExprStuff
-
-simplValArg arg_ty demand arg arg_se cont_ty thing_inside
- | isStrict demand ||
- isUnLiftedType arg_ty ||
- (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty)
- -- Return true only for dictionary types where the dictionary
- -- has more than one component (else we risk poking on the component
- -- of a newtype dictionary)
- = transformRhs arg `thenSmpl` \ t_arg ->
- getEnv `thenSmpl` \ env ->
- setSubstEnv arg_se $
- simplExprF t_arg (ArgOf NoDup cont_ty $ \ rhs' ->
- setAllExceptInScope env $
- etaFirst thing_inside rhs')
-
- | otherwise
- = simplRhs False {- Not top level -}
- True {- OK to float unboxed -}
- arg_ty arg arg_se
- thing_inside
-
--- Do eta-reduction on the simplified RHS, if eta reduction is on
--- NB: etaFirst only eta-reduces if that results in something trivial
-etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCoreExprToTrivial rhs)
- | otherwise = \ thing_inside rhs -> thing_inside rhs
-
--- Try for eta reduction, but *only* if we get all
--- the way to an exprIsTrivial expression. We don't want to remove
--- extra lambdas unless we are going to avoid allocating this thing altogether
-etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs'
- | otherwise = rhs
- where
- rhs' = etaReduceExpr rhs
-\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
- | (case occ_info of -- This happens; for example, the case_bndr during case of
- IAmDead -> True -- known constructor: case (a,b) of x { (p,q) -> ... }
- other -> False) -- 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
-
- | postInlineUnconditionally black_listed occ_info old_bndr new_rhs
- -- Maybe we don't need a let-binding! Maybe we can just
- -- inline it right away. Unlike the preInlineUnconditionally case
- -- we are allowed to look at the RHS.
- --
- -- NB: a loop breaker never has postInlineUnconditionally True
- -- and non-loop-breakers only have *forward* references
- -- Hence, it's safe to discard the binding
- --
- -- NB: You might think that postInlineUnconditionally is an optimisation,
- -- but if we have
- -- let x = f Bool in (x, y)
- -- then because of the constructor, x will not be *inlined* in the pair,
- -- so the trivial binding will stay. But in this postInlineUnconditionally
- -- gag we use the *substitution* to substitute (f Bool) for x, and that *will*
- -- happen.
- = tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
- extendSubst old_bndr (DoneEx new_rhs)
- 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
- old_info = idInfo old_bndr
- new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
- `setArityInfo` ArityAtLeast (exprArity new_rhs)
- `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
-
- final_id = new_bndr `setIdInfo` new_bndr_info
- in
- -- These seqs forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- final_id `seq`
- addLetBind final_id new_rhs $
- modifyInScope new_bndr final_id thing_inside
-
- where
- occ_info = idOccInfo old_bndr
-\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 -}
- (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}
-
-
-