X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUnfold.lhs;h=3327e8bb0a6ee72e05b873bdfc078ea28f618ff6;hb=914a045d66f01e11e385374553877c6446d6341d;hp=fe7b8f2c3a785d4cbfbc92f13489cb40f3ecc6f5;hpb=e0d750bedbd33f7a133c8c82c35fd8db537ab649;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index fe7b8f2..3327e8b 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -17,14 +17,13 @@ module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding, - mkOtherCon, otherCons, + evaldUnfolding, mkOtherCon, otherCons, unfoldingTemplate, maybeUnfoldingTemplate, isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding, hasUnfolding, hasSomeUnfolding, neverUnfold, couldBeSmallEnoughToInline, certainlyWillInline, - okToUnfoldInHiFile, callSiteInline ) where @@ -35,7 +34,7 @@ import CmdLineOpts ( opt_UF_CreationThreshold, opt_UF_UseThreshold, opt_UF_FunAppDiscount, opt_UF_KeenessFactor, - opt_UF_DearOp, opt_UnfoldCasms, + opt_UF_DearOp, DynFlags, DynFlag(..), dopt ) import CoreSyn @@ -43,22 +42,21 @@ import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) import Id ( Id, idType, isId, - idUnfolding, - isFCallId_maybe, globalIdDetails + idUnfolding, globalIdDetails ) import DataCon ( isUnboxedTupleCon ) -import Literal ( isLitLitLit, litSize ) +import Literal ( 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} @@ -132,13 +130,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 @@ -176,7 +174,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 @@ -220,7 +218,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr where rhs_size = foldr (addSize . size_up . snd) sizeZero pairs - size_up (Case (Var v) _ alts) + 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. @@ -268,9 +266,9 @@ sizeExpr bOMB_OUT_SIZE top_args expr -- 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 @@ -297,7 +295,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr | fun `hasKey` augmentIdKey = augmentSize | otherwise = case globalIdDetails fun of - DataConId dc -> conSizeN dc (valArgCount args) + DataConWorkId dc -> conSizeN dc (valArgCount args) FCallId fc -> sizeN opt_UF_DearOp PrimOpId op -> primOpSize op (valArgCount args) @@ -335,35 +333,32 @@ 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 @@ -461,48 +456,14 @@ 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_cheap g@(UnfoldIfGoodArgs n_vals _ size _) - -> is_cheap - && 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 -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 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 - 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 -\end{code} - - %************************************************************************ %* * \subsection{callSiteInline} @@ -585,6 +546,11 @@ callSiteInline dflags active_inline inline_call occ id arg_infos interesting_con -- 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, @@ -593,7 +559,7 @@ callSiteInline dflags active_inline inline_call occ id arg_infos interesting_con -- If (not in_lam) && one_br then PreInlineUnconditionally -- should have caught it, shouldn't it? Unless it's a top -- level thing. - not (null arg_infos) || interesting_cont + notNull arg_infos || interesting_cont | otherwise = case guidance of @@ -671,7 +637,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)