X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=5c29ffbae448a7c88603bf7ac1ce7ec795ca67a4;hb=13c66820c802b295ed153a5ce9ca1492a8c8ac51;hp=590e689f4a7ee1983a37c4e261c9560d6c2a731b;hpb=c43c981705ec33da92a9ce91eb90f2ecf00be9fe;p=ghc-hetmet.git diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 590e689..5c29ffb 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -17,7 +17,7 @@ module Specialise ( specProgram ) where import Id import TcType import CoreSubst -import CoreUnfold ( mkUnfolding ) +import CoreUnfold ( mkUnfolding, mkInlineRule ) import VarSet import VarEnv import CoreSyn @@ -29,6 +29,7 @@ import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, isJust ) +import BasicTypes ( isNeverActive, inlinePragmaActivation ) import Bag import Util import Outputable @@ -587,7 +588,7 @@ specProgram us binds = initSM us $ \begin{code} specVar :: Subst -> Id -> CoreExpr -specVar subst v = lookupIdSubst subst v +specVar subst v = lookupIdSubst (text "specVar") subst v specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) -- We carry a substitution down: @@ -773,6 +774,9 @@ specDefn subst body_uds fn rhs | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args && notNull calls_for_me -- And there are some calls to specialise + && not (isNeverActive (idInlineActivation fn)) + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] -- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small -- See Note [Inline specialisation] for why we do not @@ -800,17 +804,24 @@ specDefn subst body_uds fn rhs where fn_type = idType fn fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta - inline_act = idInlineActivation fn + inl_act = inlinePragmaActivation (idInlinePragma fn) - (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] + fn_has_inline_rule :: Maybe Bool -- Derive sat-flag from existing thing + fn_has_inline_rule = case isInlineRule_maybe fn_unf of + Just (_,sat) -> Just sat + Nothing -> Nothing + + spec_arity = unfoldingArity fn_unf - n_dicts -- Arity of the *specialised* inline rule + + (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs - -- It's important that we "see past" any INLINE pragma - -- else we'll fail to specialise an INLINE thing - (inline_rhs, rhs_inside) = dropInline rhs - (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside + (body_uds_without_me, calls_for_me) = callsForMe fn body_uds rhs_dict_ids = take n_dicts rhs_ids body = mkLams (drop n_dicts rhs_ids) rhs_body @@ -818,7 +829,8 @@ specDefn subst body_uds fn rhs already_covered :: [CoreExpr] -> Bool already_covered args -- Note [Specialisations already covered] - = isJust (lookupRule (const True) (substInScope subst) + = isJust (lookupRule (const True) realIdUnfolding + (substInScope subst) fn args (idCoreRules fn)) mk_ty_args :: [Maybe Type] -> [CoreExpr] @@ -878,10 +890,6 @@ specDefn subst body_uds fn rhs spec_id_ty = mkPiTypes lam_args body_ty ; spec_f <- newSpecIdSM fn spec_id_ty - ; let spec_f_w_arity = setIdArity spec_f (max 0 (fn_arity - n_dicts)) - -- Adding arity information just propagates it a bit faster - -- See Note [Arity decrease] in Simplify - ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body) ; let -- The rule to put in the function's specialisation is: @@ -889,19 +897,34 @@ specDefn subst body_uds fn rhs rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args)) spec_env_rule = mkLocalRule rule_name - inline_act -- Note [Auto-specialisation and RULES] + inl_act -- Note [Auto-specialisation and RULES] (idName fn) (poly_tyvars ++ inst_dict_ids) inst_args - (mkVarApps (Var spec_f_w_arity) app_args) + (mkVarApps (Var spec_f) app_args) -- Add the { d1' = dx1; d2' = dx2 } usage stuff final_uds = foldr consDictBind rhs_uds dx_binds - spec_pr | inline_rhs = (spec_f_w_arity `setInlineActivation` inline_act, Note InlineMe spec_rhs) - | otherwise = (spec_f_w_arity, spec_rhs) - - ; return (Just (spec_pr, final_uds, spec_env_rule)) } } + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in Simplify + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_f + spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) + `setInlineActivation` inl_act + + -- Add an InlineRule if the parent has one + -- See Note [Inline specialisations] + final_spec_f + | Just sat <- fn_has_inline_rule + = let + mb_spec_arity = if sat then Just spec_arity else Nothing + in + spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity + | otherwise + = spec_f_w_arity + + ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } } where my_zipEqual xs ys zs | debugIsOn && not (equalLength xs ys && equalLength ys zs) @@ -927,7 +950,7 @@ bindAuxiliaryDicts subst triples = go subst [] triples -- No auxiliary binding necessary | otherwise = go subst_w_unf (NonRec dx_id dx : binds) pairs where - dx_id1 = dx_id `setIdUnfolding` mkUnfolding False dx + dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx subst_w_unf = extendIdSubst subst d (Var dx_id1) -- Important! We're going to substitute dx_id1 for d -- and we want it to look "interesting", else we won't gather *any* @@ -1100,10 +1123,14 @@ also add RULE f g_spec = 0 But that's a bit complicated. For now we ask the programmer's help, -by *copying the INLINE activation pragma* to the auto-specialised rule. -So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule will also -not be active until phase 2. +by *copying the INLINE activation pragma* to the auto-specialised +rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule +will also not be active until phase 2. And that's what programmers +should jolly well do anyway, even aside from specialisation, to ensure +that g doesn't inline too early. +This in turn means that the RULE would never fire for a NOINLINE +thing so not much point in generating a specialisation at all. Note [Specialisation shape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1129,13 +1156,12 @@ It's a silly exapmle, but we get where choose doesn't have any dict arguments. Thus far I have not tried to fix this (wait till there's a real example). - Note [Inline specialisations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We transfer to the specialised function any INLINE stuff from the -original. This means (a) the Activation in the IdInfo, and (b) any -InlineMe on the RHS. We do not, however, transfer the RuleMatchInfo -since we do not expect the specialisation to occur in rewrite rules. +original. This means + (a) the Activation for its inlining (from its InlinePragma) + (b) any InlineRule This is a change (Jun06). Previously the idea is that the point of inlining was precisely to specialise the function at its call site, @@ -1154,14 +1180,6 @@ arguments alone are enough to specialise (even though the args are too boring to trigger inlining), and it's certainly better to call the specialised version. -A case in point is dictionary functions, which are current marked -INLINE, but which are worth specialising. - -\begin{code} -dropInline :: CoreExpr -> (Bool, CoreExpr) -dropInline (Note InlineMe rhs) = (True, rhs) -dropInline rhs = (False, rhs) -\end{code} %************************************************************************ %* *