RuleBase, emptyRuleBase,
extendRuleBase, extendRuleBaseList, addRuleBaseFVs,
ruleBaseIds, ruleBaseFVs,
- pprRuleBase,
+ pprRuleBase, ruleCheckProgram,
lookupRule, addRule, addIdSpecialisations
) where
import OccurAnal ( occurAnalyseRule )
import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
+import CoreTidy ( tidyIdRules )
import CoreUtils ( eqExpr )
-import PprCore ( pprCoreRule )
+import PprCore ( pprIdRules )
import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
- substEnv, setSubstEnv, emptySubst, isInScope,
+ substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
bindSubstList, unBindSubstList, substInScope, uniqAway
)
import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
import VarEnv
import TcType ( mkTyVarTy )
import qualified TcType ( match )
-import TypeRep ( Type(..) ) -- Can see type representation for matching
+import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
import Maybe ( isJust, isNothing, fromMaybe )
import Util ( sortLt )
+import Bag
+import List ( isPrefixOf )
\end{code}
%************************************************************************
\begin{code}
-matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
+matchRules :: (Activation -> Bool) -> InScopeSet
+ -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
-- See comments on matchRule
-matchRules in_scope [] args = Nothing
-matchRules in_scope (rule:rules) args
- = case matchRule in_scope rule args of
+matchRules is_active in_scope [] args = Nothing
+matchRules is_active in_scope (rule:rules) args
+ = case matchRule is_active in_scope rule args of
Just result -> Just result
- Nothing -> matchRules in_scope rules args
+ Nothing -> matchRules is_active in_scope rules args
+noBlackList :: Activation -> Bool
+noBlackList act = False -- Nothing is black listed
-matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
+matchRule :: (Activation -> Bool) -> InScopeSet
+ -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
-- If (matchRule rule args) returns Just (name,rhs)
-- then (f args) matches the rule, and the corresponding
-- (\x->E) matches (\x->F x)
-matchRule in_scope rule@(BuiltinRule match_fn) args = match_fn args
+matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
+ = case match_fn args of
+ Just expr -> Just (name,expr)
+ Nothing -> Nothing
-matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
+matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
+ | not (is_active act)
+ = Nothing
+ | otherwise
= go tpl_args args emptySubst
-- We used to use the in_scope set, but I don't think that's necessary
-- After all, the result is going to be simplified again with that in_scope set
%************************************************************************
\begin{code}
-addRule :: CoreRules -> Id -> CoreRule -> CoreRules
+addRule :: Id -> CoreRules -> CoreRule -> CoreRules
+
+-- Add a new rule to an existing bunch of rules.
+-- The rules are for the given Id; the Id argument is needed only
+-- so that we can exclude the Id from its own RHS free-var set
-- Insert the new rule just before a rule that is *less specific*
-- than the new one; or at the end if there isn't such a one.
-- We make no check for rules that unify without one dominating
-- the other. Arguably this would be a bug.
-addRule (Rules rules rhs_fvs) id rule@(BuiltinRule _)
+addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
= Rules (rule:rules) rhs_fvs
-- Put it at the start for lack of anything better
-addRule (Rules rules rhs_fvs) id rule
+addRule id (Rules rules rhs_fvs) rule
= Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
where
new_rule = occurAnalyseRule rule
-- that shoudn't be. E.g.
-- RULE: f (f x y) z ==> f x (f y z)
-insertRule rules new_rule@(Rule _ tpl_vars tpl_args _)
+insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
= go rules
where
tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
| otherwise = rule : go rules
- new_is_more_specific rule = isJust (matchRule tpl_var_set rule tpl_args)
+ new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
addIdSpecialisations :: Id -> [CoreRule] -> Id
addIdSpecialisations id rules
= setIdSpecialisation id new_specs
where
- new_specs = foldr add (idSpecialisation id) rules
- add rule rules = addRule rules id rule
+ new_specs = foldl (addRule id) (idSpecialisation id) rules
\end{code}
%************************************************************************
%* *
-\subsection{Preparing the rule base
+\subsection{Looking up a rule}
%* *
%************************************************************************
\begin{code}
-lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
-lookupRule in_scope fn args
+lookupRule :: (Activation -> Bool) -> InScopeSet
+ -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
+lookupRule is_active in_scope fn args
= case idSpecialisation fn of
- Rules rules _ -> matchRules in_scope rules args
+ Rules rules _ -> matchRules is_active in_scope rules args
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Checking a program for failing rule applications}
+%* *
+%************************************************************************
+
+-----------------------------------------------------
+ Game plan
+-----------------------------------------------------
+
+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
+-- Report partial matches for rules beginning
+-- with the specified string
+ruleCheckProgram phase rule_pat binds
+ | isEmptyBag results
+ = text "Rule check results: no rule application sites"
+ | otherwise
+ = vcat [text "Rule check results:",
+ line,
+ vcat [ p $$ line | p <- bagToList results ]
+ ]
+ where
+ results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
+ line = text (replicate 20 '-')
+
+type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
+
+ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
+ -- The Bag returned has one SDoc for each call site found
+ruleCheckBind env (NonRec b r) = ruleCheck env r
+ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs]
+
+ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
+ruleCheck env (Var v) = emptyBag
+ruleCheck env (Lit l) = emptyBag
+ruleCheck env (Type ty) = emptyBag
+ruleCheck env (App f a) = ruleCheckApp env (App f a) []
+ruleCheck env (Note n e) = ruleCheck env e
+ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
+ruleCheck env (Lam b e) = ruleCheck env e
+ruleCheck env (Case e _ as) = ruleCheck env e `unionBags`
+ unionManyBags [ruleCheck env r | (_,_,r) <- as]
+
+ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
+ruleCheckApp env (Var f) as = ruleCheckFun env f as
+ruleCheckApp env other as = ruleCheck env other
+\end{code}
+
+\begin{code}
+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
+ | null name_match_rules = emptyBag
+ | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
+ where
+ name_match_rules = case idSpecialisation fn of
+ Rules rules _ -> filter match rules
+ match rule = pat `isPrefixOf` _UNPK_ (ruleName rule)
+
+ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
+ruleAppCheck_help phase 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)]
+ where
+ n_args = length args
+ i_args = args `zip` [1::Int ..]
+
+ check_rule rule = rule_herald rule <> colon <+> rule_info rule
+
+ rule_herald (BuiltinRule name _) = text "Builtin rule" <+> doubleQuotes (ptext name)
+ rule_herald (Rule name _ _ _ _) = text "Rule" <+> doubleQuotes (ptext name)
+
+ rule_info rule
+ | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
+ = text "matches (which is very peculiar!)"
+
+ rule_info (BuiltinRule name fn) = text "does not match"
+
+ rule_info (Rule name act rule_bndrs rule_args _)
+ | not (isActive phase 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 the rule as a whole does not"
+ | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
+ where
+ n_rule_args = length rule_args
+ n_mismatches = length mismatches
+ mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
+ not (isJust (match_fn rule_arg arg))]
+
+ bndr_set = mkVarSet rule_bndrs
+ match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst
\end{code}
= RuleBase (extendVarSet rule_ids new_id)
(rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
where
- new_id = setIdSpecialisation id (addRule old_rules id rule)
+ new_id = setIdSpecialisation id (addRule id old_rules rule)
old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
-- Get the old rules from rule_ids if the Id is already there, but
-- locally defined ones!!
pprRuleBase :: RuleBase -> SDoc
-pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs
- | id <- varSetElems rules,
- rs <- rulesRules $ idSpecialisation id ]
+pprRuleBase (RuleBase rules _) = vcat [ pprIdRules (tidyIdRules id)
+ | id <- varSetElems rules ]
\end{code}