X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=d73856585674f815de8cfa3bb0f58558043cf187;hb=5c61fd637c1f3f47cddb523b33be95baa29716eb;hp=590e689f4a7ee1983a37c4e261c9560d6c2a731b;hpb=c43c981705ec33da92a9ce91eb90f2ecf00be9fe;p=ghc-hetmet.git diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 590e689..d738565 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 @@ -800,17 +800,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 - (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 - -- 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 + (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs + + (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 +825,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] @@ -898,10 +906,14 @@ specDefn subst body_uds fn rhs -- 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)) } } + -- See Note [Inline specialisations] + final_spec_f | Just sat <- fn_has_inline_rule + = spec_f_w_arity `setInlineActivation` inline_act + `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity + -- I'm not sure this should be unconditionally InlSat + | 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) @@ -1157,11 +1169,6 @@ 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} %************************************************************************ %* *