X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=eaeba103c73ae8f3b59493887329bc5ca55d992b;hb=c0778bd3da61e80948e5813255ee82cdfebe0fdf;hp=767006076d60c7ed9d5e07bd9965442236865cac;hpb=fa1c8a7e7013b1e9a37326b80abadec737c9347e;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 7670060..eaeba10 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -18,10 +18,11 @@ find, unsurprisingly, a Core expression. module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types - noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding, + noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding, + mkCompulsoryUnfolding, seqUnfolding, evaldUnfolding, mkOtherCon, otherCons, unfoldingTemplate, maybeUnfoldingTemplate, - isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding, + isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding, hasUnfolding, hasSomeUnfolding, neverUnfold, couldBeSmallEnoughToInline, @@ -31,23 +32,24 @@ module CoreUnfold ( ) where -#include "HsVersions.h" - import StaticFlags import DynFlags import CoreSyn import PprCore () -- Instances import OccurAnal +import CoreSubst ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst + , lookupIdSubst, substBndr, substBndrs, substRecBndrs ) import CoreUtils import Id import DataCon import Literal import PrimOp import IdInfo -import Type +import Type hiding( substTy, extendTvSubst ) import PrelNames import Bag import FastTypes +import FastString import Outputable \end{code} @@ -63,6 +65,16 @@ import Outputable mkTopUnfolding :: CoreExpr -> Unfolding mkTopUnfolding expr = mkUnfolding True {- Top level -} expr +mkImplicitUnfolding :: CoreExpr -> Unfolding +-- For implicit Ids, do a tiny bit of optimising first +mkImplicitUnfolding expr + = CoreUnfolding (simpleOptExpr emptySubst expr) + True + (exprIsHNF expr) + (exprIsCheap expr) + (exprIsExpandable expr) + (calcUnfoldingGuidance opt_UF_CreationThreshold expr) + mkUnfolding :: Bool -> CoreExpr -> Unfolding mkUnfolding top_lvl expr = CoreUnfolding (occurAnalyseExpr expr) @@ -74,6 +86,8 @@ mkUnfolding top_lvl expr (exprIsCheap expr) -- OK to inline inside a lambda + (exprIsExpandable expr) + (calcUnfoldingGuidance opt_UF_CreationThreshold expr) -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains @@ -85,11 +99,11 @@ mkUnfolding top_lvl expr -- it gets fixed up next round instance Outputable Unfolding where - ppr NoUnfolding = ptext SLIT("No unfolding") - ppr (OtherCon cs) = ptext SLIT("OtherCon") <+> ppr cs - ppr (CompulsoryUnfolding e) = ptext SLIT("Compulsory") <+> ppr e - ppr (CoreUnfolding e top hnf cheap g) - = ptext SLIT("Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g, + ppr NoUnfolding = ptext (sLit "No unfolding") + ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs + ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e + ppr (CoreUnfolding e top hnf cheap expable g) + = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g, ppr e] mkCompulsoryUnfolding :: CoreExpr -> Unfolding @@ -106,9 +120,9 @@ mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded \begin{code} instance Outputable UnfoldingGuidance where - ppr UnfoldNever = ptext SLIT("NEVER") + ppr UnfoldNever = ptext (sLit "NEVER") ppr (UnfoldIfGoodArgs v cs size discount) - = hsep [ ptext SLIT("IF_ARGS"), int v, + = hsep [ ptext (sLit "IF_ARGS"), int v, brackets (hsep (map int cs)), int size, int discount ] @@ -298,7 +312,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr | fun `hasKey` buildIdKey = buildSize | fun `hasKey` augmentIdKey = augmentSize | otherwise - = case globalIdDetails fun of + = case idDetails fun of DataConWorkId dc -> conSizeN dc (valArgCount args) FCallId _ -> sizeN opt_UF_DearOp @@ -473,13 +487,13 @@ couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold certainlyWillInline :: Unfolding -> Bool -- Sees if the unfolding is pretty certain to inline -certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _)) +certainlyWillInline (CoreUnfolding _ _ _ is_cheap _ (UnfoldIfGoodArgs n_vals _ size _)) = is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold certainlyWillInline _ = False smallEnoughToInline :: Unfolding -> Bool -smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _)) +smallEnoughToInline (CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ _ size _)) = size <= opt_UF_UseThreshold smallEnoughToInline _ = False @@ -525,13 +539,18 @@ data CallCtxt = BoringCtxt -- => be keener to inline -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt + | ValAppCtxt -- We're applied to at least one value arg + -- This arises when we have ((f x |> co) y) + -- Then the (f x) has argument 'x' but in a ValAppCtxt + | CaseCtxt -- We're the scrutinee of a case -- that decomposes its scrutinee instance Outputable CallCtxt where - ppr BoringCtxt = ptext SLIT("BoringCtxt") - ppr (ArgCtxt _ _) = ptext SLIT("ArgCtxt") - ppr CaseCtxt = ptext SLIT("CaseCtxt") + ppr BoringCtxt = ptext (sLit "BoringCtxt") + ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt") + ppr CaseCtxt = ptext (sLit "CaseCtxt") + ppr ValAppCtxt = ptext (sLit "ValAppCtxt") callSiteInline dflags active_inline id lone_variable arg_infos cont_info = case idUnfolding id of { @@ -545,7 +564,7 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info -- compulsory unfoldings (see MkId.lhs). -- We don't allow them to be inactive - CoreUnfolding unf_template is_top is_value is_cheap guidance -> + CoreUnfolding unf_template is_top is_value is_cheap is_expable guidance -> let result | yes_or_no = Just unf_template @@ -575,10 +594,13 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info -> True | otherwise - -> some_benefit && small_enough + -> some_benefit && small_enough && inline_enough_args where enough_args = n_val_args >= n_vals_wanted + inline_enough_args = + not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args + some_benefit = or arg_infos || really_interesting_cont -- There must be something interesting @@ -596,8 +618,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info = case cont_info of BoringCtxt -> not is_top && n_vals_wanted > 0 -- Note [Nested functions] CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables] - ArgCtxt {} -> True - -- Was: n_vals_wanted > 0; but see test eyeball/inline1.hs + ArgCtxt {} -> n_vals_wanted > 0 -- Note [Inlining in ArgCtxt] + ValAppCtxt -> True -- Note [Cast then apply] small_enough = (size - discount) <= opt_UF_UseThreshold discount = computeDiscount n_vals_wanted arg_discounts @@ -605,7 +627,7 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info res_discount' = case cont_info of BoringCtxt -> 0 CaseCtxt -> res_discount - ArgCtxt _ _ -> 4 `min` res_discount + _other -> 4 `min` res_discount -- res_discount can be very large when a function returns -- construtors; but we only want to invoke that large discount -- when there's a case continuation. @@ -615,14 +637,15 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info in if dopt Opt_D_dump_inlinings dflags then - pprTrace "Considering inlining" - (ppr id <+> vcat [text "active:" <+> ppr active_inline, - text "arg infos" <+> ppr arg_infos, - text "interesting continuation" <+> ppr cont_info, - text "is value:" <+> ppr is_value, - text "is cheap:" <+> ppr is_cheap, - text "guidance" <+> ppr guidance, - text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) + pprTrace ("Considering inlining: " ++ showSDoc (ppr id)) + (vcat [text "active:" <+> ppr active_inline, + text "arg infos" <+> ppr arg_infos, + text "interesting continuation" <+> ppr cont_info, + text "is value:" <+> ppr is_value, + text "is cheap:" <+> ppr is_cheap, + text "is expandable:" <+> ppr is_expable, + text "guidance" <+> ppr guidance, + text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) result else result @@ -641,8 +664,31 @@ branches. Then inlining it doesn't increase allocation, but it does increase the chance that the constructor won't be allocated at all in the branches that don't use it. +Note [Cast then apply] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + myIndex = __inline_me ( (/\a. ) |> co ) + co :: (forall a. a -> a) ~ (forall a. T a) + ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... + +We need to inline myIndex to unravel this; but the actual call (myIndex a) has +no value arguments. The ValAppCtxt gives it enough incentive to inline. + +Note [Inlining in ArgCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The condition (n_vals_wanted > 0) here is very important, because otherwise +we end up inlining top-level stuff into useless places; eg + x = I# 3# + f = \y. g x +This can make a very big difference: it adds 16% to nofib 'integer' allocs, +and 20% to 'power'. + +At one stage I replaced this condition by 'True' (leading to the above +slow-down). The motivation was test eyeball/inline1.hs; but that seems +to work ok now. + Note [Lone variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~ The "lone-variable" case is important. I spent ages messing about with unsatisfactory varaints, but this is nice. The idea is that if a variable appears all alone @@ -721,3 +767,75 @@ computeDiscount n_vals_wanted arg_discounts result_discount arg_infos mk_arg_discount discount is_evald | is_evald = discount | otherwise = 0 \end{code} + +%************************************************************************ +%* * + The Very Simple Optimiser +%* * +%************************************************************************ + + +\begin{code} +simpleOptExpr :: Subst -> CoreExpr -> CoreExpr +-- Return an occur-analysed and slightly optimised expression +-- The optimisation is very straightforward: just +-- inline non-recursive bindings that are used only once, +-- or wheere the RHS is trivial + +simpleOptExpr subst expr + = go subst (occurAnalyseExpr expr) + where + go subst (Var v) = lookupIdSubst subst v + go subst (App e1 e2) = App (go subst e1) (go subst e2) + go subst (Type ty) = Type (substTy subst ty) + go _ (Lit lit) = Lit lit + go subst (Note note e) = Note note (go subst e) + go subst (Cast e co) = Cast (go subst e) (substTy subst co) + go subst (Let bind body) = go_bind subst bind body + go subst (Lam bndr body) = Lam bndr' (go subst' body) + where + (subst', bndr') = substBndr subst bndr + + go subst (Case e b ty as) = Case (go subst e) b' + (substTy subst ty) + (map (go_alt subst') as) + where + (subst', b') = substBndr subst b + + + ---------------------- + go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + + ---------------------- + go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss')) + (go subst' body) + where + (bndrs, rhss) = unzip prs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' = map (go subst') rhss + + go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body + + ---------------------- + go_nonrec subst b (Type ty') body + | isTyVar b = go (extendTvSubst subst b ty') body + -- let a::* = TYPE ty in + go_nonrec subst b r' body + | isId b -- let x = e in + , exprIsTrivial r' || safe_to_inline (idOccInfo b) + = go (extendIdSubst subst b r') body + go_nonrec subst b r' body + = Let (NonRec b' r') (go subst' body) + where + (subst', b') = substBndr subst b + + ---------------------- + -- Unconditionally safe to inline + safe_to_inline :: OccInfo -> Bool + safe_to_inline IAmDead = True + safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br + safe_to_inline (IAmALoopBreaker {}) = False + safe_to_inline NoOccInfo = False +\end{code} \ No newline at end of file