[project @ 2001-06-28 09:49:40 by simonmar]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplCore.lhs

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 47addf3..b419461 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -32,7 +32,7 @@ import SimplMonad
 import ErrUtils                ( dumpIfSet, dumpIfSet_dyn )
 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )
-import Id              ( idName, isDataConWrapId, setIdNoDiscard, isLocalId, isImplicitId )
+import Id              ( idName, isDataConWrapId, setIdNoDiscard, isImplicitId )
 import VarSet
 import LiberateCase    ( liberateCase )
 import SAT             ( doStaticArgs )
@@ -62,24 +62,25 @@ core2core :: DynFlags               -- includes spec of what core-to-core passes to do
          -> PersistentCompilerState
          -> HomeSymbolTable
          -> IsExported
-         -> [CoreBind]         -- Binds in
-         -> [IdCoreRule]       -- Rules defined in this module
-         -> IO ([CoreBind], [IdCoreRule])  -- binds, local orphan rules out
+         -> ModDetails
+         -> IO ModDetails
 
-core2core dflags pcs hst is_exported binds rules
+core2core dflags pcs hst is_exported 
+         mod_details@(ModDetails { md_binds = binds_in, md_rules = rules_in })
   = do
         let core_todos    = dopt_CoreToDo dflags
        let pkg_rule_base = pcs_rules pcs               -- Rule-base accumulated from imported packages
+       
 
        us <-  mkSplitUniqSupply 's'
        let (cp_us, ru_us) = splitUniqSupply us
 
                -- COMPUTE THE RULE BASE TO USE
        (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
-               <- prepareRules dflags pkg_rule_base hst ru_us binds rules
+               <- prepareRules dflags pkg_rule_base hst ru_us binds_in rules_in
 
                -- PREPARE THE BINDINGS
-       let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds
+       let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds_in
 
                -- DO THE BUSINESS
        (stats, processed_binds)
@@ -92,7 +93,7 @@ core2core dflags pcs hst is_exported binds rules
        -- Return results
         -- We only return local orphan rules, i.e., local rules not attached to an Id
        -- The bindings cotain more rules, embedded in the Ids
-       return (processed_binds, orphan_rules)
+       return (mod_details { md_binds = processed_binds, md_rules = orphan_rules})
 
 
 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
@@ -209,7 +210,17 @@ prepareRules dflags pkg_rule_base hst us binds local_rules
   = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all 
                                          (mapSmpl simplRule local_rules)
 
-       ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules
+       ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
+               -- We use (`elemVarSet` local_ids) rather than isLocalId because
+               -- isLocalId isn't true of class methods.
+               -- 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 #-}
+
              rule_rhs_fvs                = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
              local_rule_base             = extendRuleBaseList emptyRuleBase local_rules
              local_rule_ids              = ruleBaseIds local_rule_base -- Local Ids with rules attached
@@ -234,8 +245,6 @@ prepareRules dflags pkg_rule_base hst us binds local_rules
     add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
 
        -- Boringly, we need to gather the in-scope set.
-       -- Typically this thunk won't even be forced, but the test in
-       -- simpVar fails if it isn't right, and it might conceiveably matter
     local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds