%
+% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1994-1998
%
-\section[CoreUnfold]{Core-syntax unfoldings}
+
+Core-syntax unfoldings
Unfoldings (which can travel across module boundaries) are in Core
syntax (namely @CoreExpr@s).
couldBeSmallEnoughToInline,
certainlyWillInline, smallEnoughToInline,
- callSiteInline
+ callSiteInline, CallCtxt(..)
+
) where
#include "HsVersions.h"
-import StaticFlags ( opt_UF_CreationThreshold, opt_UF_UseThreshold,
- opt_UF_FunAppDiscount, opt_UF_KeenessFactor,
- opt_UF_DearOp,
- )
-import DynFlags ( DynFlags, DynFlag(..), dopt )
+import StaticFlags
+import DynFlags
import CoreSyn
import PprCore () -- Instances
-import OccurAnal ( occurAnalyseExpr )
-import CoreUtils ( exprIsHNF, exprIsCheap, exprIsTrivial )
-import Id ( Id, idType, isId,
- idUnfolding, globalIdDetails
- )
-import DataCon ( isUnboxedTupleCon )
-import Literal ( litSize )
-import PrimOp ( primOpIsDupable, primOpOutOfLine )
-import IdInfo ( OccInfo(..), GlobalIdDetails(..) )
-import Type ( isUnLiftedType )
-import PrelNames ( hasKey, buildIdKey, augmentIdKey )
+import OccurAnal
+import CoreUtils
+import Id
+import DataCon
+import Literal
+import PrimOp
+import IdInfo
+import Type
+import PrelNames
import Bag
import FastTypes
+import FastString
import Outputable
-#if __GLASGOW_HASKELL__ >= 404
-import GLAEXTS ( Int# )
-#endif
\end{code}
%************************************************************************
\begin{code}
+mkTopUnfolding :: CoreExpr -> Unfolding
mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
+mkUnfolding :: Bool -> CoreExpr -> Unfolding
mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseExpr expr)
top_lvl
= 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}
-- 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 _ 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 :: Int# -- Bomb out if it gets bigger than this
+sizeExpr :: FastInt -- Bomb out if it gets bigger than this
-> [Id] -- Arguments; we're interested in which of these
-- get case'd
-> CoreExpr
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 (Type _) = sizeZero -- Types cost nothing
+ size_up (Var _) = sizeOne
- size_up (Note InlineMe body) = sizeOne -- Inline notes make it look very small
+ size_up (Note InlineMe _) = 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 #-}
-- 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 (Note _ body) = size_up body -- Other notes cost nothing
- size_up (Cast e _) = size_up e
+ size_up (Cast e _) = size_up e
- size_up (App fun (Type t)) = size_up fun
+ 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)
case alts of
- [alt] -> size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 0#
+ [alt] -> size_up_alt alt `addSize` SizeIs (_ILIT(0)) (unitBag (v, 1)) (_ILIT(0))
-- We want to make wrapper-style evaluation look cheap, so that
-- when we inline a wrapper it doesn't make call site (much) bigger
-- Otherwise we get nasty phase ordering stuff:
-- 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
- = SizeIs tot (unitBag (v, iBox (_ILIT 1 +# tot -# max)) `unionBags` max_disc) max_scrut
+ 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
-- The 1+ is a little discount for reduced allocation in the caller
alts_size tot_size _ = tot_size
--- gaw 2004
size_up (Case e _ _ alts) = nukeScrutDiscount (size_up e) `addSize`
foldr (addSize . size_up_alt) sizeZero alts
-- We don't charge for the case itself
= 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 0# (unitBag (v, opt_UF_FunAppDiscount)) 0#
- fun_discount other = sizeZero
+ fun_discount v | v `elem` top_args = SizeIs (_ILIT(0)) (unitBag (v, opt_UF_FunAppDiscount)) (_ILIT(0))
+ 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 = SizeIs (_ILIT 0) emptyBag (_ILIT 0)
-sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0)
-sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT 0)
+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))
conSizeN dc n
- | isUnboxedTupleCon dc = SizeIs (_ILIT 0) emptyBag (iUnbox n +# _ILIT 1)
- | otherwise = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1)
+ | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n +# _ILIT(1))
+ | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n +# _ILIT(1))
-- Treat constructors as size 1; we are keen to expose them
-- (and we charge separately for their args). We can't treat
-- them as size zero, else we find that (iBox x) has size 1,
-- 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 = SizeIs (-2#) emptyBag 4#
+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)
-- Indeed, we should add a result_discount becuause build is
-- build is saturated (it usually is). The "-2" discounts for the \c n,
-- The "4" is rather arbitrary.
-augmentSize = SizeIs (-2#) emptyBag 4#
+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 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 _))
= is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
-certainlyWillInline other
+certainlyWillInline _
= False
smallEnoughToInline :: Unfolding -> Bool
smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
= size <= opt_UF_UseThreshold
-smallEnoughToInline other
+smallEnoughToInline _
= False
\end{code}
\begin{code}
callSiteInline :: DynFlags
-> Bool -- True <=> the Id can be inlined
- -> OccInfo
-> 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
- -> Bool -- True <=> continuation is interesting
+ -> CallCtxt -- True <=> continuation is interesting
-> Maybe CoreExpr -- Unfolding, if any
-callSiteInline dflags active_inline occ id arg_infos interesting_cont
+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
+
+ | 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")
+
+callSiteInline dflags active_inline id lone_variable arg_infos cont_info
= case idUnfolding id of {
NoUnfolding -> Nothing ;
- OtherCon cs -> Nothing ;
+ OtherCon _ -> Nothing ;
CompulsoryUnfolding unf_template -> Just unf_template ;
-- CompulsoryUnfolding => there is no top-level binding
n_val_args = length arg_infos
- yes_or_no
- | not active_inline = False
- | otherwise = case occ of
- IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False
- IAmALoopBreaker False -> False -- Note [RulesOnly] in OccurAnal
- --OneOcc in_lam _ _ -> (not in_lam || is_cheap) && consider_safe True
- other -> is_cheap && consider_safe False
+ 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
-- caught by preInlineUnconditionally. In particular,
-- pre-inline will not have inlined it for fear of
-- invalidating the occurrence info in the rhs.
- consider_safe once
+ consider_safe
-- consider_safe decides whether it's a good idea to
-- inline something, given that there's no
-- work-duplication issue (the caller checks that).
= case guidance of
UnfoldNever -> False
UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
-
| 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)
-> some_benefit && small_enough
where
- some_benefit = or arg_infos || really_interesting_cont ||
- (not is_top && ({- once || -} (n_vals_wanted > 0 && enough_args)))
- -- [was (once && not in_lam)]
- -- If it occurs more than once, there must be
- -- something interesting about some argument, or the
- -- result context, to make it worth inlining
- --
- -- If a function has a nested defn we also record
- -- some-benefit, 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.
-
- enough_args = n_val_args >= n_vals_wanted
- really_interesting_cont | n_val_args < n_vals_wanted = False -- Too few args
- | n_val_args == n_vals_wanted = interesting_cont
- | otherwise = True -- Extra args
+ enough_args = n_val_args >= n_vals_wanted
+
+ some_benefit = or arg_infos || really_interesting_cont
+ -- There must be something interesting
+ -- about some argument, or the result
+ -- context, to make it worth inlining
+
+ really_interesting_cont
+ | n_val_args < n_vals_wanted = False -- Too few args
+ | n_val_args == n_vals_wanted = interesting_saturated_call
+ | otherwise = True -- Extra args
-- really_interesting_cont tells if the result of the
-- call is in an interesting context.
+ interesting_saturated_call
+ = case cont_info of
+ BoringCtxt -> not is_top && n_vals_wanted > 0 -- Note [Nested functions]
+ CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables]
+ ArgCtxt {} -> True
+ -- Was: n_vals_wanted > 0; but see test eyeball/inline1.hs
+
small_enough = (size - discount) <= opt_UF_UseThreshold
- discount = computeDiscount n_vals_wanted arg_discounts res_discount
- arg_infos really_interesting_cont
+ discount = computeDiscount n_vals_wanted arg_discounts
+ res_discount' arg_infos
+ res_discount' = case cont_info of
+ BoringCtxt -> 0
+ CaseCtxt -> res_discount
+ ArgCtxt _ _ -> 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.
+ -- Otherwise we, rather arbitrarily, threshold it. Yuk.
+ -- But we want to aovid inlining large functions that return
+ -- constructors into contexts that are simply "interesting"
in
if dopt Opt_D_dump_inlinings dflags then
pprTrace "Considering inlining"
(ppr id <+> vcat [text "active:" <+> ppr active_inline,
- text "occ info:" <+> ppr occ,
text "arg infos" <+> ppr arg_infos,
- text "interesting continuation" <+> ppr interesting_cont,
+ text "interesting continuation" <+> ppr cont_info,
text "is value:" <+> ppr is_value,
text "is cheap:" <+> ppr is_cheap,
text "guidance" <+> ppr guidance,
else
result
}
+\end{code}
+
+Note [Nested functions]
+~~~~~~~~~~~~~~~~~~~~~~~
+If a function has a nested defn we also record some-benefit, 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 [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 case-scrutinee 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
-computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int
-computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
+\begin{code}
+computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Int
+computeDiscount n_vals_wanted arg_discounts result_discount arg_infos
-- We multiple the raw discounts (args_discount and result_discount)
-- ty opt_UnfoldingKeenessFactor because the former have to do with
-- *size* whereas the discounts imply that there's some extra
mk_arg_discount discount is_evald | is_evald = discount
| otherwise = 0
-
- -- Don't give a result discount unless there are enough args
- result_discount | result_used = res_discount -- Over-applied, or case scrut
- | otherwise = 0
\end{code}
projects / ghc-hetmet.git / blobdiff