X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=090f0f0b807d9bda8203e9591179ba18f05443d0;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=92d3fbc22313c23f5fc65a30fbdc185b91b0989b;hpb=206b752961b48dcf8943632572b0a4f9c8a0fccc;p=ghc-hetmet.git diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 92d3fbc..090f0f0 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -4,6 +4,13 @@ \section[CoreRules]{Transformation rules} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Rules ( RuleBase, emptyRuleBase, mkRuleBase, extendRuleBaseList, unionRuleBase, pprRuleBase, ruleCheckProgram, @@ -20,7 +27,7 @@ module Rules ( import CoreSyn -- All of it import OccurAnal ( occurAnalyseExpr ) -import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesRhsFreeVars ) +import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( tcEqExprX, exprType ) import PprCore ( pprRules ) @@ -28,8 +35,7 @@ import Type ( Type, TvSubstEnv ) import Coercion ( coercionKind ) import TcType ( tcSplitTyConApp_maybe ) import CoreTidy ( tidyRules ) -import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName, idType, - idSpecialisation, idCoreRules, setIdSpecialisation ) +import Id import IdInfo ( SpecInfo( SpecInfo ) ) import Var ( Var ) import VarEnv @@ -38,13 +44,14 @@ import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) import BasicTypes ( Activation, CompilerPhase, isActive ) +import StaticFlags ( opt_PprStyle_Debug ) import Outputable import FastString import Maybes import OrdList import Bag import Util -import List hiding( mapAccumL ) -- Also defined in Util +import Data.List \end{code} @@ -135,11 +142,11 @@ ruleCantMatch ts as = False \begin{code} mkSpecInfo :: [CoreRule] -> SpecInfo -mkSpecInfo rules = SpecInfo rules (rulesRhsFreeVars rules) +mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules) extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo extendSpecInfo (SpecInfo rs1 fvs1) rs2 - = SpecInfo (rs2 ++ rs1) (rulesRhsFreeVars rs2 `unionVarSet` fvs1) + = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1) addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) @@ -195,20 +202,41 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) %* * %************************************************************************ +Note [Extra args in rule matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +but the rule firing has only consumed as many of the input args +as the ruleArity says. It's up to the caller to keep track +of any left-over args. E.g. if you call + lookupRule ... f [e1, e2, e3] +and it returns Just (r, rhs), where r has ruleArity 2 +then the real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution + \begin{code} 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 rules - where + = 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) - rules = extra_rules ++ idCoreRules fn - extra_rules | isLocalId fn = [] - | otherwise = lookupNameEnv rule_base (idName fn) `orElse` [] +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 matchRules :: (Activation -> Bool) -> InScopeSet -> Id -> [CoreExpr] @@ -241,10 +269,15 @@ 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 = pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args), - ptext SLIT("Rule 1:") <+> ppr rule1, - ptext SLIT("Rule 2:") <+> ppr rule2]) $ + | otherwise = 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) + else empty, + 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 @@ -565,11 +598,8 @@ match menv subst (Type ty1) (Type ty2) = match_ty menv subst ty1 ty2 match menv subst (Cast e1 co1) (Cast e2 co2) - | (from1, to1) <- coercionKind co1 - , (from2, to2) <- coercionKind co2 - = do { subst1 <- match_ty menv subst to1 to2 - ; subst2 <- match_ty menv subst1 from1 from2 - ; match menv subst2 e1 e2 } + = do { subst1 <- match_ty menv subst co1 co2 + ; match menv subst1 e1 e2 } {- REMOVING OLD CODE: I think that the above handling for let is better than the stuff here, which looks @@ -616,6 +646,8 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2 | otherwise -- No renaming to do on e2, because no free var -- of e2 is in the rnEnvR of the envt + -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- However, we must match the *types*; e.g. -- forall (c::Char->Int) (x::Char). -- f (c x) = "RULE FIRED" @@ -736,16 +768,11 @@ is so important. 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. -NB: we assume that this follows a run of the simplifier, so every Id -occurrence (including occurrences of imported Ids) is decorated with -all its (active) rules. No need to construct a rule base or anything -like that. - \begin{code} -ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc +ruleCheckProgram :: CompilerPhase -> String -> RuleBase -> [CoreBind] -> SDoc -- Report partial matches for rules beginning -- with the specified string -ruleCheckProgram phase rule_pat binds +ruleCheckProgram phase rule_pat rule_base binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -754,10 +781,10 @@ ruleCheckProgram phase rule_pat binds vcat [ p $$ line | p <- bagToList results ] ] where - results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds) + results = unionManyBags (map (ruleCheckBind (phase, rule_pat, rule_base)) binds) line = text (replicate 20 '-') -type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern +type RuleCheckEnv = (CompilerPhase, String, RuleBase) -- Phase and Pattern ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc -- The Bag returned has one SDoc for each call site found @@ -786,11 +813,11 @@ 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) fn args +ruleCheckFun (phase, pat, rule_base) fn args | null name_match_rules = emptyBag | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules) where - name_match_rules = filter match (idCoreRules fn) + name_match_rules = filter match (getRules rule_base fn) match rule = pat `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc