X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=5883013a06d69ba760312bcf610d7d99665ebee8;hp=bcd03b2780b69242e87d852367a33b89ea747fd0;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=e934294fd6c4a3beb150b5a6c03299d8c42fd306 diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index bcd03b2..5883013 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -19,13 +19,14 @@ module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types noUnfolding, mkImplicitUnfolding, - mkTopUnfolding, mkUnfolding, mkCoreUnfolding, - mkInlineRule, mkWwInlineRule, + mkUnfolding, mkCoreUnfolding, + mkTopUnfolding, mkSimpleUnfolding, + mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule, mkCompulsoryUnfolding, mkDFunUnfolding, interestingArg, ArgSummary(..), - couldBeSmallEnoughToInline, + couldBeSmallEnoughToInline, inlineBoringOk, certainlyWillInline, smallEnoughToInline, callSiteInline, CallCtxt(..), @@ -40,9 +41,11 @@ import StaticFlags import DynFlags import CoreSyn import PprCore () -- Instances -import OccurAnal +import TcType ( tcSplitDFunTy ) +import OccurAnal ( occurAnalyseExpr ) import CoreSubst hiding( substTy ) import CoreFVs ( exprFreeVars ) +import CoreArity ( manifestArity, exprBotStrictness_maybe ) import CoreUtils import Id import DataCon @@ -51,17 +54,17 @@ import Literal import PrimOp import IdInfo import BasicTypes ( Arity ) -import TcType ( tcSplitDFunTy ) -import Type +import Type import Coercion import PrelNames import VarEnv ( mkInScopeSet ) import Bag import Util +import Pair import FastTypes import FastString import Outputable - +import Data.Maybe \end{code} @@ -73,8 +76,7 @@ import Outputable \begin{code} mkTopUnfolding :: Bool -> CoreExpr -> Unfolding -mkTopUnfolding is_bottoming expr - = mkUnfolding True {- Top level -} is_bottoming expr +mkTopUnfolding = mkUnfolding InlineRhs True {- Top level -} mkImplicitUnfolding :: CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first @@ -86,10 +88,78 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) -- top-level flag to True. It gets set more accurately by the simplifier -- Simplify.simplUnfolding. -mkUnfolding :: Bool -> Bool -> CoreExpr -> Unfolding -mkUnfolding top_lvl is_bottoming expr +mkSimpleUnfolding :: CoreExpr -> Unfolding +mkSimpleUnfolding = mkUnfolding InlineRhs False False + +mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding +mkDFunUnfolding dfun_ty ops + = DFunUnfolding dfun_nargs data_con ops + where + (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty + dfun_nargs = length tvs + n_theta + data_con = classDataCon cls + +mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding +mkWwInlineRule id expr arity + = mkCoreUnfolding (InlineWrapper id) True + (simpleOptExpr expr) arity + (UnfWhen unSaturatedOk boringCxtNotOk) + +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding InlineCompulsory True + (simpleOptExpr expr) 0 -- Arity of unfolding doesn't matter + (UnfWhen unSaturatedOk boringCxtOk) + +mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding +mkInlineUnfolding mb_arity expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' arity + (UnfWhen unsat_ok boring_ok) + where + expr' = simpleOptExpr expr + (unsat_ok, arity) = case mb_arity of + Nothing -> (unSaturatedOk, manifestArity expr') + Just ar -> (needSaturated, ar) + + boring_ok = inlineBoringOk expr' + +mkInlinableUnfolding :: CoreExpr -> Unfolding +mkInlinableUnfolding expr + = mkUnfolding InlineStable True is_bot expr' + where + expr' = simpleOptExpr expr + is_bot = isJust (exprBotStrictness_maybe expr') +\end{code} + +Internal functions + +\begin{code} +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> Arity -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr arity guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = src, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_cheap = exprIsCheap expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + +mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding src top_lvl is_bottoming expr + | top_lvl && is_bottoming + , not (exprIsTrivial expr) + = NoUnfolding -- See Note [Do not inline top-level bottoming functions] + | otherwise = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - uf_src = InlineRhs, + uf_src = src, uf_arity = arity, uf_is_top = top_lvl, uf_is_value = exprIsHNF expr, @@ -99,7 +169,7 @@ mkUnfolding top_lvl is_bottoming expr uf_guidance = guidance } where is_cheap = exprIsCheap expr - (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) + (arity, guidance) = calcUnfoldingGuidance is_cheap 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 @@ -110,52 +180,8 @@ mkUnfolding top_lvl is_bottoming expr -- This can occasionally mean that the guidance is very pessimistic; -- 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 -> UnfoldingSource -> CoreExpr - -> Arity -> UnfoldingGuidance -> Unfolding --- Occurrence-analyses the expression before capturing it -mkCoreUnfolding top_lvl src expr arity guidance - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - uf_src = src, - uf_arity = arity, - uf_is_top = top_lvl, - 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 (InlineWrapper id) - (simpleOptExpr expr) arity - (UnfWhen unSaturatedOk boringCxtNotOk) - -mkCompulsoryUnfolding :: CoreExpr -> Unfolding -mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding True InlineCompulsory - expr 0 -- Arity of unfolding doesn't matter - (UnfWhen unSaturatedOk boringCxtOk) - -mkInlineRule :: Bool -> CoreExpr -> Arity -> Unfolding -mkInlineRule unsat_ok expr arity - = mkCoreUnfolding True InlineRule -- Note [Top-level flag on inline rules] - expr' arity - (UnfWhen unsat_ok boring_ok) - where - expr' = simpleOptExpr expr - boring_ok = case calcUnfoldingGuidance True -- Treat as cheap - False -- But not bottoming - (arity+1) expr' of - (_, UnfWhen _ boring_ok) -> boring_ok - _other -> boringCxtNotOk - -- See Note [INLINE for small functions] \end{code} - %************************************************************************ %* * \subsection{The UnfoldingGuidance type} @@ -163,15 +189,35 @@ mkInlineRule unsat_ok expr arity %************************************************************************ \begin{code} +inlineBoringOk :: CoreExpr -> Bool +-- See Note [INLINE for small functions] +-- True => the result of inlining the expression is +-- no bigger than the expression itself +-- eg (\x y -> f y x) +-- This is a quick and dirty version. It doesn't attempt +-- to deal with (\x y z -> x (y z)) +-- The really important one is (x `cast` c) +inlineBoringOk e + = go 0 e + where + go :: Int -> CoreExpr -> Bool + go credit (Lam x e) | isId x = go (credit+1) e + | otherwise = go credit e + go credit (App f (Type {})) = go credit f + go credit (App f a) | credit > 0 + , exprIsTrivial a = go (credit-1) f + go credit (Note _ e) = go credit e + go credit (Cast e _) = go credit e + go _ (Var {}) = boringCxtOk + go _ _ = boringCxtNotOk + calcUnfoldingGuidance :: Bool -- True <=> the rhs is cheap, or we want to treat it -- as cheap (INLINE things) - -> Bool -- True <=> this is a top-level unfolding for a - -- diverging function; don't inline this -> Int -- Bomb out if size gets bigger than this -> CoreExpr -- Expression to look at -> (Arity, UnfoldingGuidance) -calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr +calcUnfoldingGuidance expr_is_cheap bOMB_OUT_SIZE expr = case collectBinders expr of { (bndrs, body) -> let val_bndrs = filter isId bndrs @@ -181,12 +227,9 @@ calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr = case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_bndrs body) of TooBig -> UnfNever SizeIs size cased_bndrs scrut_discount - | uncondInline n_val_bndrs (iBox size) && expr_is_cheap - -> UnfWhen needSaturated boringCxtOk - - | top_bot -- See Note [Do not inline top-level bottoming functions] - -> UnfNever - + | uncondInline n_val_bndrs (iBox size) + , expr_is_cheap + -> UnfWhen unSaturatedOk boringCxtOk -- Note [INLINE for small functions] | otherwise -> UnfIfGoodArgs { ug_args = map (discount cased_bndrs) val_bndrs , ug_size = iBox size @@ -239,24 +282,52 @@ Do not re-inline them! But we *do* still inline if they are very small (the uncondInline stuff). -Note [Unconditional inlining] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We inline *unconditionally* if inlined thing is smaller (using sizeExpr) -than the thing it's replacing. Notice that +Note [INLINE for small functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider {-# INLINE f #-} + f x = Just x + 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. In general, f the function is +sufficiently small that its body is as small as the call itself, the +inline unconditionally, regardless of how boring the context is. + +Things to note: + + * We inline *unconditionally* if inlined thing is smaller (using sizeExpr) + than the thing it's replacing. Notice that (f x) --> (g 3) -- YES, unconditionally (f x) --> x : [] -- YES, *even though* there are two -- arguments to the cons x --> g 3 -- NO x --> Just v -- NO -It's very important not to unconditionally replace a variable by -a non-atomic term. + It's very important not to unconditionally replace a variable by + a non-atomic term. + +* We do this even if the thing isn't saturated, else we end up with the + silly situation that + f x y = x + ...map (f 3)... + doesn't inline. Even in a boring context, inlining without being + saturated will give a lambda instead of a PAP, and will be more + efficient at runtime. + +* However, when the function's arity > 0, we do insist that it + has at least one value argument at the call site. Otherwise we find this: + f = /\a \x:a. x + d = /\b. MkD (f b) + If we inline f here we get + d = /\b. MkD (\x:b. x) + and then prepareRhs floats out the argument, abstracting the type + variables, so we end up with the original again! + \begin{code} uncondInline :: Arity -> Int -> Bool -- Inline unconditionally if there no size increase -- Size of call is arity (+1 for the function) --- See Note [Unconditional inlining] +-- See Note [INLINE for small functions] uncondInline arity size | arity == 0 = size == 0 | otherwise = size <= arity + 1 @@ -278,11 +349,13 @@ sizeExpr bOMB_OUT_SIZE top_args expr size_up (Cast e _) = size_up e size_up (Note _ e) = size_up e size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero size_up (Lit lit) = sizeN (litSize lit) size_up (Var f) = size_up_call f [] -- Make sure we get constructor -- discounts even on nullary constructors size_up (App fun (Type _)) = size_up fun + size_up (App fun (Coercion _)) = size_up fun size_up (App fun arg) = size_up arg `addSizeNSD` size_up_app fun [arg] @@ -338,7 +411,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr ------------ -- size_up_app is used when there's ONE OR MORE value args size_up_app (App fun arg) args - | isTypeArg arg = size_up_app fun args + | isTyCoArg arg = size_up_app fun args | otherwise = size_up arg `addSizeNSD` size_up_app fun (arg:args) size_up_app (Var fun) args = size_up_call fun args @@ -444,21 +517,44 @@ 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)) -- Like variables + | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) -- Like variables + +-- See Note [Constructor size] | 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 - -- many arguments it has; we are keen to expose them - -- (and we charge separately for their args). We can't treat - -- them as size zero, else we find that (Just x) has size 0, - -- which is the same as a lone variable; and hence 'v' will - -- always be replaced by (Just x), where v is bound to Just x. - -- - -- However, unboxed tuples count as size zero - -- I found occasions where we had - -- f x y z = case op# x y z of { s -> (# s, () #) } - -- and f wasn't getting inlined +-- See Note [Unboxed tuple result discount] +-- | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (_ILIT(0)) + +-- See Note [Constructor size] + | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1)) +\end{code} + +Note [Constructor size] +~~~~~~~~~~~~~~~~~~~~~~~ +Treat a constructors application as size 1, regardless of how many +arguments it has; we are keen to expose them (and we charge separately +for their args). We can't treat them as size zero, else we find that +(Just x) has size 0, which is the same as a lone variable; and hence +'v' will always be replaced by (Just x), where v is bound to Just x. + +However, unboxed tuples count as size zero. I found occasions where we had + f x y z = case op# x y z of { s -> (# s, () #) } +and f wasn't getting inlined. + +Note [Unboxed tuple result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I tried giving unboxed tuples a *result discount* of zero (see the +commented-out line). Why? When returned as a result they do not +allocate, so maybe we don't want to charge so much for them If you +have a non-zero discount here, we find that workers often get inlined +back into wrappers, because it look like + f x = case $wf x of (# a,b #) -> (a,b) +and we are keener because of the case. However while this change +shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% +more. All other changes were very small. So it's not a big deal but I +didn't adopt the idea. + +\begin{code} primOpSize :: PrimOp -> Int -> ExprSize primOpSize op n_val_args | not (primOpIsDupable op) = sizeN opt_UF_DearOp @@ -597,9 +693,11 @@ actual arguments. \begin{code} couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool couldBeSmallEnoughToInline threshold rhs - = case calcUnfoldingGuidance False False threshold rhs of - (_, UnfNever) -> False - _ -> True + = case sizeExpr (iUnbox threshold) [] body of + TooBig -> False + _ -> True + where + (_, body) = collectBinders rhs ---------------- smallEnoughToInline :: Unfolding -> Bool @@ -647,13 +745,12 @@ StrictAnal.addStrictnessInfoToTopId \begin{code} callSiteInline :: DynFlags -> Id -- The Id - -> Unfolding -- Its unfolding (if active) + -> Bool -- True <=> unfolding is active -> Bool -- True if there are are no arguments at all (incl type args) -> [ArgSummary] -- One for each value arg; True if it is interesting -> CallCtxt -- True <=> continuation is interesting -> Maybe CoreExpr -- Unfolding, if any - instance Outputable ArgSummary where ppr TrivArg = ptext (sLit "TrivArg") ppr NonTrivArg = ptext (sLit "NonTrivArg") @@ -682,80 +779,92 @@ instance Outputable CallCtxt where ppr CaseCtxt = ptext (sLit "CaseCtxt") ppr ValAppCtxt = ptext (sLit "ValAppCtxt") -callSiteInline dflags id unfolding lone_variable arg_infos cont_info - = case unfolding of { - NoUnfolding -> Nothing ; - OtherCon _ -> Nothing ; - DFunUnfolding {} -> Nothing ; -- Never unfold a DFun - CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top, uf_is_value = is_value, - uf_is_cheap = is_cheap, uf_arity = uf_arity, uf_guidance = guidance } -> +callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info + = case idUnfolding id of + -- idUnfolding checks for loop-breakers, returning NoUnfolding + -- Things with an INLINE pragma may have an unfolding *and* + -- be a loop breaker (maybe the knot is not yet untied) + CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top + , uf_is_cheap = is_cheap, uf_arity = uf_arity + , uf_guidance = guidance, uf_expandable = is_exp } + | active_unfolding -> tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template is_top + is_cheap is_exp uf_arity guidance + | otherwise -> Nothing + NoUnfolding -> Nothing + OtherCon {} -> Nothing + DFunUnfolding {} -> Nothing -- Never unfold a DFun + +tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt + -> CoreExpr -> Bool -> Bool -> Bool -> Arity -> UnfoldingGuidance + -> Maybe CoreExpr +tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template is_top + is_cheap is_exp uf_arity guidance -- uf_arity will typically be equal to (idArity id), -- but may be less for InlineRules - let - n_val_args = length arg_infos - saturated = n_val_args >= uf_arity - - result | yes_or_no = Just unf_template - | otherwise = Nothing - - interesting_args = any nonTriv arg_infos - -- NB: (any nonTriv arg_infos) looks at the - -- over-saturated args too which is "wrong"; - -- but if over-saturated we inline anyway. - - -- some_benefit is used when the RHS is small enough - -- and the call has enough (or too many) value - -- arguments (ie n_val_args >= arity). But there must - -- be *something* interesting about some argument, or the - -- result context, to make it worth inlining - some_benefit - | not saturated = interesting_args -- Under-saturated - -- Note [Unsaturated applications] - | n_val_args > uf_arity = True -- Over-saturated - | otherwise = interesting_args -- Saturated - || interesting_saturated_call - - interesting_saturated_call - = case cont_info of - BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] - CaseCtxt -> not (lone_variable && is_value) -- Note [Lone variables] - ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] - ValAppCtxt -> True -- Note [Cast then apply] - - (yes_or_no, extra_doc) - = case guidance of - UnfNever -> (False, empty) - - UnfWhen unsat_ok boring_ok -> ( (unsat_ok || saturated) - && (boring_ok || some_benefit) - , empty ) - -- For the boring_ok part see Note [INLINE for small functions] - - UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } - -> ( is_cheap && some_benefit && small_enough - , (text "discounted size =" <+> int discounted_size) ) - where - discounted_size = size - discount - small_enough = discounted_size <= opt_UF_UseThreshold - discount = computeDiscount uf_arity arg_discounts - res_discount arg_infos cont_info - - in - if (dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags) then - pprTrace ("Considering inlining: " ++ showSDoc (ppr id)) + | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags + = pprTrace ("Considering inlining: " ++ showSDoc (ppr id)) (vcat [text "arg infos" <+> ppr arg_infos, text "uf arity" <+> ppr uf_arity, text "interesting continuation" <+> ppr cont_info, text "some_benefit" <+> ppr some_benefit, - text "is value:" <+> ppr is_value, + text "is exp:" <+> ppr is_exp, text "is cheap:" <+> ppr is_cheap, text "guidance" <+> ppr guidance, extra_doc, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) - result - else - result - } + result + | otherwise = result + + where + n_val_args = length arg_infos + saturated = n_val_args >= uf_arity + + result | yes_or_no = Just unf_template + | otherwise = Nothing + + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- arguments (ie n_val_args >= arity). But there must + -- be *something* interesting about some argument, or the + -- result context, to make it worth inlining + some_benefit + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | n_val_args > uf_arity = True -- Over-saturated + | otherwise = interesting_args -- Saturated + || interesting_saturated_call + + interesting_saturated_call + = case cont_info of + BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] + CaseCtxt -> not (lone_variable && is_cheap) -- Note [Lone variables] + ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + ValAppCtxt -> True -- Note [Cast then apply] + + (yes_or_no, extra_doc) + = case guidance of + UnfNever -> (False, empty) + + UnfWhen unsat_ok boring_ok + -> (enough_args && (boring_ok || some_benefit), empty ) + where -- See Note [INLINE for small functions] + enough_args = saturated || (unsat_ok && n_val_args > 0) + + UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + -> ( is_cheap && some_benefit && small_enough + , (text "discounted size =" <+> int discounted_size) ) + where + discounted_size = size - discount + small_enough = discounted_size <= opt_UF_UseThreshold + discount = computeDiscount uf_arity arg_discounts + res_discount arg_infos cont_info \end{code} Note [RHS of lets] @@ -789,22 +898,12 @@ But the defn of GHC.Classes.$dmmin is: {- Arity: 3, HasNoCafRefs, Strictness: SLL, Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> case @ a GHC.Classes.<= @ a $dOrd x y of wild { - GHC.Bool.False -> y GHC.Bool.True -> x }) -} + GHC.Types.False -> y GHC.Types.True -> x }) -} We *really* want to inline $dmmin, even though it has arity 3, in order to unravel the recursion. -Note [INLINE for small functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider {-# INLINE f #-} - f x = Just x - 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!) - - Note [Things to watch] ~~~~~~~~~~~~~~~~~~~~~~ * { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } @@ -871,8 +970,8 @@ 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] -~~~~~~~~~~~~~~~~~~~~~ +Note [Lone variables] See also Note [Interaction of exprIsCheap and lone variables] +~~~~~~~~~~~~~~~~~~~~~ which appears below 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 @@ -881,7 +980,7 @@ variable appears all alone as scrutinee of a case CaseCtxt as arg of a fn ArgCtxt AND - it is bound to a value + it is bound to a cheap expression then we should not inline it (unless there is some other reason, e.g. is is the sole occurrence). That is what is happening at @@ -933,6 +1032,27 @@ However, watch out: There's no advantage in inlining f here, and perhaps a significant disadvantage. Hence some_val_args in the Stop case +Note [Interaction of exprIsCheap and lone variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lone-variable test says "don't inline if a case expression +scrutines a lone variable whose unfolding is cheap". It's very +important that, under these circumstances, exprIsConApp_maybe +can spot a constructor application. So, for example, we don't +consider + let x = e in (x,x) +to be cheap, and that's good because exprIsConApp_maybe doesn't +think that expression is a constructor application. + +I used to test is_value rather than is_cheap, which was utterly +wrong, because the above expression responds True to exprIsHNF. + +This kind of thing can occur if you have + + {-# INLINE foo #-} + foo = let x = e in (x,x) + +which Roman did. + \begin{code} computeDiscount :: Int -> [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info @@ -1030,7 +1150,9 @@ interestingArg e = go e 0 conlike_unfolding = isConLikeUnfolding (idUnfolding v) go (Type _) _ = TrivArg - go (App fn (Type _)) n = go fn n + go (Coercion _) _ = TrivArg + go (App fn (Type _)) n = go fn n + go (App fn (Coercion _)) n = go fn n go (App fn _) n = go fn (n+1) go (Note _ a) n = go a n go (Cast e _) n = go e n @@ -1070,13 +1192,14 @@ However e might not *look* as if -- where t1..tk are the *universally-qantified* type args of 'dc' exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe id_unf (Note _ expr) +exprIsConApp_maybe id_unf (Note note expr) + | notSccNote note = exprIsConApp_maybe id_unf expr - -- We ignore all notes. For example, + -- We ignore all notes except SCCs. For example, -- case _scc_ "foo" (C a b) of -- C a b -> e - -- should be optimised away, but it will be only if we look - -- through the SCC note. + -- should not be optimised away, because we'll lose the + -- entry count on 'foo'; see Trac #4414 exprIsConApp_maybe id_unf (Cast expr co) = -- Here we do the KPush reduction rule as described in the FC paper @@ -1090,7 +1213,7 @@ exprIsConApp_maybe id_unf (Cast expr co) Nothing -> Nothing ; Just (dc, _dc_univ_args, dc_args) -> - let (_from_ty, to_ty) = coercionKind co + let Pair _from_ty to_ty = coercionKind co dc_tc = dataConTyCon dc in case splitTyConApp_maybe to_ty of { @@ -1110,41 +1233,28 @@ exprIsConApp_maybe id_unf (Cast expr co) dc_ex_tyvars = dataConExTyVars dc arg_tys = dataConRepArgTys dc - dc_eqs :: [(Type,Type)] -- All equalities from the DataCon - dc_eqs = [(mkTyVarTy tv, ty) | (tv,ty) <- dataConEqSpec dc] ++ - [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc] - - (ex_args, rest1) = splitAtList dc_ex_tyvars dc_args - (co_args, val_args) = splitAtList dc_eqs rest1 + (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co - theta = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars) - (gammas ++ stripTypeArgs ex_args) - - -- Cast the existential coercion arguments - cast_co (ty1, ty2) (Type co) - = Type $ mkSymCoercion (substTy theta ty1) - `mkTransCoercion` co - `mkTransCoercion` (substTy theta ty2) - cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg) - new_co_args = zipWith cast_co dc_eqs co_args - + theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars) + (gammas ++ map mkReflCo (stripTypeArgs ex_args)) + -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg + cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg in #ifdef DEBUG 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] in - ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) - ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc ) + ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) + ASSERT2( all isTypeArg ex_args, dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) #endif - Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args) + Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) }} exprIsConApp_maybe id_unf expr @@ -1155,17 +1265,21 @@ exprIsConApp_maybe id_unf expr analyse (Var fun) args | Just con <- isDataConWorkId_maybe fun - , is_saturated + , count isValArg args == idArity fun , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args = Just (con, stripTypeArgs univ_ty_args, rest_args) -- Look through dictionary functions; see Note [Unfolding DFuns] - | DFunUnfolding con ops <- unfolding - , is_saturated - , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) - subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) - = Just (con, substTys subst dfun_res_tys, - [mkApps op args | op <- ops]) + | DFunUnfolding dfun_nargs con ops <- unfolding + , let sat = length args == dfun_nargs -- See Note [DFun arity check] + in if sat then True else + pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False + , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) + subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) + mk_arg (DFunConstArg e) = e + mk_arg (DFunLamArg i) = args !! i + mk_arg (DFunPolyArg e) = mkApps e args + = Just (con, substTys subst dfun_res_tys, map mk_arg ops) -- Look through unfoldings, but only cheap ones, because -- we are effectively duplicating the unfolding @@ -1173,33 +1287,28 @@ exprIsConApp_maybe id_unf expr = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $ analyse rhs args where - is_saturated = count isValArg args == idArity fun unfolding = id_unf fun analyse _ _ = Nothing ----------- beta (Lam v body) pairs (arg : args) - | isTypeArg arg + | isTyCoArg arg = beta body ((v,arg):pairs) args beta (Lam {}) _ _ -- Un-saturated, or not a type lambda = Nothing beta fun pairs args - = 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 + = analyse (substExpr (text "subst-expr-is-con-app") subst fun) args where subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args] - stripTypeArgs :: [CoreExpr] -> [Type] stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) [ty | Type ty <- args] + -- We really do want isTypeArg here, not isTyCoArg! \end{code} Note [Unfolding DFuns] @@ -1214,3 +1323,8 @@ So to split it up we just need to apply the ops $c1, $c2 etc to the very same args as the dfun. It takes a little more work to compute the type arguments to the dictionary constructor. +Note [DFun arity check] +~~~~~~~~~~~~~~~~~~~~~~~ +Here we check that the total number of supplied arguments (inclding +type args) matches what the dfun is expecting. This may be *less* +than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn