X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=fa9f5dcfb398a3951cd3aee6e97581e491a7a057;hb=cd0e2c0cc3005c3f5e74eeda57dc9cebbe1bac7e;hp=9e3bb4a5c0914df031a4b0a795051fff97e67178;hpb=958d03f3075647dd4b361bb1917fe30ef7355945;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 9e3bb4a..fa9f5dc 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -79,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 @@ -120,17 +105,37 @@ 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} @@ -551,7 +556,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} @@ -600,11 +604,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) @@ -614,10 +620,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 @@ -660,23 +666,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 @@ -707,6 +709,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 @@ -742,7 +753,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] @@ -806,6 +817,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 @@ -898,7 +914,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 @@ -936,7 +952,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 @@ -958,10 +974,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