X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUnfold.lhs;h=b59e9cf140189d7772f0b2fe7590105b4613de6e;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=f2077ba738370a7e01e4208ae1a545141f3d9ce7;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index f2077ba..b59e9cf 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1998 % \section[CoreUnfold]{Core-syntax unfoldings} @@ -9,64 +9,51 @@ 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) - - FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, + Unfolding(..), UnfoldingGuidance(..), -- types noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate, + isEvaldUnfolding, hasUnfolding, - smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline, - okToInline, + smallEnoughToInline, couldBeSmallEnoughToInline, + certainlySmallEnoughToInline, + okToUnfoldInHiFile, calcUnfoldingGuidance ) where -IMP_Ubiq() -IMPORT_DELOOPER(IdLoop) -- for paranoia checking; - -- and also to get mkMagicUnfoldingFun -IMPORT_DELOOPER(PrelLoop) -- for paranoia checking +#include "HsVersions.h" -import Bag ( emptyBag, unitBag, unionBags, Bag ) +import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun, mkMagicUnfoldingFun ) import CmdLineOpts ( opt_UnfoldingCreationThreshold, opt_UnfoldingUseThreshold, - opt_UnfoldingConDiscount + opt_UnfoldingConDiscount, + opt_UnfoldingKeenessFactor, + opt_UnfoldCasms ) import Constants ( uNFOLDING_CHEAP_OP_COST, uNFOLDING_DEAR_OP_COST, uNFOLDING_NOREP_LIT_COST ) -import BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger ) import CoreSyn -import CoreUtils ( unTagBinders ) -import HsCore ( UfExpr ) -import RdrHsSyn ( RdrName ) import OccurAnal ( occurAnalyseGlobalExpr ) -import CoreUtils ( coreExprType ) -import CostCentre ( ccMentionsId ) -import Id ( idType, getIdArity, isBottomingId, isDataCon, isPrimitiveId_maybe, - SYN_IE(IdSet), GenId{-instances-} ) -import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) ) -import IdInfo ( ArityInfo(..), bottomIsGuaranteed ) -import Literal ( isNoRepLit, isLitLitLit ) -import Pretty +import CoreUtils ( coreExprType, exprIsTrivial, mkFormSummary, + FormSummary(..) ) +import Id ( Id, idType, isId ) +import Const ( Con(..), isLitLitLit ) +import PrimOp ( PrimOp(..), primOpOutOfLine ) +import IdInfo ( ArityInfo(..), InlinePragInfo(..) ) import TyCon ( tyConFamilySize ) -import Type ( maybeAppDataTyConExpandingDicts ) -import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, - addOneToUniqSet, unionUniqSets - ) -import Usage ( SYN_IE(UVar) ) -import Maybes ( maybeToBool ) -import Util ( isIn, panic, assertPanic ) - +import Type ( splitAlgTyConApp_maybe ) +import Const ( isNoRepLit ) +import Unique ( Unique ) +import Util ( isIn, panic ) +import Outputable \end{code} %************************************************************************ @@ -79,41 +66,51 @@ import Util ( isIn, panic, assertPanic ) data Unfolding = NoUnfolding - | CoreUnfolding SimpleUnfolding - - | MagicUnfolding - Unique -- Unique of the Id whose magic unfolding this is - MagicUnfoldingFun - + | OtherCon [Con] -- It ain't one of these + -- (OtherCon xs) also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- OtherCon [] is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- data C = C !(Int -> Int) + -- case x of { C f -> ... } + -- Here, f gets an OtherCon [] unfolding. -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 + CoreExpr -- Template; binder-info is correct + | MagicUnfolding + Unique -- Unique of the Id whose magic unfolding this is + MagicUnfoldingFun +\end{code} +\begin{code} noUnfolding = NoUnfolding -mkUnfolding inline_me expr +mkUnfolding expr = let -- strictness mangling (depends on there being no CSE) - ufg = calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr + ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr occ = occurAnalyseGlobalExpr expr - cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ) - - cont = case occ of { Var _ -> cuf; _ -> cuf } in - case ufg of { UnfoldAlways -> cont; _ -> cont } + CoreUnfolding (mkFormSummary expr) ufg occ mkMagicUnfolding :: Unique -> Unfolding mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag) getUnfoldingTemplate :: Unfolding -> CoreExpr -getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr)) - = unTagBinders expr +getUnfoldingTemplate (CoreUnfolding _ _ expr) = expr getUnfoldingTemplate other = panic "getUnfoldingTemplate" +isEvaldUnfolding :: Unfolding -> Bool +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding ValueForm _ expr) = True +isEvaldUnfolding other = False + +hasUnfolding :: Unfolding -> Bool +hasUnfolding NoUnfolding = False +hasUnfolding other = True data UnfoldingGuidance = UnfoldNever @@ -124,147 +121,79 @@ data UnfoldingGuidance | UnfoldIfGoodArgs Int -- if "m" type args Int -- and "n" value args + [Int] -- Discount if the argument is evaluated. -- (i.e., a simplification will definitely -- be possible). One elt of the list per *value* arg. + Int -- The "size" of the unfolding; to be elaborated -- later. ToDo + + Int -- Scrutinee discount: the discount to substract if the thing is in + -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) \end{code} \begin{code} instance Outputable UnfoldingGuidance where - ppr sty UnfoldAlways = ppPStr SLIT("_ALWAYS_") --- ppr sty EssentialUnfolding = ppPStr SLIT("_ESSENTIAL_") -- shouldn't appear in an iface - ppr sty (UnfoldIfGoodArgs t v cs size) - = ppCat [ppPStr SLIT("_IF_ARGS_"), ppInt t, ppInt v, + 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 ppChar 'X' - else ppBesides (map (ppStr . show) cs), - ppInt size ] + then char 'X' + else hcat (map (text . show) cs), + int size, + int discount ] \end{code} %************************************************************************ %* * -\subsection{Figuring out things about expressions} -%* * -%************************************************************************ - -\begin{code} -data FormSummary - = VarForm -- Expression is a variable (or scc var, etc) - | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal - | BottomForm -- Expression is guaranteed to be bottom. We're more gung - -- ho about inlining such things, because it can't waste work - | OtherForm -- Anything else - -instance Outputable FormSummary where - ppr sty VarForm = ppPStr SLIT("Var") - ppr sty ValueForm = ppPStr SLIT("Value") - ppr sty BottomForm = ppPStr SLIT("Bot") - ppr sty OtherForm = ppPStr SLIT("Other") - -mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary - -mkFormSummary expr - = go (0::Int) expr -- The "n" is the number of (value) arguments so far - where - 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 (Let _ e) = OtherForm - go n (Case _ _) = OtherForm - - go 0 (Lam (ValBinder x) e) = ValueForm -- NB: \x.bottom /= bottom! - go n (Lam (ValBinder x) e) = go (n-1) e -- Applied lambda - go n (Lam other_binder e) = go n e - - go n (App fun arg) | isValArg arg = go (n+1) fun - go n (App fun other_arg) = go n fun - - go n (Var f) | isBottomingId f = BottomForm - | isDataCon f = ValueForm -- Can happen inside imported unfoldings - go 0 (Var f) = VarForm - go n (Var f) = case getIdArity f of - ArityExactly a | n < a -> ValueForm - ArityAtLeast a | n < a -> ValueForm - other -> OtherForm - -whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool -whnfOrBottom e = case mkFormSummary e of - VarForm -> True - ValueForm -> True - BottomForm -> True - OtherForm -> False -\end{code} - - -\begin{code} -exprSmallEnoughToDup (Con _ _) = True -- Could check # of args -exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args -exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit) -exprSmallEnoughToDup expr - = case (collectArgs expr) of { (fun, _, _, vargs) -> - case fun of - Var v | length vargs == 0 -> True - _ -> False - } - -{- LATER: -WAS: MORE CLEVER: -exprSmallEnoughToDup expr -- for now, just: applied to - = case (collectArgs expr) of { (fun, _, _, vargs) -> - case fun of - Var v -> v /= buildId - && v /= augmentId - && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish. - _ -> False - } --} -\end{code} -Question (ADR): What is the above used for? Is a _ccall_ really small -enough? - -%************************************************************************ -%* * \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression} %* * %************************************************************************ \begin{code} calcUnfoldingGuidance - :: Bool -- True <=> there's an INLINE pragma on this thing - -> 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 True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so - -calcUnfoldingGuidance False bOMB_OUT_SIZE expr - = case collectBinders expr of { (use_binders, ty_binders, val_binders, body) -> +calcUnfoldingGuidance bOMB_OUT_SIZE expr + | exprIsTrivial expr -- Often trivial expressions are never bound + -- to an expression, but it can happen. For + -- example, the Id for a nullary constructor has + -- a trivial expression as its unfolding, and + -- we want to make sure that we always unfold it. + = UnfoldAlways + + | otherwise + = case collectTyAndValBinders expr of { (ty_binders, val_binders, body) -> case (sizeExpr bOMB_OUT_SIZE val_binders body) of - Nothing -> UnfoldNever + TooBig -> UnfoldNever - Just (size, cased_args) + SizeIs size cased_args scrut_discount -> UnfoldIfGoodArgs (length ty_binders) (length val_binders) (map discount_for val_binders) - size + (I# size) + (I# scrut_discount) where - discount_for b - | is_data && b `is_elem` cased_args = tyConFamilySize tycon - | otherwise = 0 + discount_for b + | num_cases == 0 = 0 + | otherwise + = if is_data + then tyConFamilySize tycon * num_cases + else num_cases -- prim cases are pretty cheap + 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" } + num_cases = length (filter (==b) cased_args) + } \end{code} \begin{code} @@ -272,157 +201,112 @@ sizeExpr :: Int -- Bomb out if it gets bigger than this -> [Id] -- Arguments; we're interested in which of these -- get case'd -> CoreExpr - -> Maybe (Int, -- Size - [Id] -- Subset of args which are cased - ) - -sizeExpr bOMB_OUT_SIZE args expr + -> ExprSize - | data_or_prim fun --- We are very keen to inline literals, constructors, or primitives --- including their slightly-disguised forms as applications (the latter --- can show up in the bodies of things imported from interfaces). - = Just (0, []) - - | otherwise +sizeExpr (I# bOMB_OUT_SIZE) args expr = size_up expr where - (fun, _) = splitCoreApps expr - data_or_prim (Var v) = maybeToBool (isPrimitiveId_maybe v) || - isDataCon v - data_or_prim (Con _ _) = True - data_or_prim (Prim _ _) = True - data_or_prim (Lit _) = True - data_or_prim other = False - - size_up (Var v) = sizeZero - size_up (App fun arg) = size_up fun `addSize` size_up_arg arg `addSizeN` 1 - -- 1 for application node - - size_up (Lit lit) = if isNoRepLit lit - then sizeN uNFOLDING_NOREP_LIT_COST - else sizeZero - --- I don't understand this hack so I'm removing it! SLPJ Nov 96 --- size_up (SCC _ (Con _ _)) = Nothing -- **** HACK ***** - - size_up (SCC lbl body) = size_up body -- SCCs cost nothing - size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing - - size_up (Con con args) = sizeN (numValArgs args) - -- We don't count 1 for the constructor because we're - -- quite keen to get constructors into the open - - size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args - where - op_cost = if primOpCanTriggerGC op - then uNFOLDING_DEAR_OP_COST - -- these *tend* to be more expensive; - -- number chosen to avoid unfolding (HACK) - else uNFOLDING_CHEAP_OP_COST + size_up (Type t) = sizeZero -- Types cost nothing + size_up (Note _ body) = size_up body -- Notes cost nothing + size_up (Var v) = sizeOne + size_up (App fun arg) = size_up fun `addSize` size_up arg + + size_up (Con con args) = foldr (addSize . size_up) + (size_up_con con (valArgCount args)) + args - size_up expr@(Lam _ _) - = let - (uvars, tyvars, args, body) = collectBinders expr - in - size_up body `addSizeN` length args + size_up (Lam b e) | isId b = size_up e `addSizeN` 1 + | otherwise = size_up e size_up (Let (NonRec binder rhs) body) - = size_up rhs - `addSize` - size_up body - `addSizeN` - 1 + = nukeScrutDiscount (size_up rhs) `addSize` + size_up body `addSizeN` + 1 -- For the allocation size_up (Let (Rec pairs) body) - = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs] - `addSize` - size_up body - `addSizeN` - length pairs - - size_up (Case scrut alts) - = size_up_scrut scrut - `addSize` - size_up_alts (coreExprType scrut) alts - -- We charge for the "case" itself in "size_up_alts" - - ------------ - size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST - size_up_arg other = sizeZero - - ------------ - size_up_alts scrut_ty (AlgAlts alts deflt) - = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts - `addSizeN` - alt_cost + = nukeScrutDiscount rhs_size `addSize` + size_up body `addSizeN` + length pairs -- For the allocation where - size_alg_alt (con,args,rhs) = size_up rhs + rhs_size = foldr (addSize . size_up . snd) sizeZero pairs + + size_up (Case scrut _ alts) + = nukeScrutDiscount (size_up scrut) `addSize` + arg_discount scrut `addSize` + foldr (addSize . size_up_alt) sizeZero alts `addSizeN` + case (splitAlgTyConApp_maybe (coreExprType scrut)) of + Nothing -> 1 + Just (tc,_,_) -> tyConFamilySize tc + + ------------ + size_up_alt (con, bndrs, rhs) = size_up rhs -- Don't charge for args, so that wrappers look cheap - -- NB: we charge N for an alg. "case", where N is - -- the number of constructors in the thing being eval'd. - -- (You'll eventually get a "discount" of N if you - -- think the "case" is likely to go away.) - -- It's important to charge for alternatives. If you don't then you - -- get size 1 for things like: - -- case x of { A -> 1#; B -> 2#; ... lots } - - alt_cost :: Int - alt_cost - = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $ - case (maybeAppDataTyConExpandingDicts scrut_ty) of - Nothing -> 1 - Just (tc,_,_) -> tyConFamilySize tc - - size_up_alts _ (PrimAlts alts deflt) - = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts - -- *no charge* for a primitive "case"! - where - size_prim_alt (lit,rhs) = size_up rhs - ------------ - size_up_deflt NoDefault = sizeZero - size_up_deflt (BindDefault binder rhs) = size_up rhs + size_up_con (Literal lit) nv | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST + | otherwise = sizeOne + + size_up_con (DataCon dc) n_val_args = conSizeN n_val_args + + size_up_con (PrimOp op) nv = sizeN op_cost + where + op_cost = if primOpOutOfLine op + then uNFOLDING_DEAR_OP_COST + -- these *tend* to be more expensive; + -- number chosen to avoid unfolding (HACK) + else uNFOLDING_CHEAP_OP_COST ------------ - -- Scrutinees. There are two things going on here. - -- First, we want to record if we're case'ing an argument - -- Second, we want to charge nothing for the srutinee if it's just - -- a variable. That way wrapper-like things look cheap. - size_up_scrut (Var v) | v `is_elem` args = Just (0, [v]) - | otherwise = Just (0, []) - size_up_scrut other = size_up other + -- 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" ------------ - sizeZero = Just (0, []) - sizeOne = Just (1, []) - sizeN n = Just (n, []) - - addSizeN Nothing _ = Nothing - addSizeN (Just (n, xs)) m - | tot < bOMB_OUT_SIZE = Just (tot, xs) - | otherwise = Nothing - where - tot = n+m + -- These addSize things have to be here because + -- I don't want to give them bOMB_OUT_SIZE as an argument - addSize Nothing _ = Nothing - addSize _ Nothing = Nothing - addSize (Just (n, xs)) (Just (m, ys)) - | tot < bOMB_OUT_SIZE = Just (tot, xys) - | otherwise = Nothing + addSizeN TooBig _ = TooBig + addSizeN (SizeIs n xs d) (I# m) + | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d + | otherwise = TooBig + where + n_tot = n +# m + + addSize TooBig _ = TooBig + addSize _ TooBig = TooBig + addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) + | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot + | otherwise = TooBig where - tot = n+m - xys = xs ++ ys + n_tot = n1 +# n2 + d_tot = d1 +# d2 + xys = xs ++ ys -splitCoreApps e - = go e [] - where - go (App fun arg) args = go fun (arg:args) - go fun args = (fun,args) + +\end{code} + +Code for manipulating sizes + +\begin{code} + +data ExprSize = TooBig + | SizeIs Int# -- Size found + [Id] -- Arguments cased herein + 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 0# [] n -- We don't count 1 for the constructor because we're + -- quite keen to get constructors into the open +scrutArg v = SizeIs 0# [v] 0# + +nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0# +nukeScrutDiscount TooBig = TooBig \end{code} %************************************************************************ @@ -437,7 +321,8 @@ purposes here, we assume we've got those. (2)~A ``size'' or ``cost,'' a single integer. (3)~An ``argument info'' vector. For this, what we have at the moment is a Boolean per argument position that says, ``I will look with great favour on an explicit constructor in this -position.'' +position.'' (4)~The ``discount'' to subtract if the expression +is being scrutinised. Assuming we have enough type- and value arguments (if not, we give up immediately), then we see if the ``discounted size'' is below some @@ -446,29 +331,60 @@ position where we're looking for a constructor AND WE HAVE ONE in our hands, we get a (again, semi-arbitrary) discount [proportion to the number of constructors in the type being scrutinized]. +If we're in the context of a scrutinee ( \tr{(case of A .. -> ...;.. )}) +and the expression in question will evaluate to a constructor, we use +the computed discount size *for the result only* rather than +computing the argument discounts. Since we know the result of +the expression is going to be taken apart, discounting its size +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 - (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size) - = enough_args n_vals_wanted arg_is_evald_s && - discounted_size <= opt_UnfoldingUseThreshold +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) + = if enough_args n_vals_wanted arg_is_evald_s && + size - discount <= opt_UnfoldingUseThreshold + then + True + else + False where - enough_args 0 evals = True - enough_args n [] = False - enough_args n (e:es) = enough_args (n-1) es - -- NB: don't take the length of arg_is_evald_s because when - -- called from couldBeSmallEnoughToInline it is infinite! - discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s) + enough_args n [] | n > 0 = False -- A function with no value args => don't unfold + enough_args _ _ = True -- Otherwise it's ok to try + + -- 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) + -- by inlining. + + -- we also discount 1 for each argument passed, because these will + -- reduce with the lambdas in the function (we count 1 for a lambda + -- in size_up). + + discount :: Int + discount = length (take n_vals_wanted arg_is_evald_s) + + round ( + opt_UnfoldingKeenessFactor * + fromInt (args_discount + result_discount) + ) + + args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s) + 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 + | is_evald = no_of_constrs * opt_UnfoldingConDiscount + | otherwise = 0 \end{code} We use this one to avoid exporting inlinings that we ``couldn't possibly @@ -476,43 +392,41 @@ use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code} -couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool -couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) guidance +couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool +couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance -certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool -certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) guidance +certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool +certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance \end{code} -Predicates -~~~~~~~~~~ +@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} -okToInline - :: FormSummary -- What the thing to be inlined is like - -> BinderInfo -- How the thing to be inlined occurs - -> Bool -- True => it's small enough to inline - -> Bool -- True => yes, inline it - --- If there's no danger of duplicating work, we can inline if it occurs once, or is small -okToInline form occ_info small_enough - | no_dup_danger form - = small_enough || one_occ +okToUnfoldInHiFile :: CoreExpr -> Bool +okToUnfoldInHiFile e = opt_UnfoldCasms || go e where - one_occ = case occ_info of - OneOcc _ _ _ n_alts _ -> n_alts <= 1 - other -> False - - no_dup_danger VarForm = True - no_dup_danger ValueForm = True - no_dup_danger BottomForm = True - no_dup_danger other = False - --- A non-WHNF can be inlined if it doesn't occur inside a lambda, --- and occurs exactly once or --- occurs once in each branch of a case and is small -okToInline OtherForm (OneOcc _ dup_danger _ n_alts _) small_enough - = not (isDupDanger dup_danger) && (n_alts <= 1 || small_enough) - -okToInline form any_occ small_enough = False + -- Race over an expression looking for CCalls.. + go (Var _) = True + go (Con (Literal lit) _) = not (isLitLitLit lit) + go (Con (PrimOp op) args) = okToUnfoldPrimOp op && all go args + go (Con con args) = True -- con args are always atomic + 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)) + go (Note _ body) = go body + go (Type _) = True + + -- ok to unfold a PrimOp as long as it's not a _casm_ + okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm + okToUnfoldPrimOp _ = True \end{code} -