X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=39a9f054c56f6678a621917f08d9f2a1432b029e;hp=090f0f0b807d9bda8203e9591179ba18f05443d0;hb=960a5edb6ac87c7d85e36f4b70be8da0175819f7;hpb=6c51a993efa623be3f92ae997c3cb321e4b0badb diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 090f0f0..39a9f05 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -11,15 +11,26 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. module Rules ( - RuleBase, emptyRuleBase, mkRuleBase, extendRuleBaseList, - unionRuleBase, pprRuleBase, ruleCheckProgram, + -- * RuleBase + RuleBase, + + -- ** Constructing + emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + -- ** Manipulating 'SpecInfo' rules mkSpecInfo, extendSpecInfo, addSpecInfo, - rulesOfBinds, addIdSpecialisations, + addIdSpecialisations, - matchN, - + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + lookupRule, mkLocalRule, roughTopNames ) where @@ -28,7 +39,6 @@ module Rules ( import CoreSyn -- All of it import OccurAnal ( occurAnalyseExpr ) import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) -import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( tcEqExprX, exprType ) import PprCore ( pprRules ) import Type ( Type, TvSubstEnv ) @@ -43,7 +53,7 @@ import VarSet import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) -import BasicTypes ( Activation, CompilerPhase, isActive ) +import BasicTypes ( Activation ) import StaticFlags ( opt_PprStyle_Debug ) import Outputable import FastString @@ -92,7 +102,8 @@ where pi' :: Lift Int# is the specialised version of pi. \begin{code} mkLocalRule :: RuleName -> Activation -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule --- Used to make CoreRule for an Id defined in this module +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'CoreSyn.CoreRule' mkLocalRule name act fn bndrs args rhs = Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, ru_args = args, @@ -101,14 +112,19 @@ mkLocalRule name act fn bndrs args rhs -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't roughTopNames args = map roughTopName args roughTopName :: CoreExpr -> Maybe Name --- Find the "top" free name of an expression --- a) the function in an App chain (if a GlobalId) --- b) the TyCon in a type --- This is used for the fast-match-check for rules; --- if the top names don't match, the rest can't roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of Just (tc,_) -> Just (getName tc) Nothing -> Nothing @@ -118,21 +134,39 @@ roughTopName (Var f) | isGlobalId f = Just (idName f) roughTopName other = Nothing ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool --- (ruleCantMatch tpl actual) returns True only if 'actual' --- definitely can't match 'tpl' by instantiating 'tpl'. +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. -- It's only a one-way match; unlike instance matching we --- don't consider unification +-- don't consider unification. -- --- Notice that there is no case --- ruleCantMatch (Just n1 : ts) (Nothing : as) = True --- Reason: a local variable 'v' in the actuals might --- have an unfolding which is a global. --- This quite often happens with case scrutinees. +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as ruleCantMatch (t : ts) (a : as) = ruleCantMatch ts as ruleCantMatch ts as = False \end{code} +\begin{code} +pprRulesForUser :: [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in PprCore because it calls tidyRules +pprRulesForUser rules + = withPprStyle defaultUserStyle $ + pprRules $ + sortLe le_rule $ + tidyRules emptyTidyEnv rules + where + le_rule r1 r2 = ru_name r1 <= ru_name r2 +\end{code} + %************************************************************************ %* * @@ -141,6 +175,8 @@ ruleCantMatch ts as = False %************************************************************************ \begin{code} +-- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable +-- for putting into an 'IdInfo' mkSpecInfo :: [CoreRule] -> SpecInfo mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules) @@ -157,8 +193,21 @@ addIdSpecialisations id rules = setIdSpecialisation id $ extendSpecInfo (idSpecialisation id) rules +-- | Gather all the rules for locally bound identifiers from the supplied bindings rulesOfBinds :: [CoreBind] -> [CoreRule] rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +getRules :: RuleBase -> Id -> [CoreRule] + -- The rules for an Id come from two places: + -- (a) the ones it is born with (idCoreRules fn) + -- (b) rules added in subsequent modules (extra_rules) + -- PrimOps, for example, are born with a bunch of rules under (a) +getRules rule_base fn + | isLocalId fn = idCoreRules fn + | otherwise = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), + ppr fn <+> ppr (idCoreRules fn) ) + idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` []) + -- Only PrimOpIds have rules inside themselves, and perhaps more besides \end{code} @@ -169,8 +218,8 @@ rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds %************************************************************************ \begin{code} +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules type RuleBase = NameEnv [CoreRule] - -- Maps (the name of) an Id to its rules -- The rules are are unordered; -- we sort out any overlaps on lookup @@ -219,30 +268,17 @@ in the Simplifier works better as it is. Reason: the 'args' passed to lookupRule are the result of a lazy substitution \begin{code} +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. lookupRule :: (Activation -> Bool) -> InScopeSet - -> RuleBase -- Imported rules - -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr) --- See Note [Extra argsin rule matching] -lookupRule is_active in_scope rule_base fn args - = matchRules is_active in_scope fn args (getRules rule_base fn) - -getRules :: RuleBase -> Id -> [CoreRule] - -- The rules for an Id come from two places: - -- (a) the ones it is born with (idCoreRules fn) - -- (b) rules added in subsequent modules (extra_rules) - -- PrimOps, for example, are born with a bunch of rules under (a) -getRules rule_base fn - | isLocalId fn = idCoreRules fn - | otherwise = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), - ppr fn <+> ppr (idCoreRules fn) ) - idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` []) - -- Only PrimOpIds have rules inside themselves, and perhaps more besides + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -matchRules :: (Activation -> Bool) -> InScopeSet - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) +-- See Note [Extra args in rule matching] -- See comments on matchRule -matchRules is_active in_scope fn args rules +lookupRule is_active in_scope fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $ case go [] rules of [] -> Nothing @@ -255,7 +291,7 @@ matchRules is_active in_scope fn args rules go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of Just e -> go ((r,e):ms) rs Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ - -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] ) + -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] ) go ms rs findBest :: (Id, [CoreExpr]) @@ -268,20 +304,17 @@ findBest target (rule,ans) [] = (rule,ans) findBest target (rule1,ans1) ((rule2,ans2):prs) | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs -#ifdef DEBUG - | otherwise = let pp_rule rule + | debugIsOn = let pp_rule rule | opt_PprStyle_Debug = ppr rule | otherwise = doubleQuotes (ftext (ru_name rule)) in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" (vcat [if opt_PprStyle_Debug then - ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args) + ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args) else empty, - ptext SLIT("Rule 1:") <+> pp_rule rule1, - ptext SLIT("Rule 2:") <+> pp_rule rule2]) $ + ptext (sLit "Rule 1:") <+> pp_rule rule1, + ptext (sLit "Rule 2:") <+> pp_rule rule2]) $ findBest target (rule1,ans1) prs -#else | otherwise = findBest target (rule1,ans1) prs -#endif where (fn,args) = target @@ -348,12 +381,15 @@ matchRule is_active in_scope args rough_args \end{code} \begin{code} -matchN :: InScopeSet - -> [Var] -- Template tyvars - -> [CoreExpr] -- Template - -> [CoreExpr] -- Target; can have more elts than template - -> Maybe ([CoreBind], -- Bindings to wrap around the entire result - [CoreExpr]) -- What is substituted for each template var +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- Fail if there are two few actual arguments from the target to match the template +matchN :: InScopeSet -- ^ In-scope variables + -> [Var] -- ^ Match template type variables + -> [CoreExpr] -- ^ Match template + -> [CoreExpr] -- ^ Target; can have more elements than the template + -> Maybe ([CoreBind], + [CoreExpr]) matchN in_scope tmpl_vars tmpl_es target_es = do { (tv_subst, id_subst, binds) @@ -732,19 +768,19 @@ SpecConstr sees this fragment: Data.Maybe.Nothing -> lvl_smf; Data.Maybe.Just n_acT [Just S(L)] -> case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> - $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf }}; and correctly generates the rule RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# sc_snn :: GHC.Prim.Int#} - $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) - = $s$wfoo_sno y_amr sc_snn ;] + \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = \$s\$wfoo_sno y_amr sc_snn ;] BUT we must ensure that this rule matches in the original function! -Note that the call to $wfoo is - $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf +Note that the call to \$wfoo is + \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf During matching we expand wild_Xf to (Just n_acT). But then we must also expand n_acT to (I# y_amr). And we can only do that if we look up n_acT @@ -769,10 +805,14 @@ We want to know what sites have rules that could have fired but didn't. This pass runs over the tree (without changing it) and reports such. \begin{code} -ruleCheckProgram :: CompilerPhase -> String -> RuleBase -> [CoreBind] -> SDoc --- Report partial matches for rules beginning --- with the specified string -ruleCheckProgram phase rule_pat rule_base binds +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: (Activation -> Bool) -- ^ Rule activation test + -> String -- ^ Rule pattern + -> RuleBase -- ^ Database of rules + -> [CoreBind] -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram is_active rule_pat rule_base binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -781,10 +821,14 @@ ruleCheckProgram phase rule_pat rule_base binds vcat [ p $$ line | p <- bagToList results ] ] where - results = unionManyBags (map (ruleCheckBind (phase, rule_pat, rule_base)) binds) + results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds) line = text (replicate 20 '-') -type RuleCheckEnv = (CompilerPhase, String, RuleBase) -- Phase and Pattern +data RuleCheckEnv = RuleCheckEnv { + rc_is_active :: Activation -> Bool, + rc_pattern :: String, + rc_rule_base :: RuleBase +} ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc -- The Bag returned has one SDoc for each call site found @@ -813,15 +857,15 @@ ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc -- Produce a report for all rules matching the predicate -- saying why it doesn't match the specified application -ruleCheckFun (phase, pat, rule_base) fn args +ruleCheckFun env fn args | null name_match_rules = emptyBag - | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules) + | otherwise = unitBag (ruleAppCheck_help (rc_is_active env) fn args name_match_rules) where - name_match_rules = filter match (getRules rule_base fn) - match rule = pat `isPrefixOf` unpackFS (ruleName rule) + name_match_rules = filter match (getRules (rc_rule_base env) fn) + match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) -ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc -ruleAppCheck_help phase fn args rules +ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help is_active fn args rules = -- The rules match the pattern, so we want to print something vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] @@ -833,9 +877,9 @@ ruleAppCheck_help phase fn args rules check_rule rule = rule_herald rule <> colon <+> rule_info rule rule_herald (BuiltinRule { ru_name = name }) - = ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name) + = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name) rule_herald (Rule { ru_name = name }) - = ptext SLIT("Rule") <+> doubleQuotes (ftext name) + = ptext (sLit "Rule") <+> doubleQuotes (ftext name) rule_info rule | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule @@ -845,7 +889,7 @@ ruleAppCheck_help phase fn args rules rule_info (Rule { ru_name = name, ru_act = act, ru_bndrs = rule_bndrs, ru_args = rule_args}) - | not (isActive phase act) = text "active only in later phase" + | not (is_active act) = text "active only in later phase" | n_args < n_rule_args = text "too few arguments" | n_mismatches == n_rule_args = text "no arguments match" | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"