X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=64d0cdd7a32b22f0db065def2264d273ffed1692;hb=527f52a72acf214994921ad36de92f934e9632da;hp=4a1cc4c37bc2129165f96134fb3c6b8ca9f5a9ad;hpb=d95ce839533391e7118257537044f01cbb1d6694;p=ghc-hetmet.git diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 4a1cc4c..64d0cdd 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -14,9 +14,9 @@ module Specialise ( specProgram ) where #include "HsVersions.h" -import Id ( Id, idName, idType, mkUserLocal, idCoreRules, - idInlinePragma, setInlinePragma, setIdUnfolding, - isLocalId, idUnfolding ) +import Id ( Id, idName, idType, mkUserLocal, idCoreRules, idUnfolding, + idInlineActivation, setInlineActivation, setIdUnfolding, + isLocalId, isDataConWorkId, idArity, setIdArity ) import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, isClassPred, tcCmpType, isUnLiftedType @@ -26,8 +26,7 @@ import CoreSubst ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, extendIdSubst ) -import CoreUnfold ( mkUnfolding, mkInlineRule ) -import SimplUtils ( interestingArg ) +import CoreUnfold ( mkUnfolding ) import Var ( DictId ) import VarSet import VarEnv @@ -43,7 +42,6 @@ import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, isJust ) -import BasicTypes ( Arity ) import Bag import Util import Outputable @@ -827,19 +825,16 @@ specDefn subst calls fn rhs where fn_type = idType fn + fn_arity = idArity fn (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta - inline_prag = idInlinePragma fn + inline_act = idInlineActivation fn - -- Figure out whether the function has an INLINE pragma - -- See Note [Inline specialisations] - fn_has_inline_rule :: Maybe Arity -- Gives arity of the *specialised* inline rule - fn_has_inline_rule = case idUnfolding fn of - InlineRule { uf_arity = arity } -> Just (arity - n_dicts) - _other -> Nothing - - (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 rhs_dict_ids = take n_dicts rhs_ids body = mkLams (drop n_dicts rhs_ids) rhs_body @@ -911,6 +906,10 @@ specDefn subst calls 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: @@ -918,22 +917,19 @@ specDefn subst calls fn rhs rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args)) spec_env_rule = mkLocalRule rule_name - inline_prag -- Note [Auto-specialisation and RULES] + inline_act -- Note [Auto-specialisation and RULES] (idName fn) (poly_tyvars ++ inst_dict_ids) inst_args - (mkVarApps (Var spec_f) app_args) + (mkVarApps (Var spec_f_w_arity) app_args) -- Add the { d1' = dx1; d2' = dx2 } usage stuff final_uds = foldr addDictBind rhs_uds dx_binds - -- See Note [Inline specialisations] - final_spec_f | Just spec_arity <- fn_has_inline_rule - = spec_f `setInlinePragma` inline_prag - `setIdUnfolding` mkInlineRule spec_rhs spec_arity - | otherwise - = spec_f - ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } } + 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)) } } where my_zipEqual xs ys zs | debugIsOn && not (equalLength xs ys && equalLength ys zs) @@ -1076,7 +1072,8 @@ 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. +InlineMe on the RHS. We do not, however, transfer the RuleMatchInfo +since we do not expect the specialisation to occur in rewrite rules. This is a change (Jun06). Previously the idea is that the point of inlining was precisely to specialise the function at its call site, @@ -1098,6 +1095,11 @@ 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} %************************************************************************ %* * @@ -1197,13 +1199,13 @@ mkCallUDs f args -- *don't* say what the value of the implicit param is! || not (spec_tys `lengthIs` n_tyvars) || not ( dicts `lengthIs` n_dicts) - || not (any interestingArg dicts) -- Note [Interesting dictionary arguments] + || not (any interestingDict dicts) -- Note [Interesting dictionary arguments] -- See also Note [Specialisations already covered] - = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)]) + = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)]) emptyUDs -- Not overloaded, or no specialisation wanted | otherwise - = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)]) + = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)]) singleCall f spec_tys dicts where (tyvars, theta, _) = tcSplitSigmaTy (idType f) @@ -1227,9 +1229,19 @@ There really is not much point in specialising f wrt the dictionary d, because the code for the specialised f is not improved at all, because d is lambda-bound. We simply get junk specialisations. -We re-use the function SimplUtils.interestingArg function to determine -what sort of dictionary arguments have *some* information in them. +What is "interesting"? Just that it has *some* structure. +\begin{code} +interestingDict :: CoreExpr -> Bool +-- A dictionary argument is interesting if it has *some* structure +interestingDict (Var v) = hasSomeUnfolding (idUnfolding v) + || isDataConWorkId v +interestingDict (Type _) = False +interestingDict (App fn (Type _)) = interestingDict fn +interestingDict (Note _ a) = interestingDict a +interestingDict (Cast e _) = interestingDict e +interestingDict _ = True +\end{code} \begin{code} plusUDs :: UsageDetails -> UsageDetails -> UsageDetails