X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUnfold.lhs;h=46f2ba2015f5332bd9941e19d8d81e3926f3f0e4;hb=1cfc9faaa059b9b090971399e4eb8ae9d364335c;hp=25659dae9f046820b6a03c7113a16b742b88f917;hpb=90fa6b84fdc99ba99c0b7df9691ca69d50b62530;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 25659da..46f2ba2 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -26,7 +26,7 @@ module CoreUnfold ( certainlyWillInline, okToUnfoldInHiFile, - callSiteInline, blackListed + callSiteInline ) where #include "HsVersions.h" @@ -42,24 +42,24 @@ import CoreSyn import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) -import Id ( Id, idType, idFlavour, isId, - idSpecialisation, idInlinePragma, idUnfolding, - isPrimOpId_maybe - ) -import VarSet -import Literal ( isLitLitLit, litIsDupable ) -import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm ) -import IdInfo ( InlinePragInfo(..), OccInfo(..), IdFlavour(..), - isNeverInlinePrag +import Id ( Id, idType, isId, + idUnfolding, + isFCallId_maybe, globalIdDetails ) +import DataCon ( isUnboxedTupleCon ) +import Literal ( isLitLitLit, litSize ) +import PrimOp ( primOpIsDupable, primOpOutOfLine ) +import ForeignCall ( okToExposeFCall ) +import IdInfo ( OccInfo(..), GlobalIdDetails(..) ) import Type ( isUnLiftedType ) import PrelNames ( hasKey, buildIdKey, augmentIdKey ) import Bag import FastTypes import Outputable +import Util #if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) +import GLAEXTS ( Int# ) #endif \end{code} @@ -76,6 +76,7 @@ mkTopUnfolding expr = mkUnfolding True {- Top level -} expr mkUnfolding top_lvl expr = CoreUnfolding (occurAnalyseGlobalExpr expr) top_lvl + (exprIsValue expr) -- Already evaluated @@ -132,7 +133,7 @@ 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 @@ -176,7 +177,7 @@ 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 @@ -188,13 +189,20 @@ sizeExpr bOMB_OUT_SIZE top_args expr 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 (Note _ body) = size_up body -- Other notes cost nothing - size_up (App fun (Type t)) = size_up fun - size_up (App fun arg) = size_up_app fun [arg] + size_up (App fun (Type t)) = size_up fun + size_up (App fun arg) = size_up_app fun [arg] - size_up (Lit lit) | litIsDupable lit = sizeOne - | otherwise = sizeN opt_UF_DearOp -- For lack of anything better + size_up (Lit lit) = sizeN (litSize lit) size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1) | otherwise = size_up e @@ -220,7 +228,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr (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) o point in inlining (+) here! + 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 @@ -289,9 +297,10 @@ sizeExpr 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 @@ -327,54 +336,66 @@ sizeExpr bOMB_OUT_SIZE top_args expr -- 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) m - | n_tot ># (iUnbox bOMB_OUT_SIZE) = TooBig - | otherwise = SizeIs n_tot xs d - where - n_tot = n +# iUnbox 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 ># (iUnbox 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 FastInt -- Size found (Bag (Id,Int)) -- Arguments cased herein, and discount for each such FastInt -- Size to subtract if result is scrutinised -- by a case expression - +-- 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 (_ILIT 0) emptyBag (_ILIT 0) -sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0) -sizeTwo = SizeIs (_ILIT 2) emptyBag (_ILIT 0) +sizeZero = SizeIs (_ILIT 0) emptyBag (_ILIT 0) +sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0) sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT 0) -conSizeN n = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1) +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 (iBox x) has size 1, -- which is the same as a lone variable; and hence 'v' will -- 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# @@ -438,16 +459,12 @@ 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 +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 \end{code} @okToUnfoldInHifile@ is used when emitting unfolding info into an interface @@ -466,9 +483,9 @@ 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 (Var v) = case isFCallId_maybe v of + Just fcall -> okToExposeFCall fcall + Nothing -> True go (Lit lit) = not (isLitLitLit lit) go (App fun arg) = go fun && go arg go (Lam _ body) = go body @@ -477,10 +494,6 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e 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 \end{code} @@ -508,7 +521,7 @@ StrictAnal.addStrictnessInfoToTopId \begin{code} callSiteInline :: DynFlags - -> Bool -- True <=> the Id is black listed + -> Bool -- True <=> the Id can be inlined -> Bool -- 'inline' note at call site -> OccInfo -> Id -- The Id @@ -517,15 +530,18 @@ callSiteInline :: DynFlags -> Maybe CoreExpr -- Unfolding, if any -callSiteInline dflags 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 + + 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 @@ -535,8 +551,8 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont n_val_args = length arg_infos 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 || is_cheap) && consider_safe in_lam True one_br @@ -563,11 +579,20 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont -- 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 [Jan 2002]: this comment looks out of date. The actual code + -- doesn't inline *ever* in an uninteresting context. Why not? I + -- think it's just because we don't want to inline top-level constants + -- into uninteresting contexts, lest we (for example) re-nest top-level + -- literal lists. -- -- 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 + = WARN( not is_top && not in_lam, ppr id ) + -- If (not in_lam) && one_br then PreInlineUnconditionally + -- should have caught it, shouldn't it? Unless it's a top + -- level thing. + notNull arg_infos || interesting_cont | otherwise = case guidance of @@ -575,7 +600,7 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont 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 @@ -610,10 +635,9 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont arg_infos really_interesting_cont in -#ifdef DEBUG 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, @@ -626,7 +650,6 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont else empty]) result else -#endif result } @@ -647,7 +670,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) @@ -658,95 +681,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. -