X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUnfold.lhs;h=247e969fdefd4b5b1cc1f746b6e874b3a12cb3f9;hp=39893059856b1fba1a22d2f1a847b948ffe22cf1;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1 diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 3989305..247e969 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -6,53 +6,54 @@ Unfoldings (which can travel across module boundaries) are in Core syntax (namely @CoreExpr@s). -The type @UnfoldingDetails@ sits ``above'' simply-Core-expressions +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 @GenForm@ unfolding, you will +literal''). In the corner of a @SimpleUnfolding@ unfolding, you will find, unsurprisingly, a Core expression. \begin{code} #include "HsVersions.h" module CoreUnfold ( - UnfoldingDetails(..), UnfoldingGuidance(..), -- types - FormSummary(..), + SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types - mkFormSummary, - mkGenForm, + FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, + + smallEnoughToInline, couldBeSmallEnoughToInline, + + mkSimpleUnfolding, mkMagicUnfolding, - modifyUnfoldingDetails, calcUnfoldingGuidance, mentionedInUnfolding ) where -import Ubiq -import IdLoop -- for paranoia checking; +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) -- for paranoia checking; -- and also to get mkMagicUnfoldingFun -import PrelLoop -- for paranoia checking +IMPORT_DELOOPER(PrelLoop) -- for paranoia checking import Bag ( emptyBag, unitBag, unionBags, Bag ) -import BinderInfo ( oneTextualOcc, oneSafeOcc ) import CgCompInfo ( uNFOLDING_CHEAP_OP_COST, uNFOLDING_DEAR_OP_COST, uNFOLDING_NOREP_LIT_COST ) import CoreSyn -import CoreUtils ( coreExprType, manifestlyWHNF ) +import CoreUtils ( coreExprType ) import CostCentre ( ccMentionsId ) -import Id ( IdSet(..), GenId{-instances-} ) -import IdInfo ( bottomIsGuaranteed ) +import Id ( idType, getIdArity, isBottomingId, + SYN_IE(IdSet), GenId{-instances-} ) +import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) ) +import IdInfo ( arityMaybe, bottomIsGuaranteed ) import Literal ( isNoRepLit, isLitLitLit ) import Pretty -import PrimOp ( primOpCanTriggerGC, PrimOp(..) ) import TyCon ( tyConFamilySize ) -import Type ( getAppDataTyCon ) +import Type ( maybeAppDataTyConExpandingDicts ) import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, addOneToUniqSet, unionUniqSets ) -import Usage ( UVar(..) ) -import Util ( isIn, panic ) +import Usage ( SYN_IE(UVar) ) +import Util ( isIn, panic, assertPanic ) whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)" getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)" @@ -60,177 +61,146 @@ getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromTy %************************************************************************ %* * -\subsection{@UnfoldingDetails@ and @UnfoldingGuidance@ types} +\subsection{@Unfolding@ and @UnfoldingGuidance@ types} %* * %************************************************************************ -(And @FormSummary@, too.) - \begin{code} -data UnfoldingDetails - = NoUnfoldingDetails - - | LitForm - Literal - - | OtherLitForm - [Literal] -- It is a literal, but definitely not one of these - - | ConForm - Id -- The constructor - [CoreArg] -- Type/value arguments; NB OutArgs, already cloned - - | OtherConForm - [Id] -- It definitely isn't one of these constructors - -- This captures the situation in the default branch of - -- a case: case x of - -- c1 ... -> ... - -- c2 ... -> ... - -- v -> default-rhs - -- Then in default-rhs we know that v isn't c1 or c2. - -- - -- NB. In the degenerate: case x of {v -> default-rhs} - -- x will be bound to - -- OtherConForm [] - -- which captures the idea that x is eval'd but we don't - -- know which constructor. - - - | GenForm - Bool -- True <=> At most one textual occurrence of the - -- binder in its scope, *or* - -- if we are happy to duplicate this - -- binding. - FormSummary -- Tells whether the template is a WHNF or bottom - TemplateOutExpr -- The template - UnfoldingGuidance -- Tells about the *size* of the template. - - | MagicForm +data Unfolding + = NoUnfolding + | CoreUnfolding SimpleUnfolding + | MagicUnfolding Unique -- of the Id whose magic unfolding this is MagicUnfoldingFun + +data SimpleUnfolding + = SimpleUnfolding FormSummary -- Tells whether the template is a WHNF or bottom + UnfoldingGuidance -- Tells about the *size* of the template. + TemplateOutExpr -- The template + type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar -- An OutExpr with occurrence info attached. This is used as -- a template in GeneralForms. -mkMagicUnfolding :: Unique -> UnfoldingDetails -mkMagicUnfolding tag = MagicForm tag (mkMagicUnfoldingFun tag) - -data FormSummary - = WhnfForm -- Expression is WHNF - | 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 WhnfForm = ppStr "WHNF" - ppr sty BottomForm = ppStr "Bot" - ppr sty OtherForm = ppStr "Other" ---???mkFormSummary :: StrictnessInfo -> GenCoreExpr bndr Id -> FormSummary -mkFormSummary si expr - | manifestlyWHNF expr = WhnfForm - | bottomIsGuaranteed si = BottomForm +mkSimpleUnfolding form guidance template + = SimpleUnfolding form guidance template - -- Chances are that the Id will be decorated with strictness info - -- telling that the RHS is definitely bottom. This *might* not be the - -- case, if it's been a while since strictness analysis, but leaving out - -- the test for manifestlyBottom makes things a little more efficient. - -- We can always put it back... - -- | manifestlyBottom expr = BottomForm +mkMagicUnfolding :: Unique -> Unfolding +mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag) - | otherwise = OtherForm -\end{code} -\begin{code} data UnfoldingGuidance - = UnfoldNever -- Don't do it! - + = UnfoldNever | UnfoldAlways -- There is no "original" definition, -- so you'd better unfold. Or: something -- so cheap to unfold (e.g., 1#) that -- you should do it absolutely always. - | EssentialUnfolding -- Like UnfoldAlways, but you *must* do - -- it absolutely always. - -- This is what we use for data constructors - -- and PrimOps, because we don't feel like - -- generating curried versions "just in case". - - | UnfoldIfGoodArgs Int -- if "m" type args and "n" value args; and - Int -- those val args are manifestly data constructors - [Bool] -- the val-arg positions marked True + | 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). + -- be possible). One elt of the list per *value* arg. Int -- The "size" of the unfolding; to be elaborated -- later. ToDo - - | BadUnfolding -- This is used by TcPragmas if the *lazy* - -- lintUnfolding test fails - -- It will never escape from the IdInfo as - -- it is caught by getInfo_UF and converted - -- to NoUnfoldingDetails \end{code} \begin{code} instance Outputable UnfoldingGuidance where - ppr sty UnfoldNever = ppStr "_N_" ppr sty UnfoldAlways = ppStr "_ALWAYS_" - ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface +-- ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface ppr sty (UnfoldIfGoodArgs t v cs size) = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v, if null cs -- always print *something* then ppChar 'X' - else ppBesides (map pp_c cs), + else ppBesides (map (ppStr . show) cs), ppInt size ] - where - pp_c False = ppChar 'X' - pp_c True = ppChar 'C' \end{code} %************************************************************************ %* * -\subsection{@mkGenForm@ and @modifyUnfoldingDetails@} +\subsection{Figuring out things about expressions} %* * %************************************************************************ \begin{code} -mkGenForm :: Bool -- Ok to Dup code down different case branches, - -- because of either a flag saying so, - -- or alternatively the object is *SMALL* - -> BinderInfo -- - -> FormSummary - -> TemplateOutExpr -- Template - -> UnfoldingGuidance -- Tells about the *size* of the template. - -> UnfoldingDetails - -mkGenForm safe_to_dup occ_info WhnfForm template guidance - = GenForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance - -mkGenForm safe_to_dup occ_info form_summary template guidance - | oneSafeOcc safe_to_dup occ_info -- Non-WHNF with only safe occurrences - = GenForm True form_summary template guidance - - | otherwise -- Not a WHNF, many occurrences - = NoUnfoldingDetails -\end{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 -\begin{code} -modifyUnfoldingDetails - :: Bool -- OK to dup - -> BinderInfo -- New occurrence info for the thing - -> UnfoldingDetails - -> UnfoldingDetails +instance Outputable FormSummary where + ppr sty VarForm = ppStr "Var" + ppr sty ValueForm = ppStr "Value" + ppr sty BottomForm = ppStr "Bot" + ppr sty OtherForm = ppStr "Other" -modifyUnfoldingDetails ok_to_dup occ_info - (GenForm only_one form_summary template guidance) - | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance +mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary -modifyUnfoldingDetails ok_to_dup occ_info other = other +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 + go 0 (Var f) = VarForm + go n (Var f) = case (arityMaybe (getIdArity f)) of + Just arity | n < arity -> 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} @@ -239,9 +209,9 @@ modifyUnfoldingDetails ok_to_dup occ_info other = other \begin{code} calcUnfoldingGuidance - :: Bool -- True <=> OK if _scc_s appear in expr - -> Int -- bomb out if size gets bigger than this - -> CoreExpr -- expression to look at + :: Bool -- True <=> OK if _scc_s appear in expr + -> Int -- bomb out if size gets bigger than this + -> CoreExpr -- expression to look at -> UnfoldingGuidance calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr @@ -257,8 +227,18 @@ calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr uf = UnfoldIfGoodArgs (length ty_binders) (length val_binders) - [ b `is_elem` cased_args | b <- val_binders ] + (map discount_for val_binders) size + + discount_for b + | is_data && b `is_elem` cased_args = tyConFamilySize tycon + | otherwise = 0 + where + (is_data, tycon) + = --trace "CoreUnfold.getAppDataTyConExpandingDicts:1" $ + case (maybeAppDataTyConExpandingDicts (idType b)) of + Nothing -> (False, panic "discount") + Just (tc,_,_) -> (True, tc) in -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr)) uf @@ -289,7 +269,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr size_up (SCC lbl body) = if scc_s_OK then size_up body else Nothing - size_up (Coerce _ _ body) = size_up body + size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing size_up (Con con args) = -- 1 + # of val args sizeN (1 + numValArgs args) @@ -333,7 +313,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr ------------ size_up_alts scrut_ty (AlgAlts alts deflt) = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts - `addSizeN` (tyConFamilySize tycon) + `addSizeN` (if is_data then tyConFamilySize tycon else 1{-??-}) -- 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 @@ -342,7 +322,11 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr size_alg_alt (con,args,rhs) = size_up rhs -- Don't charge for args, so that wrappers look cheap - (tycon, _, _) = _trace "getAppDataTyCon.CoreUnfold" $ getAppDataTyCon scrut_ty + (is_data,tycon) + = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $ + case (maybeAppDataTyConExpandingDicts scrut_ty) of + Nothing -> (False, panic "size_up_alts") + Just (tc,_,_) -> (True, tc) size_up_alts _ (PrimAlts alts deflt) = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts @@ -370,7 +354,6 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr sizeZero = Just (0, []) sizeOne = Just (1, []) sizeN n = Just (n, []) - sizeVar v = Just (0, [v]) addSizeN Nothing _ = Nothing addSizeN (Just (n, xs)) m @@ -391,6 +374,61 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr %************************************************************************ %* * +\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +%* * +%************************************************************************ + +We have very limited information about an unfolding expression: (1)~so +many type arguments and so many value arguments expected---for our +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.'' + +Assuming we have enough type- and value arguments (if not, we give up +immediately), then we see if the ``discounted size'' is below some +(semi-arbitrary) threshold. It works like this: for every argument +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]. + +\begin{code} +smallEnoughToInline :: Int -> Int -- Constructor discount and size threshold + -> [Bool] -- Evaluated-ness of value arguments + -> UnfoldingGuidance + -> Bool -- True => unfold it + +smallEnoughToInline con_discount size_threshold _ UnfoldAlways = True +smallEnoughToInline con_discount size_threshold _ UnfoldNever = False +smallEnoughToInline con_discount size_threshold arg_is_evald_s + (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size) + = n_vals_wanted <= length arg_is_evald_s && + discounted_size <= size_threshold + + where + discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s) + + arg_discount no_of_constrs is_evald + | is_evald = 1 + no_of_constrs * con_discount + | otherwise = 1 +\end{code} + +We use this one to avoid exporting inlinings that we ``couldn't possibly +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 :: Int -> Int -- Constructor discount and size threshold + -> UnfoldingGuidance + -> Bool -- True => unfold it + +couldBeSmallEnoughToInline con_discount size_threshold guidance + = smallEnoughToInline con_discount size_threshold (repeat True) guidance +\end{code} + +%************************************************************************ +%* * \subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces} %* * %************************************************************************