X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUnfold.lhs;h=5d1f2b2b699130b0bb21474b965f83ed65e72d7f;hb=f36fb2ce821caf594c1db5669dd10ca082f66361;hp=e25495862570a6fc74e3c2bb130ceb0a71717d42;hpb=adf74bb1c724edd4a8d1ea22b464203fc2ddb55c;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index e254958..5d1f2b2 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -9,39 +9,27 @@ syntax (namely @CoreExpr@s). The type @Unfolding@ sits ``above'' simply-Core-expressions unfoldings, capturing ``higher-level'' things we know about a binding, usually things that the simplifier found out (e.g., ``it's a -literal''). In the corner of a @SimpleUnfolding@ unfolding, you will +literal''). In the corner of a @CoreUnfolding@ unfolding, you will find, unsurprisingly, a Core expression. \begin{code} -#include "HsVersions.h" - module CoreUnfold ( - SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types - UfExpr, RdrName, -- For closure (delete in 1.3) + Unfolding(..), UnfoldingGuidance(..), -- types - FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, exprIsTrivial, + FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, + exprIsTrivial, noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate, - smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline, - inlineUnconditionally, - - calcUnfoldingGuidance, + smallEnoughToInline, couldBeSmallEnoughToInline, + certainlySmallEnoughToInline, inlineUnconditionally, okToInline, - PragmaInfo(..) -- Re-export + calcUnfoldingGuidance ) where -IMP_Ubiq() -#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -- for paranoia checking; - -- and also to get mkMagicUnfoldingFun -IMPORT_DELOOPER(PrelLoop) -- for paranoia checking -IMPORT_DELOOPER(SmplLoop) -#else -import {-# SOURCE #-} MagicUFs -#endif +#include "HsVersions.h" -import Bag ( emptyBag, unitBag, unionBags, Bag ) +import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun, mkMagicUnfoldingFun ) import CmdLineOpts ( opt_UnfoldingCreationThreshold, opt_UnfoldingUseThreshold, @@ -52,36 +40,30 @@ import Constants ( uNFOLDING_CHEAP_OP_COST, uNFOLDING_DEAR_OP_COST, uNFOLDING_NOREP_LIT_COST ) -import BinderInfo ( BinderInfo, isOneFunOcc, isOneSafeFunOcc +import BinderInfo ( BinderInfo, isOneSameSCCFunOcc, isDeadOcc, + isInlinableOcc, isOneSafeFunOcc ) -import PragmaInfo ( PragmaInfo(..) ) import CoreSyn +import Literal ( Literal ) import CoreUtils ( unTagBinders ) -import HsCore ( UfExpr ) -import RdrHsSyn ( RdrName ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( coreExprType ) ---import CostCentre ( ccMentionsId ) -import Id ( SYN_IE(Id), idType, getIdArity, isBottomingId, isDataCon, +import Id ( Id, idType, getIdArity, isBottomingId, isDataCon, idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd, - SYN_IE(IdSet), GenId{-instances-} ) -import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) ) -import IdInfo ( ArityInfo(..), bottomIsGuaranteed ) -import Literal ( isNoRepLit, isLitLitLit ) -import Pretty + IdSet ) +import PrimOp ( fragilePrimOp, primOpCanTriggerGC ) +import IdInfo ( ArityInfo(..), InlinePragInfo(..) ) +import Name ( isExported ) +import Literal ( isNoRepLit ) import TyCon ( tyConFamilySize ) -import Type ( maybeAppDataTyConExpandingDicts ) +import Type ( splitAlgTyConApp_maybe ) import Unique ( Unique ) -import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, - addOneToUniqSet, unionUniqSets - ) -import Usage ( SYN_IE(UVar) ) -import Maybes ( maybeToBool ) import Util ( isIn, panic, assertPanic ) -#if __GLASGOW_HASKELL__ >= 202 +import UniqFM import Outputable -#endif +import List ( maximumBy ) +import GlaExts --tmp \end{code} %************************************************************************ @@ -94,28 +76,28 @@ import Outputable data Unfolding = NoUnfolding - | CoreUnfolding SimpleUnfolding + | OtherLit [Literal] -- It ain't one of these + | OtherCon [Id] -- It ain't one of these - | MagicUnfolding - Unique -- Unique of the Id whose magic unfolding this is - MagicUnfoldingFun - - -data SimpleUnfolding - = SimpleUnfolding -- An unfolding with redundant cached information + | CoreUnfolding -- An unfolding with redundant cached information FormSummary -- Tells whether the template is a WHNF or bottom UnfoldingGuidance -- Tells about the *size* of the template. SimplifiableCoreExpr -- Template + | MagicUnfolding + Unique -- Unique of the Id whose magic unfolding this is + MagicUnfoldingFun +\end{code} +\begin{code} noUnfolding = NoUnfolding -mkUnfolding inline_prag expr +mkUnfolding expr = let -- strictness mangling (depends on there being no CSE) - ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr + ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr occ = occurAnalyseGlobalExpr expr - cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ) + cuf = CoreUnfolding (mkFormSummary expr) ufg occ cont = case occ of { Var _ -> cuf; _ -> cuf } in @@ -125,7 +107,7 @@ mkMagicUnfolding :: Unique -> Unfolding mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag) getUnfoldingTemplate :: Unfolding -> CoreExpr -getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr)) +getUnfoldingTemplate (CoreUnfolding _ _ expr) = unTagBinders expr getUnfoldingTemplate other = panic "getUnfoldingTemplate" @@ -154,8 +136,8 @@ data UnfoldingGuidance \begin{code} instance Outputable UnfoldingGuidance where - ppr sty UnfoldAlways = ptext SLIT("_ALWAYS_") - ppr sty (UnfoldIfGoodArgs t v cs size discount) + ppr UnfoldAlways = ptext SLIT("_ALWAYS_") + ppr (UnfoldIfGoodArgs t v cs size discount) = hsep [ptext SLIT("_IF_ARGS_"), int t, int v, if null cs -- always print *something* then char 'X' @@ -180,12 +162,12 @@ data FormSummary | OtherForm -- Anything else instance Outputable FormSummary where - ppr sty VarForm = ptext SLIT("Var") - ppr sty ValueForm = ptext SLIT("Value") - ppr sty BottomForm = ptext SLIT("Bot") - ppr sty OtherForm = ptext SLIT("Other") + ppr VarForm = ptext SLIT("Var") + ppr ValueForm = ptext SLIT("Value") + ppr BottomForm = ptext SLIT("Bot") + ppr OtherForm = ptext SLIT("Other") -mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary +mkFormSummary ::GenCoreExpr bndr Id flexi -> FormSummary mkFormSummary expr = go (0::Int) expr -- The "n" is the number of (value) arguments so far @@ -193,8 +175,7 @@ mkFormSummary expr go n (Lit _) = ASSERT(n==0) ValueForm go n (Con _ _) = ASSERT(n==0) ValueForm go n (Prim _ _) = OtherForm - go n (SCC _ e) = go n e - go n (Coerce _ _ e) = go n e + go n (Note _ e) = go n e go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g) -- should be treated as a value @@ -230,7 +211,7 @@ simple variables and constants, and type applications. exprIsTrivial (Var v) = True exprIsTrivial (Lit lit) = not (isNoRepLit lit) exprIsTrivial (App e (TyArg _)) = exprIsTrivial e -exprIsTrivial (Coerce _ _ e) = exprIsTrivial e +exprIsTrivial (Note _ e) = exprIsTrivial e exprIsTrivial other = False \end{code} @@ -238,9 +219,9 @@ exprIsTrivial other = False exprSmallEnoughToDup (Con _ _) = True -- Could check # of args exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit) -exprSmallEnoughToDup (Coerce _ _ e) = exprSmallEnoughToDup e +exprSmallEnoughToDup (Note _ e) = exprSmallEnoughToDup e exprSmallEnoughToDup expr - = case (collectArgs expr) of { (fun, _, _, vargs) -> + = case (collectArgs expr) of { (fun, _, vargs) -> case fun of Var v | length vargs <= 4 -> True _ -> False @@ -257,23 +238,20 @@ exprSmallEnoughToDup expr \begin{code} calcUnfoldingGuidance - :: PragmaInfo -- INLINE pragma stuff - -> Int -- bomb out if size gets bigger than this + :: Int -- bomb out if size gets bigger than this -> CoreExpr -- expression to look at -> UnfoldingGuidance -calcUnfoldingGuidance IMustBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so -calcUnfoldingGuidance IWantToBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so -calcUnfoldingGuidance IMustNotBeINLINEd bOMB_OUT_SIZE expr = UnfoldNever -- ...and vice versa... - -calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr - = case collectBinders expr of { (use_binders, ty_binders, val_binders, body) -> +calcUnfoldingGuidance bOMB_OUT_SIZE expr + = case collectBinders expr of { (ty_binders, val_binders, body) -> case (sizeExpr bOMB_OUT_SIZE val_binders body) of TooBig -> UnfoldNever SizeIs size cased_args scrut_discount - -> UnfoldIfGoodArgs + -> {- trace ("calcUnfoldingGuidance: \n" ++ showSDoc (ppr expr) ++ "\n" + ++ show (I# size) ++ "\n" ++ show (map discount_for val_binders)) $ -} + UnfoldIfGoodArgs (length ty_binders) (length val_binders) (map discount_for val_binders) @@ -281,15 +259,16 @@ calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr (I# scrut_discount) where discount_for b - | is_data && b `is_elem` cased_args = tyConFamilySize tycon + | is_data = case lookupUFM cased_args b of + Nothing -> 0 + Just d -> d | otherwise = 0 where (is_data, tycon) - = case (maybeAppDataTyConExpandingDicts (idType b)) of + = case (splitAlgTyConApp_maybe (idType b)) of Nothing -> (False, panic "discount") Just (tc,_,_) -> (True, tc) - - is_elem = isIn "calcUnfoldingGuidance" } + } \end{code} \begin{code} @@ -306,8 +285,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST | otherwise = sizeZero - size_up (SCC lbl body) = size_up body -- SCCs cost nothing - size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing + size_up (Note _ body) = size_up body -- Notes cost nothing size_up (App fun arg) = size_up fun `addSize` size_up_arg arg -- NB Zero cost for for type applications; @@ -327,7 +305,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr size_up expr@(Lam _ _) = let - (uvars, tyvars, args, body) = collectBinders expr + (tyvars, args, body) = collectBinders expr in size_up body `addSizeN` length args @@ -335,18 +313,20 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr = nukeScrutDiscount (size_up rhs) `addSize` size_up body + `addSizeN` + 1 -- For the allocation size_up (Let (Rec pairs) body) = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]) `addSize` size_up body + `addSizeN` + length pairs -- For the allocation size_up (Case scrut alts) = nukeScrutDiscount (size_up scrut) `addSize` - arg_discount scrut - `addSize` - size_up_alts (coreExprType scrut) alts + size_up_alts scrut (coreExprType scrut) alts -- We charge for the "case" itself in "size_up_alts" ------------ @@ -358,11 +338,23 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr size_up_arg other = sizeOne ------------ - size_up_alts scrut_ty (AlgAlts alts deflt) - = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts) + size_up_alts scrut scrut_ty (AlgAlts alts deflt) + = total_size + `addSize` + scrut_discount scrut `addSizeN` alt_cost where + alts_sizes = size_up_deflt deflt : map size_alg_alt alts + total_size = foldr addSize sizeZero alts_sizes + + biggest_alt = maximumBy (\a b -> if ltSize a b then b else a) alts_sizes + + scrut_discount (Var v) | v `is_elem` args = + scrutArg v (minusSize total_size biggest_alt + alt_cost) + scrut_discount _ = sizeZero + + size_alg_alt (con,args,rhs) = size_up rhs -- Don't charge for args, so that wrappers look cheap @@ -376,11 +368,11 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr alt_cost :: Int alt_cost - = case (maybeAppDataTyConExpandingDicts scrut_ty) of + = case (splitAlgTyConApp_maybe scrut_ty) of Nothing -> 1 Just (tc,_,_) -> tyConFamilySize tc - size_up_alts _ (PrimAlts alts deflt) + size_up_alts _ _ (PrimAlts alts deflt) = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts -- *no charge* for a primitive "case"! where @@ -391,10 +383,6 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr size_up_deflt (BindDefault binder rhs) = size_up rhs ------------ - -- We want to record if we're case'ing an argument - arg_discount (Var v) | v `is_elem` args = scrutArg v - arg_discount other = sizeZero - is_elem :: Id -> [Id] -> Bool is_elem = isIn "size_up_scrut" @@ -409,6 +397,14 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr where n_tot = n +# m + -- trying to find a reasonable discount for eliminating this case. + -- if the case is eliminated, in the worse case we end up with the + -- largest alternative, so subtract the size of the largest alternative + -- from the total size of the case to end up with the discount + minusSize TooBig _ = 0 + minusSize _ TooBig = panic "CoreUnfold: minusSize" -- shouldn't happen + minusSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) = I# (n1 -# n2) + addSize TooBig _ = TooBig addSize _ TooBig = TooBig addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) @@ -417,8 +413,9 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr where n_tot = n1 +# n2 d_tot = d1 +# d2 - xys = xs ++ ys + xys = combineArgDiscounts xs ys + \end{code} @@ -428,18 +425,25 @@ Code for manipulating sizes data ExprSize = TooBig | SizeIs Int# -- Size found - [Id] -- Arguments cased herein + (UniqFM Int) -- discount for each argument Int# -- Size to subtract if result is scrutinised -- by a case expression -sizeZero = SizeIs 0# [] 0# -sizeOne = SizeIs 1# [] 0# -sizeN (I# n) = SizeIs n [] 0# -conSizeN (I# n) = SizeIs n [] n -scrutArg v = SizeIs 0# [v] 0# +ltSize a TooBig = True +ltSize TooBig a = False +ltSize (SizeIs s1# _ _) (SizeIs s2# _ _) = s1# <=# s2# + +sizeZero = SizeIs 0# emptyUFM 0# +sizeOne = SizeIs 1# emptyUFM 0# +sizeN (I# n) = SizeIs n emptyUFM 0# +conSizeN (I# n) = SizeIs n emptyUFM n +scrutArg v d = SizeIs 0# (unitUFM v d) 0# nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0# nukeScrutDiscount TooBig = TooBig + +combineArgDiscounts :: UniqFM Int -> UniqFM Int -> UniqFM Int +combineArgDiscounts = plusUFM_C (+) \end{code} %************************************************************************ @@ -473,17 +477,23 @@ is more accurate (see @sizeExpr@ above for how this discount size is computed). \begin{code} -smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments +smallEnoughToInline :: Id -- The function (trace msg only) + -> [Bool] -- Evaluated-ness of value arguments -> Bool -- Result is scrutinised -> UnfoldingGuidance -> Bool -- True => unfold it -smallEnoughToInline _ _ UnfoldAlways = True -smallEnoughToInline _ _ UnfoldNever = False -smallEnoughToInline arg_is_evald_s result_is_scruted +smallEnoughToInline _ _ _ UnfoldAlways = True +smallEnoughToInline _ _ _ UnfoldNever = False +smallEnoughToInline id arg_is_evald_s result_is_scruted (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount) - = enough_args n_vals_wanted arg_is_evald_s && - size - discount <= opt_UnfoldingUseThreshold + = if enough_args n_vals_wanted arg_is_evald_s && + size - discount <= opt_UnfoldingUseThreshold + then + -- pprTrace "small enough" (ppr id <+> int size <+> int discount) + True + else + False where enough_args n [] | n > 0 = False -- A function with no value args => don't unfold @@ -503,9 +513,9 @@ smallEnoughToInline arg_is_evald_s result_is_scruted result_discount | result_is_scruted = scrut_discount | otherwise = 0 - arg_discount no_of_constrs is_evald - | is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount - | otherwise = 1 + arg_discount discount is_evald + | is_evald = discount + | otherwise = 0 \end{code} We use this one to avoid exporting inlinings that we ``couldn't possibly @@ -513,12 +523,11 @@ use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code} ---UNUSED? -couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool -couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance +couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool +couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance -certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool -certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance +certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool +certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance \end{code} Predicates @@ -531,17 +540,41 @@ certain that every use can be inlined. So, notably, any ArgOccs rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc \begin{code} -inlineUnconditionally :: Bool -> Id -> BinderInfo -> Bool +inlineUnconditionally :: (Id,BinderInfo) -> Bool -inlineUnconditionally ok_to_dup id occ_info - | idMustNotBeINLINEd id = False +inlineUnconditionally (id, occ_info) + | idMustNotBeINLINEd id + || isExported id + = False - | isOneFunOcc occ_info - && idMustBeINLINEd id = True + | isOneSameSCCFunOcc occ_info + && idWantsToBeINLINEd id = True - | isOneSafeFunOcc (ok_to_dup || idWantsToBeINLINEd id) occ_info + | isOneSafeFunOcc occ_info = True | otherwise = False \end{code} + +okToInline is used at call sites, so it is a bit more generous + +\begin{code} +okToInline :: Id -- The Id + -> Bool -- The thing is WHNF or bottom; + -> Bool -- It's small enough to duplicate the code + -> BinderInfo + -> Bool -- True <=> inline it + +okToInline id _ _ _ -- Check the Id first + | idWantsToBeINLINEd id = True + | idMustNotBeINLINEd id = False + +okToInline id whnf small binder_info +#ifdef DEBUG + | isDeadOcc binder_info + = pprTrace "okToInline: dead" (ppr id) False + | otherwise +#endif + = isInlinableOcc whnf small binder_info +\end{code}