%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 19941998
%
Coresyntax unfoldings
Unfoldings (which can travel across module boundaries) are in Core
syntax (namely @CoreExpr@s).
The type @Unfolding@ sits ``above'' simplyCoreexpressions
unfoldings, capturing ``higherlevel'' things we know about a binding,
usually things that the simplifier found out (e.g., ``it's a
literal''). In the corner of a @CoreUnfolding@ unfolding, you will
find, unsurprisingly, a Core expression.
\begin{code}
module CoreUnfold (
Unfolding, UnfoldingGuidance,
noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding,
mkCompulsoryUnfolding, seqUnfolding,
evaldUnfolding, mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
interestingArg, ArgSummary(..),
couldBeSmallEnoughToInline,
certainlyWillInline, smallEnoughToInline,
callSiteInline, CallCtxt(..),
) where
import StaticFlags
import DynFlags
import CoreSyn
import PprCore ()
import OccurAnal
import CoreSubst ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst
, lookupIdSubst, substBndr, substBndrs, substRecBndrs )
import CoreUtils
import Id
import DataCon
import Literal
import PrimOp
import IdInfo
import Type hiding( substTy, extendTvSubst )
import PrelNames
import Bag
import FastTypes
import FastString
import Outputable
\end{code}
%************************************************************************
%* *
\subsection{Making unfoldings}
%* *
%************************************************************************
\begin{code}
mkTopUnfolding :: CoreExpr -> Unfolding
mkTopUnfolding expr = mkUnfolding True expr
mkImplicitUnfolding :: CoreExpr -> Unfolding
mkImplicitUnfolding expr
= CoreUnfolding (simpleOptExpr emptySubst expr)
True
(exprIsHNF expr)
(exprIsCheap expr)
(exprIsExpandable expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold expr)
mkUnfolding :: Bool -> CoreExpr -> Unfolding
mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseExpr expr)
top_lvl
(exprIsHNF expr)
(exprIsCheap expr)
(exprIsExpandable expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold expr)
instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e
ppr (CoreUnfolding e top hnf cheap expable g)
= ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g,
ppr e]
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr
= CompulsoryUnfolding (occurAnalyseExpr expr)
\end{code}
%************************************************************************
%* *
\subsection{The UnfoldingGuidance type}
%* *
%************************************************************************
\begin{code}
instance Outputable UnfoldingGuidance where
ppr UnfoldNever = ptext (sLit "NEVER")
ppr (UnfoldIfGoodArgs v cs size discount)
= hsep [ ptext (sLit "IF_ARGS"), int v,
brackets (hsep (map int cs)),
int size,
int discount ]
\end{code}
\begin{code}
calcUnfoldingGuidance
:: Int
-> CoreExpr
-> UnfoldingGuidance
calcUnfoldingGuidance bOMB_OUT_SIZE expr
= case collect_val_bndrs expr of { (inline, val_binders, body) ->
let
n_val_binders = length val_binders
max_inline_size = n_val_binders+2
in
case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of
TooBig
| not inline -> UnfoldNever
| otherwise -> UnfoldIfGoodArgs n_val_binders
(map (const 0) val_binders)
max_inline_size 0
SizeIs size cased_args scrut_discount
-> UnfoldIfGoodArgs
n_val_binders
(map discount_for val_binders)
final_size
(iBox scrut_discount)
where
boxed_size = iBox size
final_size | inline = boxed_size `min` max_inline_size
| otherwise = boxed_size
discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc)
0 cased_args
}
where
collect_val_bndrs e = go False [] e
go _ rev_vbs (Note InlineMe e) = go True rev_vbs e
go inline rev_vbs (Lam b e) | isId b = go inline (b:rev_vbs) e
| otherwise = go inline rev_vbs e
go inline rev_vbs e = (inline, reverse rev_vbs, e)
\end{code}
Note [Computing the size of an expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The basic idea of sizeExpr is obvious enough: count nodes. But getting the
heuristics right has taken a long time. Here's the basic strategy:
* Variables, literals: 0
(Exception for string literals, see litSize.)
* Function applications (f e1 .. en): 1 + #value args
* Constructor applications: 1, regardless of #args
* Let(rec): 1 + size of components
* Note, cast: 0
Examples
Size Term
0 42#
0 x
2 f x
1 Just x
4 f (g x)
Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's
a function call to account for. Notice also that constructor applications
are very cheap, because exposing them to a caller is so valuable.
Thing to watch out for
* We inline *unconditionally* if inlined thing is smaller (using sizeExpr)
than the thing it's replacing. Notice that
(f x) --> (g 3)
(f x) --> x : []
x --> g 3
x --> Just v
It's very important not to unconditionally replace a variable by
a nonatomic term.
\begin{code}
sizeExpr :: FastInt
-> [Id]
-> CoreExpr
-> ExprSize
sizeExpr bOMB_OUT_SIZE top_args expr
= size_up expr
where
size_up (Type _) = sizeZero
size_up (Lit lit) = sizeN (litSize lit)
size_up (Var f) = size_up_call f 0
size_up (Cast e _) = size_up e
size_up (Note InlineMe _) = sizeOne
size_up (Note _ body) = size_up body
size_up (App fun (Type _)) = size_up fun
size_up (App fun arg) = size_up_app fun [arg]
`addSize` nukeScrutDiscount (size_up arg)
size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1)
| otherwise = size_up e
size_up (Let (NonRec binder rhs) body)
= nukeScrutDiscount (size_up rhs) `addSize`
size_up body `addSizeN`
(if isUnLiftedType (idType binder) then 0 else 1)
size_up (Let (Rec pairs) body)
= nukeScrutDiscount rhs_size `addSize`
size_up body `addSizeN`
length pairs
where
rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
size_up (Case (Var v) _ _ alts)
| v `elem` top_args
= alts_size (foldr addSize sizeOne alt_sizes)
(foldr1 maxSize alt_sizes)
where
alt_sizes = map size_up_alt alts
alts_size (SizeIs tot tot_disc _tot_scrut)
(SizeIs max _max_disc max_scrut)
= SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` tot_disc) max_scrut
alts_size tot_size _ = tot_size
size_up (Case e _ _ alts) = foldr (addSize . size_up_alt)
(nukeScrutDiscount (size_up e))
alts
`addSizeN` 1
size_up_app (App fun arg) args
| isTypeArg arg = size_up_app fun args
| otherwise = size_up_app fun (arg:args)
`addSize` nukeScrutDiscount (size_up arg)
size_up_app (Var fun) args = size_up_call fun (length args)
size_up_app other args = size_up other `addSizeN` length args
size_up_call :: Id -> Int -> ExprSize
size_up_call fun n_val_args
= case idDetails fun of
FCallId _ -> sizeN opt_UF_DearOp
DataConWorkId dc -> conSize dc n_val_args
PrimOpId op -> primOpSize op n_val_args
_ -> funSize top_args fun n_val_args
size_up_alt (_con, _bndrs, rhs) = size_up rhs
addSizeN TooBig _ = TooBig
addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d
addSize TooBig _ = TooBig
addSize _ TooBig = TooBig
addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
= mkSizeIs bOMB_OUT_SIZE (n1 +# n2) (xs `unionBags` ys) (d1 +# d2)
\end{code}
\begin{code}
litSize :: Literal -> Int
litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
litSize _other = 0
funSize :: [Id] -> Id -> Int -> ExprSize
funSize top_args fun n_val_args
| fun `hasKey` buildIdKey = buildSize
| fun `hasKey` augmentIdKey = augmentSize
| otherwise = SizeIs (iUnbox size) arg_discount (iUnbox res_discount)
where
some_val_args = n_val_args > 0
arg_discount | some_val_args && fun `elem` top_args
= unitBag (fun, opt_UF_FunAppDiscount)
| otherwise = emptyBag
res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount
| otherwise = 0
size | some_val_args = 1 + n_val_args
| otherwise = 0
conSize :: DataCon -> Int -> ExprSize
conSize dc n_val_args
| n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1))
| isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1))
| otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1))
primOpSize :: PrimOp -> Int -> ExprSize
primOpSize op n_val_args
| not (primOpIsDupable op) = sizeN opt_UF_DearOp
| not (primOpOutOfLine op) = sizeN 1
| otherwise = sizeN n_val_args
buildSize :: ExprSize
buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
augmentSize :: ExprSize
augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
nukeScrutDiscount :: ExprSize -> ExprSize
nukeScrutDiscount (SizeIs n vs _) = SizeIs n vs (_ILIT(0))
nukeScrutDiscount TooBig = TooBig
lamScrutDiscount :: ExprSize -> ExprSize
lamScrutDiscount (SizeIs n vs _) = SizeIs n vs (iUnbox opt_UF_FunAppDiscount)
lamScrutDiscount TooBig = TooBig
\end{code}
Note [Function applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a function application (f a b)
If 'f' is an argument to the function being analysed,
and there's at least one value arg, record a FunAppDiscount for f
If the application if a PAP (arity > 2 in this example)
record a *result* discount (because inlining
with "extra" args in the call may mean that we now
get a saturated application)
Code for manipulating sizes
\begin{code}
data ExprSize = TooBig
| SizeIs FastInt
(Bag (Id,Int))
FastInt
instance Outputable ExprSize where
ppr TooBig = ptext (sLit "TooBig")
ppr (SizeIs a _ c) = brackets (int (iBox a) <+> int (iBox c))
mkSizeIs :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> ExprSize
mkSizeIs max n xs d | (n -# d) ># max = TooBig
| otherwise = SizeIs n xs d
maxSize :: ExprSize -> ExprSize -> ExprSize
maxSize TooBig _ = TooBig
maxSize _ TooBig = TooBig
maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1
| otherwise = s2
sizeZero, sizeOne :: ExprSize
sizeN :: Int -> ExprSize
sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0))
sizeOne = SizeIs (_ILIT(1)) emptyBag (_ILIT(0))
sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0))
\end{code}
%************************************************************************
%* *
\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
%* *
%************************************************************************
We have very limited information about an unfolding expression: (1)~so
many type arguments and so many value arguments expected
purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
a single integer. (3)~An ``argument info'' vector. For this, what we
have at the moment is a Boolean per argument position that says, ``I
will look with great favour on an explicit constructor in this
position.'' (4)~The ``discount'' to subtract if the expression
is being scrutinised.
Assuming we have enough type and value arguments (if not, we give up
immediately), then we see if the ``discounted size'' is below some
(semiarbitrary) threshold. It works like this: for every argument
position where we're looking for a constructor AND WE HAVE ONE in our
hands, we get a (again, semiarbitrary) discount [proportion to the
number of constructors in the type being scrutinized].
If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
and the expression in question will evaluate to a constructor, we use
the computed discount size *for the result only* rather than
computing the argument discounts. Since we know the result of
the expression is going to be taken apart, discounting its size
is more accurate (see @sizeExpr@ above for how this discount size
is computed).
We use this one to avoid exporting inlinings that we ``couldn't possibly
use'' on the other side. Can be overridden w/ flaggery.
Just the same as smallEnoughToInline, except that it has no actual arguments.
\begin{code}
couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of
UnfoldNever -> False
_ -> True
certainlyWillInline :: Unfolding -> Bool
certainlyWillInline (CoreUnfolding _ _ _ is_cheap _ (UnfoldIfGoodArgs n_vals _ size _))
= is_cheap && size (n_vals+1) <= opt_UF_UseThreshold
certainlyWillInline _
= False
smallEnoughToInline :: Unfolding -> Bool
smallEnoughToInline (CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
= size <= opt_UF_UseThreshold
smallEnoughToInline _
= False
\end{code}
%************************************************************************
%* *
\subsection{callSiteInline}
%* *
%************************************************************************
This is the key function. It decides whether to inline a variable at a call site
callSiteInline is used at call sites, so it is a bit more generous.
It's a very important function that embodies lots of heuristics.
A nonWHNF can be inlined if it doesn't occur inside a lambda,
and occurs exactly once or
occurs once in each branch of a case and is small
If the thing is in WHNF, there's no danger of duplicating work,
so we can inline if it occurs once, or is small
NOTE: we don't want to inline toplevel functions that always diverge.
It just makes the code bigger. Tt turns out that the convenient way to prevent
them inlining is to give them a NOINLINE pragma, which we do in
StrictAnal.addStrictnessInfoToTopId
\begin{code}
callSiteInline :: DynFlags
-> Bool
-> Id
-> Bool
-> [ArgSummary]
-> CallCtxt
-> Maybe CoreExpr
instance Outputable ArgSummary where
ppr TrivArg = ptext (sLit "TrivArg")
ppr NonTrivArg = ptext (sLit "NonTrivArg")
ppr ValueArg = ptext (sLit "ValueArg")
data CallCtxt = BoringCtxt
| ArgCtxt Bool
Int
| ValAppCtxt
| CaseCtxt
instance Outputable CallCtxt where
ppr BoringCtxt = ptext (sLit "BoringCtxt")
ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt")
ppr CaseCtxt = ptext (sLit "CaseCtxt")
ppr ValAppCtxt = ptext (sLit "ValAppCtxt")
callSiteInline dflags active_inline id lone_variable arg_infos cont_info
= case idUnfolding id of {
NoUnfolding -> Nothing ;
OtherCon _ -> Nothing ;
CompulsoryUnfolding unf_template -> Just unf_template ;
CoreUnfolding unf_template is_top is_value is_cheap is_expable guidance ->
let
result | yes_or_no = Just unf_template
| otherwise = Nothing
n_val_args = length arg_infos
yes_or_no = active_inline && is_cheap && consider_safe
consider_safe
= case guidance of
UnfoldNever -> False
UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
| uncond_inline -> True
| otherwise -> some_benefit && small_enough && inline_enough_args
where
uncond_inline
| n_vals_wanted == 0 = size == 0
| otherwise = enough_args && (size <= n_vals_wanted + 1)
enough_args = n_val_args >= n_vals_wanted
inline_enough_args =
not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args
some_benefit = any nonTriv arg_infos || really_interesting_cont
really_interesting_cont
| n_val_args < n_vals_wanted = False
| n_val_args == n_vals_wanted = interesting_saturated_call
| otherwise = True
interesting_saturated_call
= case cont_info of
BoringCtxt -> not is_top && n_vals_wanted > 0
CaseCtxt -> not lone_variable || not is_value
ArgCtxt {} -> n_vals_wanted > 0
ValAppCtxt -> True
small_enough = (size discount) <= opt_UF_UseThreshold
discount = computeDiscount n_vals_wanted arg_discounts
res_discount arg_infos cont_info
in
if dopt Opt_D_dump_inlinings dflags then
pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
(vcat [text "active:" <+> ppr active_inline,
text "arg infos" <+> ppr arg_infos,
text "interesting continuation" <+> ppr cont_info,
text "is value:" <+> ppr is_value,
text "is cheap:" <+> ppr is_cheap,
text "is expandable:" <+> ppr is_expable,
text "guidance" <+> ppr guidance,
text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
result
else
result
}
\end{code}
Note [Things to watch]
~~~~~~~~~~~~~~~~~~~~~~
* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }
Assume x is exported, so not inlined unconditionally.
Then we want x to inline unconditionally; no reason for it
not to, and doing so avoids an indirection.
* { x = I# 3; ....f x.... }
Make sure that x does not inline unconditionally!
Lest we get extra allocation.
Note [Nested functions]
~~~~~~~~~~~~~~~~~~~~~~~
If a function has a nested defn we also record somebenefit, on the
grounds that we are often able to eliminate the binding, and hence the
allocation, for the function altogether; this is good for join points.
But this only makes sense for *functions*; inlining a constructor
doesn't help allocation unless the result is scrutinised. UNLESS the
constructor occurs just once, albeit possibly in multiple case
branches. Then inlining it doesn't increase allocation, but it does
increase the chance that the constructor won't be allocated at all in
the branches that don't use it.
Note [Cast then apply]
~~~~~~~~~~~~~~~~~~~~~~
Consider
myIndex = __inline_me ( (/\a. <blah>) |> co )
co :: (forall a. a -> a) ~ (forall a. T a)
... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...
We need to inline myIndex to unravel this; but the actual call (myIndex a) has
no value arguments. The ValAppCtxt gives it enough incentive to inline.
Note [Inlining in ArgCtxt]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The condition (n_vals_wanted > 0) here is very important, because otherwise
we end up inlining toplevel stuff into useless places; eg
x = I# 3#
f = \y. g x
This can make a very big difference: it adds 16% to nofib 'integer' allocs,
and 20% to 'power'.
At one stage I replaced this condition by 'True' (leading to the above
slowdown). The motivation was test eyeball/inline1.hs; but that seems
to work ok now.
Note [Lone variables]
~~~~~~~~~~~~~~~~~~~~~
The "lone-variable" case is important. I spent ages messing about
with unsatisfactory varaints, but this is nice. The idea is that if a
variable appears all alone
as an arg of lazy fn, or rhs Stop
as scrutinee of a case Select
as arg of a strict fn ArgOf
AND
it is bound to a value
then we should not inline it (unless there is some other reason,
e.g. is is the sole occurrence). That is what is happening at
the use of 'lone_variable' in 'interesting_saturated_call'.
Why? At least in the casescrutinee situation, turning
let x = (a,b) in case x of y -> ...
into
let x = (a,b) in case (a,b) of y -> ...
and thence to
let x = (a,b) in let y = (a,b) in ...
is bad if the binding for x will remain.
Another example: I discovered that strings
were getting inlined straight back into applications of 'error'
because the latter is strict.
s = "foo"
f = \x -> ...(error s)...
Fundamentally such contexts should not encourage inlining because the
context can ``see'' the unfolding of the variable (e.g. case or a
RULE) so there's no gain. If the thing is bound to a value.
However, watch out:
* Consider this:
foo = _inline_ (\n. [n])
bar = _inline_ (foo 20)
baz = \n. case bar of { (m:_) -> m + n }
Here we really want to inline 'bar' so that we can inline 'foo'
and the whole thing unravels as it should obviously do. This is
important: in the NDP project, 'bar' generates a closure data
structure rather than a list.
* Even a type application or coercion isn't a lone variable.
Consider
case $fMonadST @ RealWorld of { :DMonad a b c -> c }
We had better inline that sucker! The case won't see through it.
For now, I'm treating treating a variable applied to types
in a *lazy* context "lone". The motivating example was
f = /\a. \x. BIG
g = /\a. \y. h (f a)
There's no advantage in inlining f here, and perhaps
a significant disadvantage. Hence some_val_args in the Stop case
\begin{code}
computeDiscount :: Int -> [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int
computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
= 1
+ length (take n_vals_wanted arg_infos)
+ round (opt_UF_KeenessFactor *
fromIntegral (arg_discount + res_discount'))
where
arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
mk_arg_discount _ TrivArg = 0
mk_arg_discount _ NonTrivArg = 1
mk_arg_discount discount ValueArg = discount
res_discount' = case cont_info of
BoringCtxt -> 0
CaseCtxt -> res_discount
_other -> 4 `min` res_discount
\end{code}
%************************************************************************
%* *
Interesting arguments
%* *
%************************************************************************
Note [Interesting arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An argument is interesting if it deserves a discount for unfoldings
with a discount in that argument position. The idea is to avoid
unfolding a function that is applied only to variables that have no
unfolding (i.e. they are probably lambda bound): f x y z There is
little point in inlining f here.
Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But
we must look through lets, eg (let x = e in C a b), because the let will
float, exposing the value, if we inline. That makes it different to
exprIsHNF.
Before 2009 we said it was interesting if the argument had *any* structure
at all; i.e. (hasSomeUnfolding v). But does too much inlining; see Trac #3016.
But we don't regard (f x y) as interesting, unless f is unsaturated.
If it's saturated and f hasn't inlined, then it's probably not going
to now!
\begin{code}
data ArgSummary = TrivArg
| NonTrivArg
| ValueArg
interestingArg :: CoreExpr -> ArgSummary
interestingArg e = go e 0
where
go (Lit {}) _ = ValueArg
go (Var v) n
| isDataConWorkId v = ValueArg
| idArity v > n = ValueArg
| n > 0 = NonTrivArg
| evald_unfolding = ValueArg
| otherwise = TrivArg
where
evald_unfolding = isEvaldUnfolding (idUnfolding v)
go (Type _) _ = TrivArg
go (App fn (Type _)) n = go fn n
go (App fn _) n = go fn (n+1)
go (Note _ a) n = go a n
go (Cast e _) n = go e n
go (Lam v e) n
| isTyVar v = go e n
| n>0 = go e (n1)
| otherwise = ValueArg
go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
go (Case {}) _ = NonTrivArg
nonTriv :: ArgSummary -> Bool
nonTriv TrivArg = False
nonTriv _ = True
\end{code}
%************************************************************************
%* *
The Very Simple Optimiser
%* *
%************************************************************************
\begin{code}
simpleOptExpr :: Subst -> CoreExpr -> CoreExpr
simpleOptExpr subst expr
= go subst (occurAnalyseExpr expr)
where
go subst (Var v) = lookupIdSubst subst v
go subst (App e1 e2) = App (go subst e1) (go subst e2)
go subst (Type ty) = Type (substTy subst ty)
go _ (Lit lit) = Lit lit
go subst (Note note e) = Note note (go subst e)
go subst (Cast e co) = Cast (go subst e) (substTy subst co)
go subst (Let bind body) = go_bind subst bind body
go subst (Lam bndr body) = Lam bndr' (go subst' body)
where
(subst', bndr') = substBndr subst bndr
go subst (Case e b ty as) = Case (go subst e) b'
(substTy subst ty)
(map (go_alt subst') as)
where
(subst', b') = substBndr subst b
go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
where
(subst', bndrs') = substBndrs subst bndrs
go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
(go subst' body)
where
(bndrs, rhss) = unzip prs
(subst', bndrs') = substRecBndrs subst bndrs
rhss' = map (go subst') rhss
go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
go_nonrec subst b (Type ty') body
| isTyVar b = go (extendTvSubst subst b ty') body
go_nonrec subst b r' body
| isId b
, exprIsTrivial r' || safe_to_inline (idOccInfo b)
= go (extendIdSubst subst b r') body
go_nonrec subst b r' body
= Let (NonRec b' r') (go subst' body)
where
(subst', b') = substBndr subst b
safe_to_inline :: OccInfo -> Bool
safe_to_inline IAmDead = True
safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
safe_to_inline (IAmALoopBreaker {}) = False
safe_to_inline NoOccInfo = False
\end{code}