Commit 802f4b89 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Improve eta expansion (again)

The presenting issue was that we were never eta-expanding

    f (\x -> case x of (a,b) -> \s -> blah)

and that meant we were allocating two lambdas instead of one.
See Note [Eta expanding lambdas] in SimplUtils.

However I didn't want to eta expand the lambda, and then try all over
again for tryEtaExpandRhs.  Yet the latter is important in the context
of a let-binding it can do simple arity analysis.  So I ended up
refactoring CallCtxt so that it tells when we are on the RHS of a let.

I also moved findRhsArity from SimplUtils to CoreArity.

Performance increases nicely. Here are the ones where allocation improved
by more than 0.5%. Notice the nice decrease in binary size too.

--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
           ansi          -2.3%     -0.9%      0.00      0.00     +0.0%
           bspt          -2.1%     -9.7%      0.01      0.01    -33.3%
          fasta          -1.8%    -11.7%     -3.4%     -3.6%     +0.0%
            fft          -1.9%     -1.3%      0.06      0.06    +11.1%
reverse-complem          -1.9%    -18.1%     -1.9%     -2.8%     +0.0%
         sphere          -1.8%     -4.5%      0.09      0.09     +0.0%
      transform          -1.8%     -2.3%     -4.6%     -3.1%     +0.0%
--------------------------------------------------------------------------------
            Min          -3.0%    -18.1%    -13.9%    -14.6%    -35.7%
            Max          -1.3%     +0.0%     +7.7%     +7.7%    +50.0%
 Geometric Mean          -1.9%     -0.6%     -2.1%     -2.1%     -0.2%
