X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=f83521c83f1ff4edab52c8c39304667f66e77171;hb=8a85f89b9e663ba0b69d92c730f54f066b15a6aa;hp=f32d5b1482c386aaf21d6979c22b8b7ad99e0962;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index f32d5b1..f83521c 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -42,6 +42,7 @@ import CoreSyn import PprCore () -- Instances import OccurAnal import CoreSubst hiding( substTy ) +import CoreFVs ( exprFreeVars ) import CoreUtils import Id import DataCon @@ -54,6 +55,7 @@ import TcType ( tcSplitDFunTy ) import Type import Coercion import PrelNames +import VarEnv ( mkInScopeSet ) import Bag import Util import FastTypes @@ -77,21 +79,6 @@ mkImplicitUnfolding :: CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr) -mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding -mkWwInlineRule id = mkInlineRule (InlWrapper id) - -mkInlineRule :: InlineRuleInfo -> CoreExpr -> Arity -> Unfolding -mkInlineRule inl_info expr arity - = mkCoreUnfolding True -- Note [Top-level flag on inline rules] - expr' arity - (InlineRule { ug_ir_info = inl_info, ug_small = small }) - where - expr' = simpleOptExpr expr - small = case calcUnfoldingGuidance (arity+1) expr' of - (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) - -> uncondInline arity_e size_e - _other {- actually UnfoldNever -} -> False - -- Note [Top-level flag on inline rules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Slight hack: note that mk_inline_rules conservatively sets the @@ -106,11 +93,12 @@ mkUnfolding top_lvl expr -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains -- two copies of the thing while the occurrence-analysed expression doesn't - -- Nevertheless, we don't occ-analyse before computing the size because the + -- Nevertheless, we *don't* occ-analyse before computing the size because the -- size computation bales out after a while, whereas occurrence analysis does not. -- -- This can occasionally mean that the guidance is very pessimistic; - -- it gets fixed up next round + -- it gets fixed up next round. And it should be rare, because large + -- let-bound things that are dead are usually caught by preInlineUnconditionally mkCoreUnfolding :: Bool -> CoreExpr -> Arity -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it @@ -118,17 +106,38 @@ mkCoreUnfolding top_lvl expr arity guidance = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, uf_arity = arity, uf_is_top = top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_cheap = exprIsCheap expr, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_cheap = exprIsCheap expr, uf_expandable = exprIsExpandable expr, uf_guidance = guidance } mkDFunUnfolding :: DataCon -> [Id] -> Unfolding mkDFunUnfolding con ops = DFunUnfolding con (map Var ops) +mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding +mkWwInlineRule id expr arity + = mkCoreUnfolding True (simpleOptExpr expr) arity + (InlineRule { ir_sat = InlUnSat, ir_info = InlWrapper id }) + mkCompulsoryUnfolding :: CoreExpr -> Unfolding -mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding True expr 0 UnfoldAlways -- Arity of unfolding doesn't matter +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding True expr + 0 -- Arity of unfolding doesn't matter + (InlineRule { ir_info = InlAlways, ir_sat = InlUnSat }) + +mkInlineRule :: InlSatFlag -> CoreExpr -> Arity -> Unfolding +mkInlineRule sat expr arity + = mkCoreUnfolding True -- Note [Top-level flag on inline rules] + expr' arity + (InlineRule { ir_sat = sat, ir_info = info }) + where + expr' = simpleOptExpr expr + info = if small then InlSmall else InlVanilla + small = case calcUnfoldingGuidance (arity+1) expr' of + (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) + -> uncondInline arity_e size_e + _other {- actually UnfoldNever -} -> False \end{code} @@ -183,6 +192,7 @@ Examples -------------- 0 42# 0 x + 0 True 2 f x 1 Just x 4 f (g x) @@ -382,7 +392,7 @@ funSize top_args fun n_val_args conSize :: DataCon -> Int -> ExprSize conSize dc n_val_args - | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) + | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) -- Like variables | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1)) | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1)) -- Treat a constructors application as size 1, regardless of how @@ -549,7 +559,6 @@ certainlyWillInline :: Unfolding -> Bool -- Sees if the unfolding is pretty certain to inline certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance }) = case guidance of - UnfoldAlways {} -> True UnfoldNever -> False InlineRule {} -> True UnfoldIfGoodArgs { ug_size = size} @@ -598,11 +607,13 @@ instance Outputable ArgSummary where data CallCtxt = BoringCtxt - | ArgCtxt Bool -- We're somewhere in the RHS of function with rules - -- => be keener to inline - Int -- We *are* the argument of a function with this arg discount - -- => be keener to inline - -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt + | ArgCtxt -- We are somewhere in the argument of a function + Bool -- True <=> we're somewhere in the RHS of function with rules + -- False <=> we *are* the argument of a function with non-zero + -- arg discount + -- OR + -- we *are* the RHS of a let Note [RHS of lets] + -- In both cases, be a little keener to inline | ValAppCtxt -- We're applied to at least one value arg -- This arises when we have ((f x |> co) y) @@ -612,10 +623,10 @@ data CallCtxt = BoringCtxt -- that decomposes its scrutinee instance Outputable CallCtxt where - ppr BoringCtxt = ptext (sLit "BoringCtxt") - ppr (ArgCtxt rules disc) = ptext (sLit "ArgCtxt") <> ppr (rules,disc) - ppr CaseCtxt = ptext (sLit "CaseCtxt") - ppr ValAppCtxt = ptext (sLit "ValAppCtxt") + ppr BoringCtxt = ptext (sLit "BoringCtxt") + ppr (ArgCtxt rules) = ptext (sLit "ArgCtxt") <+> ppr rules + ppr CaseCtxt = ptext (sLit "CaseCtxt") + ppr ValAppCtxt = ptext (sLit "ValAppCtxt") callSiteInline dflags active_inline id lone_variable arg_infos cont_info = let @@ -658,23 +669,19 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info = case guidance of UnfoldNever -> False - UnfoldAlways -> True - -- UnfoldAlways => there is no top-level binding for - -- these things, so we must inline it. Only a few - -- primop-like things have compulsory unfoldings (see - -- MkId.lhs). Ignore is_active because we want to - -- inline even if SimplGently is on. - - InlineRule { ug_ir_info = inl_info, ug_small = uncond_inline } + InlineRule { ir_info = inl_info, ir_sat = sat } + | InlAlways <- inl_info -> True -- No top-level binding, so inline! + -- Ignore is_active because we want to + -- inline even if SimplGently is on. | not active_inline -> False | n_val_args < uf_arity -> yes_unsat -- Not enough value args - | uncond_inline -> True -- Note [INLINE for small functions] + | InlSmall <- inl_info -> True -- Note [INLINE for small functions] | otherwise -> some_benefit -- Saturated or over-saturated where -- See Note [Inlining an InlineRule] - yes_unsat = case inl_info of - InlSat -> False - _other -> interesting_args + yes_unsat = case sat of + InlSat -> False + InlUnSat -> interesting_args UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } | not active_inline -> False @@ -705,6 +712,15 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info } \end{code} +Note [RHS of lets] +~~~~~~~~~~~~~~~~~~ +Be a tiny bit keener to inline in the RHS of a let, because that might +lead to good thing later + f y = (y,y,y) + g y = let x = f y in ...(case x of (a,b,c) -> ...) ... +We'd inline 'f' if the call was in a case context, and it kind-of-is, +only we can't see it. So we treat the RHS of a let as not-totally-boring. + Note [Unsaturated applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When a call is not saturated, we *still* inline if one of the @@ -740,7 +756,7 @@ Consider {-# INLINE f #-} g y = f y Then f's RHS is no larger than its LHS, so we should inline it into even the most boring context. (We do so if there is no INLINE -pragma!) That's the reason for the 'inl_small' flag on an InlineRule. +pragma!) That's the reason for the 'ug_small' flag on an InlineRule. Note [Things to watch] @@ -804,6 +820,11 @@ 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: arguably, we should inline in ArgCtxt only if the result of the +call is at least CONLIKE. At least for the cases where we use ArgCtxt +for the RHS of a 'let', we only profit from the inlining if we get a +CONLIKE thing (modulo lets). + Note [Lone variables] ~~~~~~~~~~~~~~~~~~~~~ The "lone-variable" case is important. I spent ages messing about @@ -896,7 +917,7 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info CaseCtxt -> 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 + -- constructors; but we only want to invoke that large discount -- when there's a case continuation. -- Otherwise we, rather arbitrarily, threshold it. Yuk. -- But we want to aovid inlining large functions that return @@ -934,7 +955,7 @@ Note [Conlike is interesting] Consider f d = ...((*) d x y)... ... f (df d')... -where df is con-like. Then we'd really like to inline so that the +where df is con-like. Then we'd really like to inline 'f' so that the rule for (*) (df d) can fire. To do this a) we give a discount for being an argument of a class-op (eg (*) d) b) we say that a con-like argument (eg (df d)) is interesting @@ -956,10 +977,11 @@ interestingArg e = go e 0 -- data constructors here | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding | n > 0 = NonTrivArg -- Saturated or unknown call - | evald_unfolding = ValueArg -- n==0; look for a value + | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding + -- See Note [Conlike is interesting] | otherwise = TrivArg -- n==0, no useful unfolding where - evald_unfolding = isEvaldUnfolding (idUnfolding v) + conlike_unfolding = isConLikeUnfolding (idUnfolding v) go (Type _) _ = TrivArg go (App fn (Type _)) n = go fn n @@ -1070,7 +1092,8 @@ exprIsConApp_maybe (Cast expr co) let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, ppr arg_tys, ppr dc_args, ppr _dc_univ_args, ppr ex_args, ppr val_args] - ASSERT2( coreEqType from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) + in + ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) #endif @@ -1110,6 +1133,9 @@ exprIsConApp_maybe expr analyse _ _ = Nothing ----------- + in_scope = mkInScopeSet (exprFreeVars expr) + + ----------- beta (Lam v body) pairs (arg : args) | isTypeArg arg = beta body ((v,arg):pairs) args @@ -1118,12 +1144,13 @@ exprIsConApp_maybe expr = Nothing beta fun pairs args - = case analyse (substExpr (mkOpenSubst pairs) fun) args of + = case analyse (substExpr subst fun) args of Nothing -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $ Nothing Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $ Just ans where + subst = mkOpenSubst in_scope pairs -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]