X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=5c29ffbae448a7c88603bf7ac1ce7ec795ca67a4;hb=90686adf9d3dc7a09a51853df051bc4ea472d840;hp=c51b27de3f1688605f66f78bd31818e37640471a;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index c51b27d..5c29ffb 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -29,7 +29,7 @@ import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, isJust ) -import BasicTypes ( Arity ) +import BasicTypes ( isNeverActive, inlinePragmaActivation ) import Bag import Util import Outputable @@ -588,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: @@ -774,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 @@ -801,23 +804,20 @@ specDefn subst body_uds fn rhs where fn_type = idType fn fn_arity = idArity fn - fn_unf = idUnfolding 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) -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] - fn_has_inline_rule :: Maybe (InlineRuleInfo, Arity) -- Gives arity of the *specialised* inline rule - fn_has_inline_rule - | Just inl <- isInlineRule_maybe fn_unf - = case inl of - InlWrapper _ -> Just (InlUnSat, spec_arity) - _ -> Just (inl, spec_arity) - | otherwise = Nothing - where - spec_arity = unfoldingArity fn_unf - n_dicts + 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 @@ -829,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] @@ -889,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: @@ -900,22 +897,33 @@ 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 + -- 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 (inl, spec_arity) <- fn_has_inline_rule - = spec_f_w_arity `setInlineActivation` inline_act - `setIdUnfolding` mkInlineRule inl spec_rhs spec_arity - -- I'm not sure this should be unconditionally InlSat - | otherwise - = spec_f_w_arity + 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 @@ -942,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* @@ -1115,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1144,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, @@ -1169,9 +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. - %************************************************************************ %* *