find, unsurprisingly, a Core expression.
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module CoreUnfold (
Unfolding, UnfoldingGuidance, -- Abstract types
- noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,
- evaldUnfolding, mkOtherCon, otherCons,
- unfoldingTemplate, maybeUnfoldingTemplate,
- isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
- hasUnfolding, hasSomeUnfolding, neverUnfold,
+ noUnfolding, mkImplicitUnfolding,
+ mkTopUnfolding, mkUnfolding,
+ mkInlineRule, mkWwInlineRule,
+ mkCompulsoryUnfolding,
couldBeSmallEnoughToInline,
certainlyWillInline, smallEnoughToInline,
- callSiteInline, CallContInfo(..)
+ callSiteInline, CallCtxt(..)
) where
-#include "HsVersions.h"
-
import StaticFlags
import DynFlags
import CoreSyn
import PprCore () -- Instances
import OccurAnal
+import CoreSubst ( emptySubst, substTy, extendIdSubst, extendTvSubst
+ , lookupIdSubst, substBndr, substBndrs, substRecBndrs )
import CoreUtils
import Id
import DataCon
import Literal
import PrimOp
import IdInfo
-import Type
+import BasicTypes ( Arity )
+import Type hiding( substTy, extendTvSubst )
+import Maybes
import PrelNames
import Bag
import FastTypes
+import FastString
import Outputable
\end{code}
%************************************************************************
\begin{code}
+mkTopUnfolding :: CoreExpr -> Unfolding
mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
-mkUnfolding top_lvl expr
- = CoreUnfolding (occurAnalyseExpr expr)
- top_lvl
-
+mkImplicitUnfolding :: CoreExpr -> Unfolding
+-- For implicit Ids, do a tiny bit of optimising first
+mkImplicitUnfolding expr
+ = CoreUnfolding (simpleOptExpr expr)
+ True
(exprIsHNF expr)
- -- Already evaluated
-
(exprIsCheap expr)
- -- OK to inline inside a lambda
-
(calcUnfoldingGuidance opt_UF_CreationThreshold expr)
+
+mkInlineRule :: CoreExpr -> Arity -> Unfolding
+mkInlineRule expr arity
+ = InlineRule { uf_tmpl = simpleOptExpr expr,
+ uf_is_top = True, -- Conservative; this gets set more
+ -- accuately by the simplifier (slight hack)
+ -- in SimplEnv.substUnfolding
+ uf_arity = arity,
+ uf_is_value = exprIsHNF expr,
+ uf_worker = Nothing }
+
+mkWwInlineRule :: CoreExpr -> Arity -> Id -> Unfolding
+mkWwInlineRule expr arity wkr
+ = InlineRule { uf_tmpl = simpleOptExpr expr,
+ uf_is_top = True, -- Conservative; see mkInlineRule
+ uf_arity = arity,
+ uf_is_value = exprIsHNF expr,
+ uf_worker = Just wkr }
+
+mkUnfolding :: Bool -> CoreExpr -> Unfolding
+mkUnfolding top_lvl expr
+ = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
+ uf_is_top = top_lvl,
+ uf_is_value = exprIsHNF expr,
+ uf_is_cheap = exprIsCheap expr,
+ uf_guidance = calcUnfoldingGuidance opt_UF_CreationThreshold expr }
-- Sometimes during simplification, there's a large let-bound thing
-- which has been substituted, and so is now dead; so 'expr' contains
-- two copies of the thing while the occurrence-analysed expression doesn't
-- This can occasionally mean that the guidance is very pessimistic;
-- it gets fixed up next round
-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 g)
- = ptext SLIT("Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g,
- ppr e]
-
+mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= CompulsoryUnfolding (occurAnalyseExpr expr)
\end{code}
%************************************************************************
\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 -- bomb out if size gets bigger than this
-> CoreExpr -- expression to look at
-> UnfoldingGuidance
calcUnfoldingGuidance bOMB_OUT_SIZE expr
- = case collect_val_bndrs expr of { (inline, val_binders, body) ->
+ = case collectBinders expr of { (binders, body) ->
let
+ val_binders = filter isId binders
n_val_binders = length val_binders
-
- max_inline_size = n_val_binders+2
- -- The idea is that if there is an INLINE pragma (inline is True)
- -- and there's a big body, we give a size of n_val_binders+2. This
- -- This is just enough to fail the no-size-increase test in callSiteInline,
- -- so that INLINE things don't get inlined into entirely boring contexts,
- -- but no more.
-
in
case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of
-
- TooBig
- | not inline -> UnfoldNever
- -- A big function with an INLINE pragma must
- -- have an UnfoldIfGoodArgs guidance
- | otherwise -> UnfoldIfGoodArgs n_val_binders
- (map (const 0) val_binders)
- max_inline_size 0
-
+ TooBig -> UnfoldNever
SizeIs size cased_args scrut_discount
- -> UnfoldIfGoodArgs
- n_val_binders
- (map discount_for val_binders)
- final_size
- (iBox scrut_discount)
+ -> UnfoldIfGoodArgs { ug_arity = n_val_binders
+ , ug_args = map discount_for val_binders
+ , ug_size = iBox size
+ , ug_res = iBox scrut_discount }
where
- boxed_size = iBox size
-
- final_size | inline = boxed_size `min` max_inline_size
- | otherwise = boxed_size
-
- -- Sometimes an INLINE thing is smaller than n_val_binders+2.
- -- A particular case in point is a constructor, which has size 1.
- -- We want to inline this regardless, hence the `min`
-
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
- -- We need to be a bit careful about how we collect the
- -- value binders. In ptic, if we see
- -- __inline_me (\x y -> e)
- -- We want to say "2 value binders". Why? So that
- -- we take account of information given for the arguments
-
- go inline 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}
\begin{code}
sizeExpr bOMB_OUT_SIZE top_args expr
= size_up expr
where
- size_up (Type t) = sizeZero -- Types cost nothing
- size_up (Var v) = sizeOne
-
- size_up (Note InlineMe body) = sizeOne -- Inline notes make it look very small
- -- This can be important. If you have an instance decl like this:
- -- instance Foo a => Foo [a] where
- -- {-# INLINE op1, op2 #-}
- -- op1 = ...
- -- op2 = ...
- -- then we'll get a dfun which is a pair of two INLINE lambdas
-
- size_up (Note _ body) = size_up body -- Other notes cost nothing
-
- size_up (Cast e _) = size_up e
-
- size_up (App fun (Type t)) = size_up fun
+ size_up (Type _) = sizeZero -- Types cost nothing
+ size_up (Var _) = sizeOne
+ size_up (Note _ body) = size_up body -- Notes cost nothing
+ size_up (Cast e _) = size_up e
+ size_up (App fun (Type _)) = size_up fun
size_up (App fun arg) = size_up_app fun [arg]
size_up (Lit lit) = sizeN (litSize lit)
-- alts_size tries to compute a good discount for
-- the case when we are scrutinising an argument variable
- alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives
- (SizeIs max max_disc max_scrut) -- Size of biggest alternative
+ alts_size (SizeIs tot _tot_disc _tot_scrut) -- Size of all alternatives
+ (SizeIs max max_disc max_scrut) -- Size of biggest alternative
= SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` max_disc) max_scrut
-- If the variable is known, we produce a discount that
-- will take us back to 'max', the size of rh largest alternative
= case globalIdDetails fun of
DataConWorkId dc -> conSizeN dc (valArgCount args)
- FCallId fc -> sizeN opt_UF_DearOp
+ FCallId _ -> sizeN opt_UF_DearOp
PrimOpId op -> primOpSize op (valArgCount args)
-- foldr addSize (primOpSize op) (map arg_discount args)
-- At one time I tried giving an arg-discount if a primop
-- if we know nothing about it. And just having it in a primop
-- doesn't help at all if we don't know something more.
- other -> fun_discount fun `addSizeN`
+ _ -> fun_discount fun `addSizeN`
(1 + length (filter (not . exprIsTrivial) args))
-- The 1+ is for the function itself
-- Add 1 for each non-trivial arg;
-- We should really only count for non-prim-typed args in the
-- general case, but that seems too much like hard work
- size_up_fun other args = size_up other
+ size_up_fun other _ = size_up other
------------
- size_up_alt (con, bndrs, rhs) = size_up rhs
+ size_up_alt (_con, _bndrs, rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
------------
-- We want to record if we're case'ing, or applying, an argument
fun_discount v | v `elem` top_args = SizeIs (_ILIT(0)) (unitBag (v, opt_UF_FunAppDiscount)) (_ILIT(0))
- fun_discount other = sizeZero
+ fun_discount _ = sizeZero
------------
-- These addSize things have to be here because
-- tup = (a_1, ..., a_99)
-- x = case tup of ...
--
+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
+conSizeN :: DataCon ->Int -> ExprSize
+
sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0))
sizeOne = SizeIs (_ILIT(1)) emptyBag (_ILIT(0))
sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0))
-- f x y z = case op# x y z of { s -> (# s, () #) }
-- and f wasn't getting inlined
+primOpSize :: PrimOp -> Int -> ExprSize
primOpSize op n_args
| not (primOpIsDupable op) = sizeN opt_UF_DearOp
| not (primOpOutOfLine op) = sizeN (2 - n_args)
-- and there's a good chance it'll get inlined back into C's RHS. Urgh!
| otherwise = sizeOne
+buildSize :: ExprSize
buildSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))
-- We really want to inline applications of build
-- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
-- build is saturated (it usually is). The "-2" discounts for the \c n,
-- The "4" is rather arbitrary.
+augmentSize :: ExprSize
augmentSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))
-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
-- e plus ys. The -2 accounts for the \cn
-
-nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs (_ILIT(0))
-nukeScrutDiscount TooBig = TooBig
+
+nukeScrutDiscount :: ExprSize -> ExprSize
+nukeScrutDiscount (SizeIs n vs _) = SizeIs n vs (_ILIT(0))
+nukeScrutDiscount TooBig = TooBig
-- When we return a lambda, give a discount if it's used (applied)
-lamScrutDiscount (SizeIs n vs d) = case opt_UF_FunAppDiscount of { d -> SizeIs n vs (iUnbox d) }
-lamScrutDiscount TooBig = TooBig
+lamScrutDiscount :: ExprSize -> ExprSize
+lamScrutDiscount (SizeIs n vs _) = case opt_UF_FunAppDiscount of { d -> SizeIs n vs (iUnbox d) }
+lamScrutDiscount TooBig = TooBig
\end{code}
\begin{code}
couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of
- UnfoldNever -> False
- other -> True
+ UnfoldNever -> False
+ _ -> True
certainlyWillInline :: Unfolding -> Bool
-- Sees if the unfolding is pretty certain to inline
-certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _))
+certainlyWillInline (CompulsoryUnfolding {}) = True
+certainlyWillInline (InlineRule {}) = True
+certainlyWillInline (CoreUnfolding
+ { uf_is_cheap = is_cheap
+ , uf_guidance = UnfoldIfGoodArgs {ug_arity = n_vals, ug_size = size}})
= is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
-certainlyWillInline other
+certainlyWillInline _
= False
smallEnoughToInline :: Unfolding -> Bool
-smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
+smallEnoughToInline (CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_size = size}})
= size <= opt_UF_UseThreshold
-smallEnoughToInline other
+smallEnoughToInline _
= False
\end{code}
so we can inline if it occurs once, or is small
NOTE: we don't want to inline top-level functions that always diverge.
-It just makes the code bigger. It turns out that the convenient way to prevent
+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
-> Id -- The Id
-> Bool -- True if there are are no arguments at all (incl type args)
-> [Bool] -- One for each value arg; True if it is interesting
- -> CallContInfo -- True <=> continuation is interesting
+ -> CallCtxt -- True <=> continuation is interesting
-> Maybe CoreExpr -- Unfolding, if any
-data CallContInfo = BoringCont
- | InterestingCont -- Somewhat interesting
- | CaseCont -- Very interesting; the argument of a case
- -- that decomposes its scrutinee
+data CallCtxt = BoringCtxt
+
+ | ArgCtxt Bool -- We're somewhere in the RHS of function with rules
+ -- => be keener to inline
+ Int -- We *are* the argument of a function with this arg discount
+ -- => be keener to inline
+ -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt
+
+ | 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
-instance Outputable CallContInfo where
- ppr BoringCont = ptext SLIT("BoringCont")
- ppr InterestingCont = ptext SLIT("InterestingCont")
- ppr CaseCont = ptext SLIT("CaseCont")
+ | CaseCtxt -- We're the scrutinee of a case
+ -- that decomposes its scrutinee
+
+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 {
+ = let
+ n_val_args = length arg_infos
+ in
+ case idUnfolding id of {
NoUnfolding -> Nothing ;
- OtherCon cs -> Nothing ;
+ OtherCon _ -> Nothing ;
CompulsoryUnfolding unf_template -> Just unf_template ;
-- CompulsoryUnfolding => there is no top-level binding
-- compulsory unfoldings (see MkId.lhs).
-- We don't allow them to be inactive
- CoreUnfolding unf_template is_top is_value is_cheap guidance ->
+ InlineRule { uf_tmpl = unf_template, uf_arity = arity, uf_is_top = is_top
+ , uf_is_value = is_value, uf_worker = mb_worker }
+ -> let yes_or_no | not active_inline = False
+ | n_val_args < arity = yes_unsat -- Not enough value args
+ | n_val_args == arity = yes_exact -- Exactly saturated
+ | otherwise = True -- Over-saturated
+ result | yes_or_no = Just unf_template
+ | otherwise = Nothing
+
+ -- See Note [Inlining an InlineRule]
+ is_wrapper = isJust mb_worker
+ yes_unsat | is_wrapper = or arg_infos
+ | otherwise = False
+
+ yes_exact = or arg_infos || interesting_saturated_call
+ interesting_saturated_call
+ = case cont_info of
+ BoringCtxt -> not is_top -- Note [Nested functions]
+ CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables]
+ ArgCtxt {} -> arity > 0 -- Note [Inlining in ArgCtxt]
+ ValAppCtxt -> True -- Note [Cast then apply]
+ in
+ if dopt Opt_D_dump_inlinings dflags then
+ pprTrace ("Considering InlineRule for: " ++ showSDoc (ppr id))
+ (vcat [text "active:" <+> ppr active_inline,
+ text "arg infos" <+> ppr arg_infos,
+ text "interesting call" <+> ppr interesting_saturated_call,
+ text "is value:" <+> ppr is_value,
+ text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
+ result
+ else result ;
+
+ CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top, uf_is_value = is_value,
+ uf_is_cheap = is_cheap, uf_guidance = 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
-- We consider even the once-in-one-branch
-- occurrences, because they won't all have been
-- work-duplication issue (the caller checks that).
= case guidance of
UnfoldNever -> False
- UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
+ UnfoldIfGoodArgs { ug_arity = n_vals_wanted, ug_args = arg_discounts
+ , ug_res = res_discount, ug_size = size }
| enough_args && size <= (n_vals_wanted + 1)
-- Inline unconditionally if there no size increase
-- Size of call is n_vals_wanted (+1 for the function)
-> True
| otherwise
- -> some_benefit && small_enough
+ -> some_benefit && small_enough && inline_enough_args
+
where
enough_args = n_val_args >= n_vals_wanted
- -- Note [Enough args]
+ inline_enough_args =
+ not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args
+
some_benefit = or arg_infos || really_interesting_cont
-- There must be something interesting
interesting_saturated_call
= case cont_info of
- BoringCont -> not is_top && n_vals_wanted > 0 -- Note [Nested functions]
- CaseCont -> not lone_variable || not is_value -- Note [Lone variables]
- InterestingCont -> True -- Something else interesting about continuation
+ BoringCtxt -> not is_top && n_vals_wanted > 0 -- Note [Nested functions]
+ CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables]
+ ArgCtxt {} -> n_vals_wanted > 0 -- Note [Inlining in ArgCtxt]
+ ValAppCtxt -> True -- Note [Cast then apply]
small_enough = (size - discount) <= opt_UF_UseThreshold
discount = computeDiscount n_vals_wanted arg_discounts
res_discount' arg_infos
res_discount' = case cont_info of
- BoringCont -> 0
- CaseCont -> res_discount
- InterestingCont -> 4 `min` res_discount
+ BoringCtxt -> 0
+ CaseCtxt -> res_discount
+ _other -> 4 `min` res_discount
-- res_discount can be very large when a function returns
-- construtors; but we only want to invoke that large discount
-- when there's a case continuation.
in
if dopt Opt_D_dump_inlinings dflags then
- pprTrace "Considering inlining"
- (ppr id <+> vcat [text "active:" <+> ppr active_inline,
- text "arg infos" <+> ppr arg_infos,
- text "interesting continuation" <+> ppr cont_info <+>
- ppr n_val_args,
- text "is value:" <+> ppr is_value,
- text "is cheap:" <+> ppr is_cheap,
- text "guidance" <+> ppr guidance,
- text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
+ 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 "guidance" <+> ppr guidance,
+ text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
result
else
result
}
\end{code}
-Note [Enough args]
-~~~~~~~~~~~~~~~~~~
-At one stage we considered only inlining a function that has enough
-arguments to saturate its arity. But we can lose from this. For
-example (f . g) might not be a saturated application of (.), but
-nevertheless f and g might usefully optimise with each other if we
-inlined (.) and f and g.
+Note [Inlining an InlineRule]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An InlineRules is used for
+ (a) pogrammer INLINE pragmas
+ (b) inlinings from worker/wrapper
+
+For (a) the RHS may be large, and our contract is that we *only* inline
+when the function is applied to all the arguments on the LHS of the
+source-code defn. (The uf_arity in the rule.)
+
+However for worker/wrapper it may be worth inlining even if the
+arity is not satisfied (as we do in the CoreUnfolding case) so we don't
+require saturation.
-Current story (Jan08): inline even if not saturated.
Note [Nested functions]
~~~~~~~~~~~~~~~~~~~~~~~
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 top-level 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
+slow-down). 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
mk_arg_discount discount is_evald | is_evald = discount
| otherwise = 0
\end{code}
+
+%************************************************************************
+%* *
+ The Very Simple Optimiser
+%* *
+%************************************************************************
+
+
+\begin{code}
+simpleOptExpr :: CoreExpr -> CoreExpr
+-- Return an occur-analysed and slightly optimised expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once,
+-- or wheere the RHS is trivial
+
+simpleOptExpr expr
+ = go emptySubst (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
+ -- let a::* = TYPE ty in <body>
+ go_nonrec subst b r' body
+ | isId b -- let x = e in <body>
+ , 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
+
+ ----------------------
+ -- Unconditionally safe to inline
+ 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}
\ No newline at end of file