[project @ 2003-10-13 10:43:02 by simonpj]

[ghc-hetmet.git] / ghc / compiler / specialise / Rules.lhs

diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index 4f9c24d..7a2f320 100644 (file)
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -7,7 +7,7 @@
 module Rules (
        RuleBase, emptyRuleBase, 
        extendRuleBase, extendRuleBaseList, 
-       ruleBaseIds, 
+       ruleBaseIds, getLocalRules,
        pprRuleBase, ruleCheckProgram,
 
         lookupRule, addRule, addIdSpecialisations
@@ -25,20 +25,21 @@ import Subst                ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
                          substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
                          bindSubstList, unBindSubstList, substInScope, uniqAway
                        )
-import Id              ( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) 
+import Id              ( Id, idIsFrom, idUnfolding, idSpecialisation, setIdSpecialisation ) 
 import Var             ( isId )
 import VarSet
 import VarEnv
 import TcType          ( mkTyVarTy )
 import qualified TcType ( match )
 import BasicTypes      ( Activation, CompilerPhase, isActive )
+import Module          ( Module )
 
 import Outputable
 import FastString
 import Maybe           ( isJust, isNothing, fromMaybe )
 import Util            ( sortLt )
 import Bag
-import List            ( isPrefixOf )
+import List            ( isPrefixOf, partition )
 \end{code}
 
 
@@ -607,6 +608,23 @@ extendRuleBase (RuleBase rule_ids) (id, rule)
        -- in which case it may have rules in its belly already.  Seems
        -- dreadfully hackoid.
 
+getLocalRules :: Module -> RuleBase -> (IdSet,         -- Ids with local rules
+                                       RuleBase)       -- Non-local rules
+-- Get the rules for locally-defined Ids out of the RuleBase
+-- If we miss any rules for Ids defined here, then we end up
+-- giving the local decl a new Unique (because the in-scope-set is the
+-- same as the rule-id set), and now the binding for the class method 
+-- doesn't have the same Unique as the one in the Class and the tc-env
+--     Example:        class Foo a where
+--                       op :: a -> a
+--                     {-# RULES "op" op x = x #-}
+-- 
+-- NB we can't use isLocalId, because isLocalId isn't true of class methods.
+getLocalRules this_mod (RuleBase ids)
+  = (mkVarSet local_ids, RuleBase (mkVarSet imp_ids))
+  where
+    (local_ids, imp_ids) = partition (idIsFrom this_mod) (varSetElems ids)
+
 pprRuleBase :: RuleBase -> SDoc
 pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
 \end{code}