- (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) all_rules
- imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-
- -- rule_fvs is the set of all variables mentioned in rules
- rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
-
- -- Attach the rules for each locally-defined Id to that Id.
- -- - This makes the rules easier to look up
- -- - It means that transformation rules and specialisations for
- -- locally defined Ids are handled uniformly
- -- - It keeps alive things that are referred to only from a rule
- -- (the occurrence analyser knows about rules attached to Ids)
- -- - It makes sure that, when we apply a rule, the free vars
- -- of the RHS are more likely to be in scope
- --
- -- The LHS and RHS Ids are marked 'no-discard'.
- -- This means that the binding won't be discarded EVEN if the binding
- -- ends up being trivial (v = w) -- the simplifier would usually just
- -- substitute w for v throughout, but we don't apply the substitution to
- -- the rules (maybe we should?), so this substitution would make the rule
- -- bogus.
- zap_bind (NonRec b r) = NonRec (zap_bndr b) r
- zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
-
- zap_bndr bndr = case lookupVarSet rule_ids bndr of
- Just bndr' -> setIdNoDiscard bndr'
- Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
- | otherwise -> bndr
-
-add_rule (ProtoCoreRule _ id rule)
- (rule_id_set, rule_fvs)
- = (rule_id_set `extendVarSet` new_id,
- rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
+ name_match_rules = case idSpecialisation fn of
+ Rules rules _ -> filter match rules
+ match rule = pat `isPrefixOf` unpackFS (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 _) =
+ ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
+ rule_herald (Rule name _ _ _ _) =
+ ptext SLIT("Rule") <+> doubleQuotes (ftext 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}
+
+
+%************************************************************************
+%* *
+\subsection{Getting the rules ready}
+%* *
+%************************************************************************
+
+\begin{code}
+data RuleBase = RuleBase
+ IdSet -- Ids with their rules in their specialisations
+ -- Held as a set, so that it can simply be the initial
+ -- in-scope set in the simplifier
+ -- This representation is a bit cute, and I wonder if we should
+ -- change it to use (IdEnv CoreRule) which seems a bit more natural
+
+ruleBaseIds (RuleBase ids) = ids
+emptyRuleBase = RuleBase emptyVarSet
+
+extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
+extendRuleBaseList rule_base new_guys
+ = foldl extendRuleBase rule_base new_guys
+
+extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
+extendRuleBase (RuleBase rule_ids) (id, rule)
+ = RuleBase (extendVarSet rule_ids new_id)