\begin{code}
module Rules (
- RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase,
- unionRuleBase, lookupRule, addRule, addIdSpecialisations,
- ProtoCoreRule(..), pprProtoCoreRule, pprRuleBase,
- localRule, orphanRule
+ RuleBase, emptyRuleBase,
+ extendRuleBaseList,
+ ruleBaseIds, pprRuleBase, ruleCheckProgram,
+
+ lookupRule, addRule, addIdSpecialisations
) where
#include "HsVersions.h"
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseRule )
-import CoreFVs ( exprFreeVars, idRuleVars, ruleRhsFreeVars, ruleSomeLhsFreeVars )
+import CoreFVs ( exprFreeVars, ruleRhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
-import PprCore ( pprCoreRule )
-import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
- substEnv, setSubstEnv, emptySubst, isInScope,
- bindSubstList, unBindSubstList, substInScope, uniqAway
+import CoreTidy ( pprTidyIdRules )
+import Subst ( Subst, SubstResult(..), extendIdSubst,
+ getTvSubstEnv, setTvSubstEnv,
+ emptySubst, isInScope, lookupIdSubst, lookupTvSubst,
+ bindSubstList, unBindSubstList, substInScope
)
-import Id ( Id, idUnfolding, zapLamIdInfo,
- idSpecialisation, setIdSpecialisation,
- setIdNoDiscard
- )
-import Name ( isLocallyDefined )
-import Var ( isTyVar, isId )
+import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
+import Var ( Var, isId )
import VarSet
import VarEnv
-import Type ( mkTyVarTy )
-import qualified Unify ( match )
+import TcType ( mkTyVarTy )
+import qualified Unify ( matchTyX )
+import BasicTypes ( Activation, CompilerPhase, isActive )
-import UniqFM
import Outputable
-import Maybes ( maybeToBool )
-import Util ( sortLt )
+import FastString
+import Maybe ( isJust, isNothing, fromMaybe )
+import Util ( sortLe )
+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
-----------------------
app_match subst fn vs = foldl go fn vs
- where
- senv = substEnv subst
- go fn v = case lookupSubstEnv senv v of
- Just (DoneEx ex) -> fn `App` ex
- Just (DoneTy ty) -> fn `App` Type ty
- -- Substitution should bind them all!
-
+ where
+ go fn v = case lookupVar subst v of
+ Just e -> fn `App` e
+ Nothing -> pprPanic "app_match: unbound tpl" (ppr v)
+
+lookupVar :: Subst -> Var -> Maybe CoreExpr
+lookupVar subst v
+ | isId v = case lookupIdSubst subst v of
+ Just (DoneEx ex) -> Just ex
+ other -> Nothing
+ | otherwise = case lookupTvSubst subst v of
+ Just ty -> Just (Type ty)
+ Nothing -> Nothing
-----------------------
{- The code below tries to match even if there are more
mk_result_args subst done)
Nothing -> Nothing -- Failure
where
- (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v))
+ (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
(map zapOccInfo tpl_vars)
-- Zap the occ info
subst_env = substEnv subst
Nothing -> Nothing
eta_complete other vars = Nothing
--}
zapOccInfo bndr | isTyVar bndr = bndr
| otherwise = zapLamIdInfo bndr
+-}
\end{code}
\begin{code}
-> Subst -> Maybe result -- Substitution so far -> result
-- The *SubstEnv* in these Substs apply to the TEMPLATE only
--- The *InScopeSet* in these Substs gives variables bound so far in the
+-- The *InScopeSet* in these Substs is HIJACKED,
+-- to give the set of variables bound so far in the
-- target term. So when matching forall a. (\x. a x) against (\y. y y)
-- while processing the body of the lambdas, the in-scope set will be {y}.
-- That lets us do the occurs-check when matching 'a' against 'y'
+--
+-- It starts off empty
match :: CoreExpr -- Template
-> CoreExpr -- Target
match_fail = Nothing
-match (Var v1) e2 tpl_vars kont subst
- = case lookupSubst subst v1 of
+-- ToDo: remove this debugging junk
+-- match e1 e2 tpls kont subst = pprTrace "match" (ppr e1 <+> ppr e2 <+> ppr subst) $ match_ e1 e2 tpls kont subst
+match = match_
+
+match_ (Var v1) e2 tpl_vars kont subst
+ = case lookupIdSubst subst v1 of
Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
-> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
match_fail -- Occurs check failure
-- e.g. match forall a. (\x-> a x) against (\y. y y)
else
- kont (extendSubst subst v1 (DoneEx e2))
+ kont (extendIdSubst subst v1 (DoneEx e2))
- | eqExpr (Var v1) e2 -> kont subst
+ | eqExpr (Var v1) e2 -> kont subst
-- v1 is not a template variable, so it must be a global constant
- Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
+ Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
other -> match_fail
-match (Lit lit1) (Lit lit2) tpl_vars kont subst
+match_ (Lit lit1) (Lit lit2) tpl_vars kont subst
| lit1 == lit2
= kont subst
-match (App f1 a1) (App f2 a2) tpl_vars kont subst
+match_ (App f1 a1) (App f2 a2) tpl_vars kont subst
= match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
-match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
+match_ (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
= bind [x1] [x2] (match e1 e2) tpl_vars kont subst
-- This rule does eta expansion
-- (\x.M) ~ N iff M ~ N x
-- See assumption A3
-match (Lam x1 e1) e2 tpl_vars kont subst
+match_ (Lam x1 e1) e2 tpl_vars kont subst
= bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
-- Eta expansion the other way
-- M ~ (\y.N) iff \y.M y ~ \y.N
-- iff M y ~ N
-- Remembering that by (A), y can't be free in M, we get this
-match e1 (Lam x2 e2) tpl_vars kont subst
+match_ e1 (Lam x2 e2) tpl_vars kont subst
+ | new_id == x2 -- If the two are equal, don't bind, else we get
+ -- a substitution looking like x->x, and that sends
+ -- Unify.matchTy into a loop
+ = match (App e1 (mkVarArg new_id)) e2 tpl_vars kont subst
+ | otherwise
= bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
where
new_id = uniqAway (substInScope subst) x2
-- The first \x is ok, but when we inline k, hoping it might
-- match (:) we find a second \x.
-match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
- = match e1 e2 tpl_vars case_kont subst
+-- gaw 2004
+match_ (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) tpl_vars kont subst
+ = (match_ty ty1 ty2 tpl_vars $
+ match e1 e2 tpl_vars case_kont) subst
where
- case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
+ case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLe le_alt alts2))
tpl_vars kont subst
-match (Type ty1) (Type ty2) tpl_vars kont subst
+match_ (Type ty1) (Type ty2) tpl_vars kont subst
= match_ty ty1 ty2 tpl_vars kont subst
-match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+match_ (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
tpl_vars kont subst
= (match_ty to1 to2 tpl_vars $
match_ty from1 from2 tpl_vars $
-- variable, we expand it so long as its unfolding is a WHNF
-- (Its occurrence information is not necessarily up to date,
-- so we don't use it.)
-match e1 (Var v2) tpl_vars kont subst
+match_ e1 (Var v2) tpl_vars kont subst
| isCheapUnfolding unfolding
= match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
where
-- We can't cope with lets in the template
-match e1 e2 tpl_vars kont subst = match_fail
+match_ e1 e2 tpl_vars kont subst = match_fail
------------------------------------------
subst
match_alts alts1 alts2 tpl_vars kont subst = match_fail
-lt_alt (con1, _, _) (con2, _, _) = con1 < con2
+le_alt (con1, _, _) (con2, _, _) = con1 <= con2
----------------------------------------
bind :: [CoreBndr] -- Template binders
subst' = bindSubstList subst vs1 vs2
-- The unBindSubst relies on no shadowing in the template
- not_in_subst v = not (maybeToBool (lookupSubst subst v))
+ not_in_subst v = isNothing (lookupVar subst v)
bug_msg = sep [ppr vs1, ppr vs2]
----------------------------------------
-match_ty ty1 ty2 tpl_vars kont subst
- = case Unify.match ty1 ty2 tpl_vars Just (substEnv subst) of
- Nothing -> match_fail
- Just senv' -> kont (setSubstEnv subst senv')
-
-----------------------------------------
-matches [] [] tpl_vars kont subst
- = kont subst
-matches (e:es) (e':es') tpl_vars kont subst
- = match e e' tpl_vars (matches es es' tpl_vars kont) subst
-matches es es' tpl_vars kont subst
- = match_fail
-
-----------------------------------------
mkVarArg :: CoreBndr -> CoreArg
mkVarArg v | isId v = Var v
| otherwise = Type (mkTyVarTy v)
\end{code}
+Matching Core types: use the matcher in TcType.
+Notice that we treat newtypes as opaque. For example, suppose
+we have a specialised version of a function at a newtype, say
+ newtype T = MkT Int
+We only want to replace (f T) with f', not (f Int).
+
+\begin{code}
+----------------------------------------
+match_ty ty1 ty2 tpl_vars kont subst
+ = case Unify.matchTyX tpl_vars (getTvSubstEnv subst) ty1 ty2 of
+ Just tv_env' -> kont (setTvSubstEnv subst tv_env')
+ Nothing -> match_fail
+\end{code}
+
+
+
%************************************************************************
%* *
\subsection{Adding a new rule}
\begin{code}
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.
-- In this way we make sure that when looking up, the first match
-- We make no check for rules that unify without one dominating
-- the other. Arguably this would be a bug.
-addRule id (Rules rules rhs_fvs) 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
-- 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 = maybeToBool (matchRule tpl_var_set rule tpl_args)
+ new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
-addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id
-addIdSpecialisations id spec_stuff
- = setIdSpecialisation id new_rules
+addIdSpecialisations :: Id -> [CoreRule] -> Id
+addIdSpecialisations id rules
+ = setIdSpecialisation id new_specs
where
- rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
- new_rules = foldr add (idSpecialisation id) spec_stuff
- add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
+ new_specs = foldl (addRule id) (idSpecialisation id) rules
\end{code}
%************************************************************************
%* *
-\subsection{Preparing the rule base
+\subsection{Looking up a rule}
%* *
%************************************************************************
\begin{code}
-data ProtoCoreRule
- = ProtoCoreRule
- Bool -- True <=> this rule was defined in this module,
- Id -- What Id is it for
- CoreRule -- The rule itself
-
-
-pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (ppr fn) rule
-
-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
-
-localRule :: ProtoCoreRule -> Bool
-localRule (ProtoCoreRule local _ _) = local
-
-orphanRule :: ProtoCoreRule -> Bool
--- An "orphan rule" is one that is defined in this
--- module, but for an *imported* function. We need
--- to track these separately when generating the interface file
-orphanRule (ProtoCoreRule local fn _)
- = local && not (isLocallyDefined fn)
+ Rules rules _ -> matchRules is_active in_scope rules args
\end{code}
%************************************************************************
%* *
-\subsection{Getting the rules ready}
+\subsection{Checking a program for failing rule applications}
%* *
%************************************************************************
-\begin{code}
-type RuleBase = (IdSet, -- Imported Ids that have rules attached
- IdSet) -- Ids (whether local or imported) mentioned on
- -- LHS of some rule; these should be black listed
+-----------------------------------------------------
+ Game plan
+-----------------------------------------------------
-unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2)
- = (plusUFM_C merge_rules rule_ids1 rule_ids2,
- unionVarSet black_ids1 black_ids2)
- where
- merge_rules id1 id2 = let rules1 = idSpecialisation id1
- rules2 = idSpecialisation id2
- new_rules = foldl (addRule id1) rules1 (rulesRules rules2)
- in
- setIdSpecialisation id1 new_rules
+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.
-pprRuleBase :: RuleBase -> SDoc
-pprRuleBase (rules,_) = vcat [ pprCoreRule (ppr id) rs
- | id <- varSetElems rules,
- rs <- rulesRules $ idSpecialisation id ]
+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.
--- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
--- It attaches those rules that are for local Ids to their binders, and
--- returns the remainder attached to Ids in an IdSet. It also returns
--- Ids mentioned on LHS of some rule; these should be blacklisted.
+\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
+-- gaw 2004
+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}
--- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
--- so that the opportunity to apply the rule isn't lost too soon
+\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
-prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
-prepareLocalRuleBase binds local_rules
- = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs))
+ruleCheckFun (phase, pat) fn args
+ | null name_match_rules = emptyBag
+ | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
where
- (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) local_rules
- imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-
- -- rule_fvs is the set of all variables mentioned in this module's 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
- new_id = case lookupVarSet rule_id_set id of
- Just id' -> addRuleToId id' rule
- Nothing -> addRuleToId id rule
- lhs_fvs = ruleSomeLhsFreeVars isId rule
- -- Find *all* the free Ids of the LHS, not just
- -- locally defined ones!!
+ 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}
+
-addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule)
+%************************************************************************
+%* *
+\subsection{Getting the rules ready}
+%* *
+%************************************************************************
--- prepareOrphanRuleBase does exactly the same as prepareLocalRuleBase, except that
--- it assumes that none of the rules can be attached to local Ids.
+\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 -> [IdCoreRule] -> RuleBase
+extendRuleBaseList rule_base new_guys
+ = foldl extendRuleBase rule_base new_guys
+
+extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase
+extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule)
+ = RuleBase (extendVarSet rule_ids new_id)
+ where
+ 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
+ -- if not, use the Id from the incoming rule. If may be a PrimOpId,
+ -- in which case it may have rules in its belly already. Seems
+ -- dreadfully hackoid.
-prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase
-prepareOrphanRuleBase imported_rules
- = foldr add_rule (emptyVarSet, emptyVarSet) imported_rules
+pprRuleBase :: RuleBase -> SDoc
+pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
\end{code}