X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUnfold.lhs;h=6853b96b7be758264a544671df535b4fb9aea642;hb=f6007733dc8e9a3f58c36e2bab97d2858d2b569a;hp=42db228ab8355896592bbc3e3dbb24c6b161d31e;hpb=861e836ed0cc1aa45932ecb3470967964440a0ef;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 42db228..6853b96 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -20,7 +20,7 @@ module CoreUnfold ( mkOtherCon, otherCons, unfoldingTemplate, maybeUnfoldingTemplate, isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, + hasUnfolding, hasSomeUnfolding, neverUnfold, couldBeSmallEnoughToInline, certainlyWillInline, @@ -35,27 +35,28 @@ import CmdLineOpts ( opt_UF_CreationThreshold, opt_UF_UseThreshold, opt_UF_FunAppDiscount, opt_UF_KeenessFactor, - opt_UF_CheapOp, opt_UF_DearOp, - opt_UnfoldCasms, opt_PprStyle_Debug, - opt_D_dump_inlinings + opt_UF_DearOp, opt_UnfoldCasms, + DynFlags, DynFlag(..), dopt ) import CoreSyn import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) -import CoreUtils ( exprIsValue, exprIsCheap, exprIsBottom, exprIsTrivial ) -import Id ( Id, idType, idFlavour, isId, idWorkerInfo, +import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) +import Id ( Id, idType, isId, idSpecialisation, idInlinePragma, idUnfolding, - isPrimOpId_maybe + isFCallId_maybe, globalIdDetails ) import VarSet -import Literal ( isLitLitLit, litIsDupable ) -import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm ) -import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), - insideLam, workerExists, isNeverInlinePrag +import Literal ( isLitLitLit, litSize ) +import PrimOp ( primOpIsDupable, primOpOutOfLine ) +import ForeignCall ( okToExposeFCall ) +import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..), + isNeverInlinePrag ) -import Type ( splitFunTy_maybe, isUnLiftedType ) +import Type ( isUnLiftedType ) import PrelNames ( hasKey, buildIdKey, augmentIdKey ) import Bag +import FastTypes import Outputable #if __GLASGOW_HASKELL__ >= 404 @@ -147,9 +148,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 @@ -182,19 +183,26 @@ sizeExpr :: Int -- Bomb out if it gets bigger than this -> 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) | litIsDupable lit = sizeOne - | otherwise = sizeN opt_UF_DearOp -- For lack of anything better + 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 @@ -220,7 +228,7 @@ sizeExpr (I# 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 @@ -255,7 +263,7 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr -- 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 @@ -289,9 +297,10 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr | fun `hasKey` buildIdKey = buildSize | fun `hasKey` augmentIdKey = augmentSize | otherwise - = case idFlavour fun of + = case globalIdDetails fun of DataConId dc -> conSizeN (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 @@ -328,16 +337,16 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr -- 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 + addSizeN (SizeIs n xs d) m + | n_tot ># (iUnbox bOMB_OUT_SIZE) = TooBig | otherwise = SizeIs n_tot xs d where - n_tot = n +# m + n_tot = n +# iUnbox m addSize TooBig _ = TooBig addSize _ TooBig = TooBig addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) - | n_tot ># bOMB_OUT_SIZE = TooBig + | n_tot ># (iUnbox bOMB_OUT_SIZE) = TooBig | otherwise = SizeIs n_tot xys d_tot where n_tot = n1 +# n2 @@ -350,33 +359,35 @@ 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 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 n = 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. primOpSize op n_args | not (primOpIsDupable op) = sizeN opt_UF_DearOp - | not (primOpOutOfLine op) = sizeZero -- These are good to inline + | not (primOpOutOfLine op) = sizeN (1 - 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 1. + -- I found occasions where we had + -- f x y z = case op# x y z of { s -> (# s, () #) } + -- and f wasn't getting inlined | otherwise = sizeOne buildSize = SizeIs (-2#) emptyBag 4# @@ -395,7 +406,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} @@ -468,9 +479,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 @@ -479,10 +490,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} @@ -509,7 +516,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 is black listed -> Bool -- 'inline' note at call site -> OccInfo -> Id -- The Id @@ -518,7 +526,7 @@ 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 black_listed inline_call occ id arg_infos interesting_cont = case idUnfolding id of { NoUnfolding -> Nothing ; OtherCon cs -> Nothing ; @@ -568,7 +576,9 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont -- 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 in_lam, ppr id ) -- If (not in_lam) && one_br then PreInlineUnconditionally + -- should have caught it, shouldn't it? + not (null arg_infos) || interesting_cont | otherwise = case guidance of @@ -611,8 +621,7 @@ 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, text "occ info:" <+> ppr occ, @@ -627,7 +636,6 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont else empty]) result else -#endif result }