parent 0001d161
......@@ -16,7 +16,7 @@
-- | Arit and eta expansion
module CoreArity (
manifestArity, exprArity, exprBotStrictness_maybe,
exprEtaExpandArity, CheapFun, etaExpand
exprEtaExpandArity, findRhsArity, CheapFun, etaExpand
) where
#include "HsVersions.h"
......@@ -38,6 +38,7 @@ import DynFlags ( DynFlags, GeneralFlag(..), gopt )
import Outputable
import FastString
import Pair
import Util ( debugIsOn )
\end{code}
%************************************************************************
......@@ -490,25 +491,18 @@ vanillaArityType = ATop [] -- Totally uninformative
-- ^ The Arity returned is the number of value args the
-- expression can be applied to without doing much work
exprEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
-- exprEtaExpandArity is used when eta expanding
-- e ==> \xy -> e x y
exprEtaExpandArity dflags cheap_app e
exprEtaExpandArity dflags e
= case (arityType env e) of
ATop (os:oss)
| os || has_lam e -> 1 + length oss -- Note [Eta expanding thunks]
| otherwise -> 0
ATop [] -> 0
ABot n -> n
ATop oss -> length oss
ABot n -> n
where
env = AE { ae_bndrs = []
, ae_cheap_fn = mk_cheap_fn dflags cheap_app
, ae_cheap_fn = mk_cheap_fn dflags isCheapApp
, ae_ped_bot = gopt Opt_PedanticBottoms dflags }
has_lam (Tick _ e) = has_lam e
has_lam (Lam b e) = isId b || has_lam e
has_lam _ = False
getBotArity :: ArityType -> Maybe Arity
-- Arity of a divergent function
getBotArity (ABot n) = Just n
......@@ -523,8 +517,94 @@ mk_cheap_fn dflags cheap_app
|| case mb_ty of
Nothing -> False
Just ty -> isDictLikeTy ty
----------------------
findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
-- This implements the fixpoint loop for arity analysis
-- See Note [Arity analysis]
findRhsArity dflags bndr rhs old_arity
= go (rhsEtaExpandArity dflags init_cheap_app rhs)
-- We always call exprEtaExpandArity once, but usually
-- that produces a result equal to old_arity, and then
-- we stop right away (since arities should not decrease)
-- Result: the common case is that there is just one iteration
where
init_cheap_app :: CheapAppFun
init_cheap_app fn n_val_args
| fn == bndr = True -- On the first pass, this binder gets infinite arity
| otherwise = isCheapApp fn n_val_args
go :: Arity -> Arity
go cur_arity
| cur_arity <= old_arity = cur_arity
| new_arity == cur_arity = cur_arity
| otherwise = ASSERT( new_arity < cur_arity )
#ifdef DEBUG
pprTrace "Exciting arity"
(vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
, ppr rhs])
#endif
go new_arity
where
new_arity = rhsEtaExpandArity dflags cheap_app rhs
cheap_app :: CheapAppFun
cheap_app fn n_val_args
| fn == bndr = n_val_args < cur_arity
| otherwise = isCheapApp fn n_val_args
-- ^ The Arity returned is the number of value args the
-- expression can be applied to without doing much work
rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
-- exprEtaExpandArity is used when eta expanding
-- e ==> \xy -> e x y
rhsEtaExpandArity dflags cheap_app e
= case (arityType env e) of
ATop (os:oss)
| os || has_lam e -> 1 + length oss -- Don't expand PAPs/thunks
-- Note [Eta expanding thunks]
| otherwise -> 0
ATop [] -> 0
ABot n -> n
where
env = AE { ae_bndrs = []
, ae_cheap_fn = mk_cheap_fn dflags cheap_app
, ae_ped_bot = gopt Opt_PedanticBottoms dflags }
has_lam (Tick _ e) = has_lam e
has_lam (Lam b e) = isId b || has_lam e
has_lam _ = False
\end{code}
Note [Arity analysis]
~~~~~~~~~~~~~~~~~~~~~
The motivating example for arity analysis is this:
f = \x. let g = f (x+1)
in \y. ...g...
What arity does f have? Really it should have arity 2, but a naive
look at the RHS won't see that. You need a fixpoint analysis which
says it has arity "infinity" the first time round.
This example happens a lot; it first showed up in Andy Gill's thesis,
fifteen years ago! It also shows up in the code for 'rnf' on lists
in Trac #4138.
The analysis is easy to achieve because exprEtaExpandArity takes an
argument
type CheapFun = CoreExpr -> Maybe Type -> Bool
used to decide if an expression is cheap enough to push inside a
lambda. And exprIsCheap' in turn takes an argument
type CheapAppFun = Id -> Int -> Bool
which tells when an application is cheap. This makes it easy to
write the analysis loop.
The analysis is cheap-and-cheerful because it doesn't deal with
mutual recursion. But the self-recursive case is the important one.
Note [Eta expanding through dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the experimental -fdicts-cheap flag is on, we eta-expand through
......@@ -549,6 +629,11 @@ isDictLikeTy here rather than isDictTy
Note [Eta expanding thunks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't eta-expand
* Trivial RHSs x = y
* PAPs x = map g
* Thunks f = case y of p -> \x -> blah
When we see
f = case y of p -> \x -> blah
should we eta-expand it? Well, if 'x' is a one-shot state token
......
......@@ -25,7 +25,7 @@ find, unsurprisingly, a Core expression.
module CoreUnfold (
Unfolding, UnfoldingGuidance, -- Abstract types
noUnfolding, mkImplicitUnfolding,
noUnfolding, mkImplicitUnfolding,
mkUnfolding, mkCoreUnfolding,
mkTopUnfolding, mkSimpleUnfolding,
mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
......@@ -881,28 +881,26 @@ instance Outputable ArgSummary where
ppr NonTrivArg = ptext (sLit "NonTrivArg")
ppr ValueArg = ptext (sLit "ValueArg")
data CallCtxt = BoringCtxt
data CallCtxt
= BoringCtxt
| RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets]
| DiscArgCtxt -- Argument of a fuction with non-zero arg discount
| RuleArgCtxt -- We are somewhere in the argument of a function with rules
| ArgCtxt -- We are somewhere in the argument of a function
Bool -- True <=> we're somewhere in the RHS of function with rules
-- False <=> we *are* the argument of a function with non-zero
-- arg discount
-- OR
-- we *are* the RHS of a let Note [RHS of lets]
-- In both cases, be a little keener to inline
| ValAppCtxt -- We're applied to at least one value arg
-- This arises when we have ((f x |> co) y)
-- Then the (f x) has argument 'x' but in a ValAppCtxt
| ValAppCtxt -- We're applied to at least one value arg
-- This arises when we have ((f x |> co) y)
-- Then the (f x) has argument 'x' but in a ValAppCtxt
| CaseCtxt -- We're the scrutinee of a case
-- that decomposes its scrutinee
| CaseCtxt -- We're the scrutinee of a case
-- that decomposes its scrutinee
instance Outputable CallCtxt where
ppr BoringCtxt = ptext (sLit "BoringCtxt")
ppr (ArgCtxt rules) = ptext (sLit "ArgCtxt") <+> ppr rules
ppr CaseCtxt = ptext (sLit "CaseCtxt")
ppr ValAppCtxt = ptext (sLit "ValAppCtxt")
ppr CaseCtxt = ptext (sLit "CaseCtxt")
ppr ValAppCtxt = ptext (sLit "ValAppCtxt")
ppr BoringCtxt = ptext (sLit "BoringCtxt")
ppr RhsCtxt = ptext (sLit "RhsCtxt")
ppr DiscArgCtxt = ptext (sLit "DiscArgCtxt")
ppr RuleArgCtxt = ptext (sLit "RuleArgCtxt")
callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
= case idUnfolding id of
......@@ -971,10 +969,13 @@ tryUnfolding dflags id lone_variable
interesting_call
= case cont_info' of
BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions]
CaseCtxt -> not (lone_variable && is_wf) -- Note [Lone variables]
ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt]
ValAppCtxt -> True -- Note [Cast then apply]
CaseCtxt -> not (lone_variable && is_wf) -- Note [Lone variables]
ValAppCtxt -> True -- Note [Cast then apply]
RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts]
DiscArgCtxt -> uf_arity > 0 --
RhsCtxt -> uf_arity > 0 --
_ -> not is_top && uf_arity > 0 -- Note [Nested functions]
-- Note [Inlining in ArgCtxt]
(yes_or_no, extra_doc)
= case guidance of
......@@ -995,15 +996,20 @@ tryUnfolding dflags id lone_variable
res_discount arg_infos cont_info'
\end{code}
Note [RHS of lets]
~~~~~~~~~~~~~~~~~~
Be a tiny bit keener to inline in the RHS of a let, because that might
lead to good thing later
Note [Unfold into lazy contexts], Note [RHS of lets]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the call is the argument of a function with a RULE, or the RHS of a let,
we are a little bit keener to inline. For example
f y = (y,y,y)
g y = let x = f y in ...(case x of (a,b,c) -> ...) ...
We'd inline 'f' if the call was in a case context, and it kind-of-is,
only we can't see it. So we treat the RHS of a let as not-totally-boring.
only we can't see it. Also
x = f v
could be expensive whereas
x = case v of (a,b) -> a
is patently cheap and may allow more eta expansion.
So we treat the RHS of a let as not-totally-boring.
Note [Unsaturated applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When a call is not saturated, we *still* inline if one of the
......@@ -1212,7 +1218,15 @@ computeDiscount dflags uf_arity arg_discounts res_discount arg_infos cont_info
BoringCtxt -> 0
CaseCtxt -> res_discount -- Presumably a constructor
ValAppCtxt -> res_discount -- Presumably a function
ArgCtxt {} -> 40 `min` res_discount
_ -> 40 `min` res_discount
-- ToDo: this 40 `min` res_dicount doesn't seem right
-- for DiscArgCtxt it shouldn't matter because the function will
-- get the arg discount for any non-triv arg
-- for RuleArgCtxt we do want to be keener to inline; but not only
-- constructor results
-- for RhsCtxt I suppose that exposing a data con is good in general
-- And 40 seems very arbitrary
--
-- res_discount can be very large when a function returns
-- constructors; but we only want to invoke that large discount
-- when there's a case continuation.
......
......@@ -6,7 +6,7 @@
\begin{code}
module SimplUtils (
-- Rebuilding
mkLam, mkCase, prepareAlts, tryEtaExpand,
mkLam, mkCase, prepareAlts, tryEtaExpandRhs,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally,
......@@ -93,12 +93,14 @@ Key points:
data SimplCont
= Stop -- An empty context, or <hole>
OutType -- Type of the <hole>
CallCtxt -- True <=> There is something interesting about
CallCtxt -- Tells if there is something interesting about
-- the context, and hence the inliner
-- should be a bit keener (see interestingCallContext)
-- Specifically:
-- This is an argument of a function that has RULES
-- Inlining the call might allow the rule to fire
-- Never ValAppCxt (use ApplyTo instead)
-- or CaseCtxt (use Select instead)
| CoerceIt -- <hole> `cast` co
OutCoercion -- The coercion simplified
......@@ -224,7 +226,7 @@ mkBoringStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty BoringCtxt
mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in CoreUnfold
mkRhsStop ty = Stop ty (ArgCtxt False)
mkRhsStop ty = Stop ty RhsCtxt
mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
mkLazyArgStop ty cci = Stop ty cci
......@@ -236,6 +238,10 @@ contIsRhsOrArg (StrictBind {}) = True
contIsRhsOrArg (StrictArg {}) = True
contIsRhsOrArg _ = False
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop _ RhsCtxt) = True
contIsRhs _ = False
-------------------
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop {}) = True
......@@ -361,11 +367,7 @@ interestingCallContext :: SimplCont -> CallCtxt
interestingCallContext cont
= interesting cont
where
interesting (Select _ bndr _ _ _)
| isDeadBinder bndr = CaseCtxt
| otherwise = ArgCtxt False -- If the binder is used, this
-- is like a strict let
-- See Note [RHS of lets] in CoreUnfold
interesting (Select _ _bndr _ _ _) = CaseCtxt
interesting (ApplyTo _ arg _ cont)
| isTypeArg arg = interesting cont
......@@ -505,8 +507,8 @@ interestingArgContext rules call_cont
go (Stop _ cci) = interesting cci
go (TickIt _ c) = go c
interesting (ArgCtxt rules) = rules
interesting _ = False
interesting RuleArgCtxt = True
interesting _ = False
\end{code}
......@@ -1084,14 +1086,14 @@ won't inline because 'e' is too big.
%************************************************************************
\begin{code}
mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr
mkLam :: [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
-- mkLam tries three things
-- a) eta reduction, if that gives a trivial expression
-- b) eta expansion [only if there are some value lambdas]
mkLam _b [] body
mkLam [] body _cont
= return body
mkLam _env bndrs body
mkLam bndrs body cont
= do { dflags <- getDynFlags
; mkLam' dflags bndrs body }
where
......@@ -1116,11 +1118,37 @@ mkLam _env bndrs body
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
| not (contIsRhs cont) -- See Note [Eta-expanding lambdas]
, gopt Opt_DoLambdaEtaExpansion dflags
, any isRuntimeVar bndrs
, let body_arity = exprEtaExpandArity dflags body
, body_arity > 0
= do { tick (EtaExpansion (head bndrs))
; return (mkLams bndrs (etaExpand body_arity body)) }
| otherwise
= return (mkLams bndrs body)
\end{code}
Note [Eta expanding lambdas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general we *do* want to eta-expand lambdas. Consider
f (\x -> case x of (a,b) -> \s -> blah)
where 's' is a state token, and hence can be eta expanded. This
showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather
important function!
The eta-expansion will never happen unless we do it now. (Well, it's
possible that CorePrep will do it, but CorePrep only has a half-baked
eta-expander that can't deal with casts. So it's much better to do it
here.)
However, when the lambda is let-bound, as the RHS of a let, we have a
better eta-expander (in the form of tryEtaExpandRhs), so we don't
bother to try expansion in mkLam in that case; hence the contIsRhs
guard.
Note [Casts and lambdas]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider
......@@ -1160,10 +1188,10 @@ because the latter is not well-kinded.
%************************************************************************
\begin{code}
tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
-- See Note [Eta-expanding at let bindings]
-- and Note [Eta expansion to manifest arity]
tryEtaExpand env bndr rhs
tryEtaExpandRhs env bndr rhs
= do { dflags <- getDynFlags
; (new_arity, new_rhs) <- try_expand dflags
......@@ -1178,9 +1206,8 @@ tryEtaExpand env bndr rhs
= return (exprArity rhs, rhs)
| sm_eta_expand (getMode env) -- Provided eta-expansion is on
, let new_arity = findArity dflags bndr rhs old_arity
, let new_arity = findRhsArity dflags bndr rhs old_arity
, new_arity > manifest_arity -- And the curent manifest arity isn't enough
-- See Note [Eta expansion to manifest arity]
= do { tick (EtaExpansion bndr)
; return (new_arity, etaExpand new_arity rhs) }
| otherwise
......@@ -1189,46 +1216,13 @@ tryEtaExpand env bndr rhs
manifest_arity = manifestArity rhs
old_arity = idArity bndr
_dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr
findArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
-- This implements the fixpoint loop for arity analysis
-- See Note [Arity analysis]
findArity dflags bndr rhs old_arity
= go (exprEtaExpandArity dflags init_cheap_app rhs)
-- We always call exprEtaExpandArity once, but usually
-- that produces a result equal to old_arity, and then
-- we stop right away (since arities should not decrease)
-- Result: the common case is that there is just one iteration
where
init_cheap_app :: CheapAppFun
init_cheap_app fn n_val_args
| fn == bndr = True -- On the first pass, this binder gets infinite arity
| otherwise = isCheapApp fn n_val_args
go :: Arity -> Arity
go cur_arity
| cur_arity <= old_arity = cur_arity
| new_arity == cur_arity = cur_arity
| otherwise = ASSERT( new_arity < cur_arity )
#ifdef DEBUG
pprTrace "Exciting arity"
(vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
, ppr rhs])
#endif
go new_arity
where
new_arity = exprEtaExpandArity dflags cheap_app rhs
cheap_app :: CheapAppFun
cheap_app fn n_val_args
| fn == bndr = n_val_args < cur_arity
| otherwise = isCheapApp fn n_val_args
\end{code}
Note [Eta-expanding at let bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We now eta expand at let-bindings, which is where the payoff
comes.
We now eta expand at let-bindings, which is where the payoff comes.
The most significant thing is that we can do a simple arity analysis
(in CoreArity.findRhsArity), which we can't do for free-floating lambdas
One useful consequence is this example:
genMap :: C a => ...
......@@ -1248,50 +1242,6 @@ because then 'genMap' will inline, and it really shouldn't: at least
as far as the programmer is concerned, it's not applied to two
arguments!
Note [Eta expansion to manifest arity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Eta expansion does *not* eta-expand trivial RHSs, like
x = y
because these will get substituted out in short order. (Indeed
we *eta-contract* if that yields a trivial RHS.)
Otherwise we eta-expand to produce enough manifest lambdas.
This *does* eta-expand partial applications. eg
x = map g --> x = \v -> map g v
y = \_ -> map g --> y = \_ v -> map g v
One benefit this is that in the definition of y there was
a danger that full laziness would transform to
lvl = map g
y = \_ -> lvl
which is stupid. This doesn't happen in the eta-expanded form.
Note [Arity analysis]
~~~~~~~~~~~~~~~~~~~~~
The motivating example for arity analysis is this:
f = \x. let g = f (x+1)
in \y. ...g...
What arity does f have? Really it should have arity 2, but a naive
look at the RHS won't see that. You need a fixpoint analysis which
says it has arity "infinity" the first time round.
This example happens a lot; it first showed up in Andy Gill's thesis,
fifteen years ago! It also shows up in the code for 'rnf' on lists
in Trac #4138.
The analysis is easy to achieve because exprEtaExpandArity takes an
argument
type CheapFun = CoreExpr -> Maybe Type -> Bool
used to decide if an expression is cheap enough to push inside a
lambda. And exprIsCheap' in turn takes an argument
type CheapAppFun = Id -> Int -> Bool
which tells when an application is cheap. This makes it easy to
write the analysis loop.
The analysis is cheap-and-cheerful because it doesn't deal with
mutual recursion. But the self-recursive case is the important one.
%************************************************************************
%* *
......
......@@ -342,16 +342,15 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
-- See Note [Floating and type abstraction] in SimplUtils
-- Simplify the RHS
; let body_out_ty :: OutType
body_out_ty = substTy body_env (exprType body)
; (body_env1, body1) <- simplExprF body_env body (mkRhsStop body_out_ty)
; let rhs_cont = mkRhsStop (substTy body_env (exprType body))
; (body_env1, body1) <- simplExprF body_env body rhs_cont
-- ANF-ise a constructor or PAP rhs
; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
; (env', rhs')
<- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
then -- No floating, revert to body1
do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1)
do { rhs' <- mkLam tvs' (wrapFloats body_env1 body1) rhs_cont
; return (env, rhs') }
else if null tvs then -- Simple floating
......@@ -361,7 +360,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
else -- Do type-abstraction first
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
; rhs' <- mkLam env tvs' body3
; rhs' <- mkLam tvs' body3 rhs_cont
; env' <- foldlM (addPolyBind top_lvl) env poly_binds
; return (env', rhs') }
......@@ -383,7 +382,8 @@ simplNonRecX env bndr new_rhs
-- the binding c = (a,b)
| Coercion co <- new_rhs
= return (extendCvSubst env bndr co)
| otherwise -- the binding b = (a,b)
| otherwise
= do { (env', bndr') <- simplBinder env bndr
; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
-- simplNonRecX is only used for NotTopLevel things
......@@ -656,7 +656,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
-- Do eta-expansion on the RHS of the binding
-- See Note [Eta-expanding at let bindings] in SimplUtils
; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs
; (new_arity, final_rhs) <- tryEtaExpandRhs env new_bndr new_rhs
-- Simplify the unfolding
; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
......@@ -1306,7 +1306,7 @@ simplLam env bndrs body (TickIt tickish cont)
simplLam env bndrs body cont
= do { (env', bndrs') <- simplLamBndrs env bndrs
; body' <- simplExpr env' body
; new_lam <- mkLam env' bndrs' body'
; new_lam <- mkLam bndrs' body' cont
; rebuild env' new_lam cont }
------------------
......@@ -1481,8 +1481,9 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
; rebuildCall env (addArgTo info' arg') cont }
where
info' = info { ai_strs = strs, ai_discs = discs }
cci | encl_rules || disc > 0 = ArgCtxt encl_rules -- Be keener here
| otherwise = BoringCtxt -- Nothing interesting
cci | encl_rules = RuleArgCtxt
| disc > 0 = DiscArgCtxt -- Be keener here
| otherwise = BoringCtxt -- Nothing interesting
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
| null rules
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment