X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUnfold.lhs;h=d57f1886fc0377e7b7d91397a2c169374a9915a2;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=239cd1d5df72e91d5d3a40afe97c99402d14eb21;hpb=8d873902b0ba7e267089f9e1faf690368670fe62;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 239cd1d..d57f188 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -17,51 +17,43 @@ module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding, - mkOtherCon, otherCons, + evaldUnfolding, mkOtherCon, otherCons, unfoldingTemplate, maybeUnfoldingTemplate, isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, + hasUnfolding, hasSomeUnfolding, neverUnfold, couldBeSmallEnoughToInline, - certainlyWillInline, - okToUnfoldInHiFile, + certainlyWillInline, smallEnoughToInline, - callSiteInline, blackListed + callSiteInline ) where #include "HsVersions.h" -import CmdLineOpts ( opt_UF_CreationThreshold, - opt_UF_UseThreshold, - opt_UF_ScrutConDiscount, - opt_UF_FunAppDiscount, - opt_UF_PrimArgDiscount, - opt_UF_KeenessFactor, - opt_UF_CheapOp, opt_UF_DearOp, - opt_UnfoldCasms, opt_PprStyle_Debug, - opt_D_dump_inlinings +import StaticFlags ( opt_UF_CreationThreshold, opt_UF_UseThreshold, + opt_UF_FunAppDiscount, opt_UF_KeenessFactor, + opt_UF_DearOp, ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn import PprCore ( pprCoreExpr ) -import OccurAnal ( occurAnalyseGlobalExpr ) -import CoreUtils ( exprIsValue, exprIsCheap, exprIsBottom, exprIsTrivial ) -import Id ( Id, idType, idFlavour, isId, idWorkerInfo, - idSpecialisation, idInlinePragma, idUnfolding, - isPrimOpId_maybe +import OccurAnal ( occurAnalyseExpr ) +import CoreUtils ( exprIsHNF, exprIsCheap, exprIsTrivial ) +import Id ( Id, idType, isId, + idUnfolding, globalIdDetails ) -import VarSet -import Literal ( isLitLitLit ) -import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm ) -import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), - insideLam, workerExists, isNeverInlinePrag - ) -import Type ( splitFunTy_maybe, isUnLiftedType ) -import Unique ( Unique, buildIdKey, augmentIdKey, hasKey ) +import DataCon ( isUnboxedTupleCon ) +import Literal ( litSize ) +import PrimOp ( primOpIsDupable, primOpOutOfLine ) +import IdInfo ( OccInfo(..), GlobalIdDetails(..) ) +import Type ( isUnLiftedType ) +import PrelNames ( hasKey, buildIdKey, augmentIdKey ) import Bag +import FastTypes import Outputable #if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) +import GLAEXTS ( Int# ) #endif \end{code} @@ -76,11 +68,15 @@ import GlaExts ( fromInt ) mkTopUnfolding expr = mkUnfolding True {- Top level -} expr mkUnfolding top_lvl expr - = CoreUnfolding (occurAnalyseGlobalExpr expr) + = CoreUnfolding (occurAnalyseExpr expr) top_lvl + + (exprIsHNF expr) + -- Already evaluated + (exprIsCheap expr) - (exprIsValue expr) - (exprIsBottom expr) + -- OK to inline inside a lambda + (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 @@ -92,7 +88,7 @@ mkUnfolding top_lvl expr -- it gets fixed up next round mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = CompulsoryUnfolding (occurAnalyseGlobalExpr expr) + = CompulsoryUnfolding (occurAnalyseExpr expr) \end{code} @@ -131,13 +127,13 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr -- but no more. in - case (sizeExpr bOMB_OUT_SIZE val_binders body) of + 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 - | inline -> UnfoldIfGoodArgs n_val_binders + | otherwise -> UnfoldIfGoodArgs n_val_binders (map (const 0) val_binders) max_inline_size 0 @@ -146,9 +142,9 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr n_val_binders (map discount_for val_binders) final_size - (I# scrut_discount) + (iBox scrut_discount) where - boxed_size = I# size + boxed_size = iBox size final_size | inline = boxed_size `min` max_inline_size | otherwise = boxed_size @@ -175,24 +171,32 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr \end{code} \begin{code} -sizeExpr :: Int -- Bomb out if it gets bigger than this +sizeExpr :: Int# -- Bomb out if it gets bigger than this -> [Id] -- Arguments; we're interested in which of these -- get case'd -> CoreExpr -> ExprSize -sizeExpr (I# bOMB_OUT_SIZE) top_args expr +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 _ body) = size_up body -- Notes cost nothing + 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 (App fun (Type t)) = size_up fun - size_up (App fun arg) = size_up_app fun [arg] + size_up (Note _ body) = size_up body -- Other notes cost nothing - size_up (Lit lit) = sizeOne + size_up (App fun (Type t)) = size_up fun + size_up (App fun arg) = size_up_app fun [arg] + + size_up (Lit lit) = sizeN (litSize lit) size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1) | otherwise = size_up e @@ -211,45 +215,57 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr where rhs_size = foldr (addSize . size_up . snd) sizeZero pairs - -- 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: - -- f x = g x x - -- h y = ...(f e)... - -- If we inline g's wrapper, f looks big, and doesn't get inlined - -- into h; if we inline f first, while it looks small, then g's - -- wrapper will get inlined later anyway. To avoid this nasty - -- ordering difference, we make (case a of (x,y) -> ...) look free. - size_up (Case (Var v) _ [alt]) - | v `elem` top_args - = size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 0# + size_up (Case (Var v) _ _ alts) + | v `elem` top_args -- We are scrutinising an argument variable + = +{- I'm nuking this special case; BUT see the comment with case alternatives. + + (a) It's too eager. We don't want to inline a wrapper into a + context with no benefit. + E.g. \ x. f (x+x) no point in inlining (+) here! + + (b) It's ineffective. Once g's wrapper is inlined, its case-expressions + aren't scrutinising arguments any more + + case alts of + + [alt] -> size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 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: + -- f x = g x x + -- h y = ...(f e)... + -- If we inline g's wrapper, f looks big, and doesn't get inlined + -- into h; if we inline f first, while it looks small, then g's + -- wrapper will get inlined later anyway. To avoid this nasty + -- ordering difference, we make (case a of (x,y) -> ...), + -- *where a is one of the arguments* look free. + + other -> +-} + alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the scrutinee + (foldr1 maxSize alt_sizes) + -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself - | otherwise - = size_up_alt alt - - -- Scrutinising one of the argument variables, - -- with more than one alternative - size_up (Case (Var v) _ alts) - | v `elem` top_args - = alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the scrutinee - (foldr1 maxSize alt_sizes) + where alt_sizes = map size_up_alt alts + -- 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, I# (1# +# tot -# max)) `unionBags` max_disc) max_scrut + = 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 - - size_up (Case e _ alts) = nukeScrutDiscount (size_up e) `addSize` - foldr (addSize . size_up_alt) sizeZero alts +-- 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 -- It's a strict thing, and the price of the call -- is paid by scrut. Also consider @@ -275,9 +291,10 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr | fun `hasKey` buildIdKey = buildSize | fun `hasKey` augmentIdKey = augmentSize | otherwise - = case idFlavour fun of - DataConId dc -> conSizeN (valArgCount args) + = case globalIdDetails fun of + DataConWorkId dc -> conSizeN dc (valArgCount args) + FCallId fc -> 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 @@ -301,67 +318,78 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr ------------ size_up_alt (con, bndrs, rhs) = size_up rhs - -- Don't charge for args, so that wrappers look cheap + -- 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 other = sizeZero ------------ -- These addSize things have to be here because -- I don't want to give them bOMB_OUT_SIZE as an argument - addSizeN TooBig _ = TooBig - addSizeN (SizeIs n xs d) (I# m) - | n_tot ># bOMB_OUT_SIZE = TooBig - | otherwise = SizeIs n_tot xs d - where - n_tot = n +# m + 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) - | n_tot ># bOMB_OUT_SIZE = TooBig - | otherwise = SizeIs n_tot xys d_tot - where - n_tot = n1 +# n2 - d_tot = d1 +# d2 - xys = xs `unionBags` ys + 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} Code for manipulating sizes \begin{code} - data ExprSize = TooBig - | SizeIs Int# -- Size found + | SizeIs FastInt -- Size found (Bag (Id,Int)) -- Arguments cased herein, and discount for each such - Int# -- Size to subtract if result is scrutinised + FastInt -- Size to subtract if result is scrutinised -- by a case expression -isTooBig TooBig = True -isTooBig _ = False - +-- subtract the discount before deciding whether to bale out. eg. we +-- want to inline a large constructor application into a selector: +-- tup = (a_1, ..., a_99) +-- x = case tup of ... +-- +mkSizeIs max n xs d | (n -# d) ># max = TooBig + | otherwise = SizeIs n xs d + maxSize TooBig _ = TooBig maxSize _ TooBig = TooBig maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 | otherwise = s2 -sizeZero = SizeIs 0# emptyBag 0# -sizeOne = SizeIs 1# emptyBag 0# -sizeTwo = SizeIs 2# emptyBag 0# -sizeN (I# n) = SizeIs n emptyBag 0# -conSizeN (I# n) = SizeIs 1# emptyBag (n +# 1#) +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) -- 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 (I# x) has size 1, + -- them as size zero, else we find that (iBox x) has size 1, -- which is the same as a lone variable; and hence 'v' will - -- always be replaced by (I# x), where v is bound to I# x. + -- always be replaced by (iBox x), where v is bound to iBox x. + -- + -- However, unboxed tuples count as size zero + -- I found occasions where we had + -- f x y z = case op# x y z of { s -> (# s, () #) } + -- and f wasn't getting inlined primOpSize op n_args | not (primOpIsDupable op) = sizeN opt_UF_DearOp - | not (primOpOutOfLine op) = sizeZero -- These are good to inline + | not (primOpOutOfLine op) = sizeN (2 - n_args) + -- Be very keen to inline simple primops. + -- We give a discount of 1 for each arg so that (op# x y z) costs 2. + -- We can't make it cost 1, else we'll inline let v = (op# x y z) + -- at every use of v, which is excessive. + -- + -- A good example is: + -- let x = +# p q in C {x} + -- Even though x get's an occurrence of 'many', its RHS looks cheap, + -- and there's a good chance it'll get inlined back into C's RHS. Urgh! | otherwise = sizeOne buildSize = SizeIs (-2#) emptyBag 4# @@ -380,7 +408,7 @@ nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 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 { I# d -> SizeIs n vs d } +lamScrutDiscount (SizeIs n vs d) = case opt_UF_FunAppDiscount of { d -> SizeIs n vs (iUnbox d) } lamScrutDiscount TooBig = TooBig \end{code} @@ -425,52 +453,20 @@ couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold UnfoldNever -> False other -> True -certainlyWillInline :: Id -> Bool - -- Sees if the Id is pretty certain to inline -certainlyWillInline v - = case idUnfolding v of - - CoreUnfolding _ _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _) - -> is_value - && size - (n_vals +1) <= opt_UF_UseThreshold - - other -> False -\end{code} - -@okToUnfoldInHifile@ is used when emitting unfolding info into an interface -file to determine whether an unfolding candidate really should be unfolded. -The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted -into interface files. - -The reason for inlining expressions containing _casm_s into interface files -is that these fragments of C are likely to mention functions/#defines that -will be out-of-scope when inlined into another module. This is not an -unfixable problem for the user (just need to -#include the approp. header -file), but turning it off seems to the simplest thing to do. - -\begin{code} -okToUnfoldInHiFile :: CoreExpr -> Bool -okToUnfoldInHiFile e = opt_UnfoldCasms || go e - where - -- Race over an expression looking for CCalls.. - go (Var v) = case isPrimOpId_maybe v of - Just op -> okToUnfoldPrimOp op - Nothing -> True - go (Lit lit) = not (isLitLitLit lit) - go (App fun arg) = go fun && go arg - go (Lam _ body) = go body - go (Let binds body) = and (map go (body :rhssOfBind binds)) - go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts)) && - not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ]) - go (Note _ body) = go body - go (Type _) = True - - -- ok to unfold a PrimOp as long as it's not a _casm_ - okToUnfoldPrimOp (CCallOp ccall) = not (ccallIsCasm ccall) - okToUnfoldPrimOp _ = 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 + = False + +smallEnoughToInline :: Unfolding -> Bool +smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _)) + = size <= opt_UF_UseThreshold +smallEnoughToInline other + = False \end{code} - %************************************************************************ %* * \subsection{callSiteInline} @@ -494,7 +490,8 @@ them inlining is to give them a NOINLINE pragma, which we do in StrictAnal.addStrictnessInfoToTopId \begin{code} -callSiteInline :: Bool -- True <=> the Id is black listed +callSiteInline :: DynFlags + -> Bool -- True <=> the Id can be inlined -> Bool -- 'inline' note at call site -> OccInfo -> Id -- The Id @@ -503,16 +500,19 @@ callSiteInline :: Bool -- True <=> the Id is black listed -> Maybe CoreExpr -- Unfolding, if any -callSiteInline black_listed inline_call occ id arg_infos interesting_cont +callSiteInline dflags active_inline inline_call occ id arg_infos interesting_cont = case idUnfolding id of { NoUnfolding -> Nothing ; OtherCon cs -> Nothing ; - CompulsoryUnfolding unf_template | black_listed -> Nothing - | otherwise -> Just unf_template ; - -- Constructors have compulsory unfoldings, but - -- may have rules, in which case they are - -- black listed till later - CoreUnfolding unf_template is_top is_cheap is_value is_bot guidance -> + + CompulsoryUnfolding unf_template -> Just unf_template ; + -- CompulsoryUnfolding => there is no top-level binding + -- for these things, so we must inline it. + -- Only a couple of primop-like things have + -- compulsory unfoldings (see MkId.lhs). + -- We don't allow them to be inactive + + CoreUnfolding unf_template is_top is_value is_cheap guidance -> let result | yes_or_no = Just unf_template @@ -520,51 +520,34 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont n_val_args = length arg_infos - ok_inside_lam = is_value || is_bot || (is_cheap && not is_top) - -- I'm experimenting with is_cheap && not is_top - yes_or_no - | black_listed = False - | otherwise = case occ of + | not active_inline = False + | otherwise = case occ of IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False IAmALoopBreaker -> False - OneOcc in_lam one_br -> (not in_lam || ok_inside_lam) && consider_safe in_lam True one_br - NoOccInfo -> ok_inside_lam && consider_safe True False False - - consider_safe in_lam once once_in_one_branch - -- consider_safe decides whether it's a good idea to inline something, - -- given that there's no work-duplication issue (the caller checks that). - -- once_in_one_branch = True means there's a unique textual occurrence + --OneOcc in_lam _ _ -> (not in_lam || is_cheap) && consider_safe True + other -> is_cheap && consider_safe False + -- we consider even the once-in-one-branch + -- occurrences, because they won't all have been + -- caught by preInlineUnconditionally. In particular, + -- if the occurrence is once inside a lambda, and the + -- rhs is cheap but not a manifest lambda, then + -- pre-inline will not have inlined it for fear of + -- invalidating the occurrence info in the rhs. + + consider_safe once + -- consider_safe decides whether it's a good idea to + -- inline something, given that there's no + -- work-duplication issue (the caller checks that). | inline_call = True - | once_in_one_branch - -- Be very keen to inline something if this is its unique occurrence: - -- - -- a) Inlining gives a good chance of eliminating the original - -- binding (and hence the allocation) for the thing. - -- (Provided it's not a top level binding, in which case the - -- allocation costs nothing.) - -- - -- b) Inlining a function that is called only once exposes the - -- body function to the call site. - -- - -- The only time we hold back is when substituting inside a lambda; - -- then if the context is totally uninteresting (not applied, not scrutinised) - -- there is no point in substituting because it might just increase allocation, - -- by allocating the function itself many times - -- - -- Note: there used to be a '&& not top_level' in the guard above, - -- but that stopped us inlining top-level functions used only once, - -- which is stupid - = not in_lam || not (null arg_infos) || interesting_cont - | otherwise = case guidance of - UnfoldNever -> False ; + UnfoldNever -> False UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount | enough_args && size <= (n_vals_wanted + 1) - -- No size increase + -- Inline unconditionally if there no size increase -- Size of call is n_vals_wanted (+1 for the function) -> True @@ -573,20 +556,25 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont where some_benefit = or arg_infos || really_interesting_cont || - (not is_top && (once || (n_vals_wanted > 0 && enough_args))) - -- 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. - + (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 @@ -599,25 +587,18 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont arg_infos really_interesting_cont in -#ifdef DEBUG - if opt_D_dump_inlinings then + if dopt Opt_D_dump_inlinings dflags then pprTrace "Considering inlining" - (ppr id <+> vcat [text "black listed" <+> ppr black_listed, + (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 "is value:" <+> ppr is_value, text "is cheap:" <+> ppr is_cheap, - text "is bottom:" <+> ppr is_bot, - text "is top-level:" <+> ppr is_top, text "guidance" <+> ppr guidance, - text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO", - if yes_or_no then - text "Unfolding =" <+> pprCoreExpr unf_template - else empty]) + text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) result else -#endif result } @@ -625,8 +606,8 @@ computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used -- 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 - -- *efficiency* to be gained (e.g. beta reductions, case reductions) + -- *size* whereas the discounts imply that there's some extra + -- *efficiency* to be gained (e.g. beta reductions, case reductions) -- by inlining. -- we also discount 1 for each argument passed, because these will @@ -638,7 +619,7 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used -- Discount of 1 for each arg supplied, because the -- result replaces the call round (opt_UF_KeenessFactor * - fromInt (arg_discount + result_discount)) + fromIntegral (arg_discount + result_discount)) where arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos) @@ -649,95 +630,3 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used result_discount | result_used = res_discount -- Over-applied, or case scrut | otherwise = 0 \end{code} - - -%************************************************************************ -%* * -\subsection{Black-listing} -%* * -%************************************************************************ - -Inlining is controlled by the "Inline phase" number, which is set -by the per-simplification-pass '-finline-phase' flag. - -For optimisation we use phase 1,2 and nothing (i.e. no -finline-phase flag) -in that order. The meanings of these are determined by the @blackListed@ function -here. - -The final simplification doesn't have a phase number. - -Pragmas -~~~~~~~ - Pragma Black list if - -(least black listing, most inlining) - INLINE n foo phase is Just p *and* p Maybe Int -- Inline phase - -> Id -> Bool -- True <=> blacklisted - --- The blackListed function sees whether a variable should *not* be --- inlined because of the inline phase we are in. This is the sole --- place that the inline phase number is looked at. - -blackListed rule_vars Nothing -- Last phase - = \v -> isNeverInlinePrag (idInlinePragma v) - -blackListed rule_vars (Just phase) - = \v -> normal_case rule_vars phase v - -normal_case rule_vars phase v - = case idInlinePragma v of - NoInlinePragInfo -> has_rules - - IMustNotBeINLINEd from_INLINE Nothing - | from_INLINE -> has_rules -- Black list until final phase - | otherwise -> True -- Always blacklisted - - IMustNotBeINLINEd from_inline (Just threshold) - | from_inline -> (phase < threshold && has_rules) - | otherwise -> (phase < threshold || has_rules) - where - has_rules = v `elemVarSet` rule_vars - || not (isEmptyCoreRules (idSpecialisation v)) -\end{code} - - -SLPJ 95/04: Why @runST@ must be inlined very late: -\begin{verbatim} -f x = - runST ( \ s -> let - (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' ) -\end{verbatim} -If we inline @runST@, we'll get: -\begin{verbatim} -f x = let - (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' -\end{verbatim} -And now the @newArray#@ binding can be floated to become a CAF, which -is totally and utterly wrong: -\begin{verbatim} -f = let - (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in - \ x -> - let (_, s'') = fill_in_array_or_something a x s' in - freezeArray# a s'' -\end{verbatim} -All calls to @f@ will share a {\em single} array! - -Yet we do want to inline runST sometime, so we can avoid -needless code. Solution: black list it until the last moment. -