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

Deal corectly with rules for Ids defined in this module,
even when they are imported (as orphans) from other modules.

The epicentre for this stuff is SimplCore.

ghc/compiler/iface/MkIface.lhs

@@ -185,7 +185,7 @@ import TcRnMonad
 import TcRnTypes	( ImportAvails(..), mkModDeps )
 import HscTypes		( ModIface(..), 
 			  ModGuts(..), ModGuts, IfaceExport,
-			  GhciMode(..), noDependencies,
+			  GhciMode(..), 
 			  HscEnv(..), hscEPS,
 			  Dependencies(..), FixItem(..), 
 			  isImplicitTyThing, 
@@ -741,7 +741,7 @@ checkOldIface hsc_env mod iface_path source_unchanged maybe_iface
   = do	{ showPass (hsc_dflags hsc_env) 
 	           ("Checking old interface for " ++ moduleUserString mod) ;
 
-	; initIfaceIO hsc_env noDependencies {- wrong? -} $
+	; initIfaceCheck hsc_env $
 	  check_old_iface mod iface_path source_unchanged maybe_iface
      }
 

ghc/compiler/iface/TcIface.lhs

@@ -27,7 +27,7 @@ import TypeRep		( Type(..), PredType(..) )
 import TyCon		( TyCon, tyConName )
 import HscTypes		( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
 			  HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
-			  ModIface(..), ModDetails(..), InstPool, Dependencies(..),
+			  ModIface(..), ModDetails(..), InstPool, ModGuts,
 			  TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
 			  DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
 import InstEnv		( extendInstEnv )
@@ -492,19 +492,21 @@ are in the type environment.  However, remember that typechecking a Rule may
 (as a side effect) augment the type envt, and so we may need to iterate the process.
 
 \begin{code}
-loadImportedRules :: HscEnv -> Dependencies -> IO PackageRuleBase
-loadImportedRules hsc_env deps
-  = initIfaceIO hsc_env deps $ do 
+loadImportedRules :: HscEnv -> ModGuts -> IO PackageRuleBase
+loadImportedRules hsc_env guts
+  = initIfaceRules hsc_env guts $ do 
 	{ -- Get new rules
 	  if_rules <- updateEps (\ eps ->
 		let { (new_pool, if_rules) = selectRules (eps_rules eps) (eps_PTE eps) }
 		in (eps { eps_rules = new_pool }, if_rules) )
 
+	; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules))
+
 	; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
 	; core_rules <- mapM tc_rule if_rules
 
 	-- Debug print
-	; traceIf (ptext SLIT("Importing rules:") <+> pprIdRules core_rules)
+	; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules)
 	
 	-- Update the rule base and return it
 	; updateEps (\ eps -> 

ghc/compiler/simplCore/SimplCore.lhs

@@ -22,12 +22,12 @@ import HscTypes		( HscEnv(..), GhciMode(..),
 			)
 import CSE		( cseProgram )
 import Rules		( RuleBase, emptyRuleBase, ruleBaseIds, 
-			  extendRuleBaseList, pprRuleBase, 
+			  extendRuleBaseList, pprRuleBase, getLocalRules,
 			  ruleCheckProgram )
 import Module		( moduleEnvElts )
 import Name		( Name, isExternalName )
 import NameSet		( elemNameSet )
-import PprCore		( pprCoreBindings, pprCoreExpr )
+import PprCore		( pprCoreBindings, pprCoreExpr, pprIdRules )
 import OccurAnal	( occurAnalyseBinds, occurAnalyseGlobalExpr )
 import CoreUtils	( coreBindsSize )
 import Simplify		( simplTopBinds, simplExpr )
@@ -37,7 +37,7 @@ import ErrUtils		( dumpIfSet, dumpIfSet_dyn, showPass )
 import CoreLint		( endPass )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
-import Id		( idName, setIdLocalExported )
+import Id		( idName, idIsFrom, setIdLocalExported )
 import VarSet
 import LiberateCase	( liberateCase )
 import SAT		( doStaticArgs )
@@ -222,32 +222,23 @@ prepareRules :: HscEnv
 		    [IdCoreRule])	-- Orphan rules defined in this module
 
 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
-	     (ModGuts { mg_binds = binds, mg_rules = local_rules,
-			mg_deps = deps })
+	     guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod })
 	     us 
-  = do	{ pkg_rule_base <- loadImportedRules hsc_env deps
+  = do	{ pkg_rule_base <- loadImportedRules hsc_env guts
 
 	; let env	       = emptySimplEnv SimplGently [] local_ids 
 	      (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_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 #-}
-	      local_rule_base = extendRuleBaseList emptyRuleBase local_rules
-	      local_rule_ids  = ruleBaseIds local_rule_base	-- Local Ids with rules attached
-
-	      imp_rule_base   = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
-	      final_rule_base = extendRuleBaseList imp_rule_base orphan_rules
+	      imp_rule_base  = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
+	      full_rule_base = extendRuleBaseList imp_rule_base better_rules
+
+	      (local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base
+		-- NB: the imported rules may include rules for Ids in this module
+		      
+	      orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules
 
 	; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
-		(vcat [text "Local rules", pprRuleBase local_rule_base,
+		(vcat [text "Local rules", pprIdRules better_rules,
 		       text "",
 		       text "Imported rules", pprRuleBase final_rule_base])
 

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}

ghc/compiler/typecheck/TcRnDriver.lhs

@@ -213,7 +213,7 @@ tcRnIface :: HscEnv
 	  -> ModIface 	-- Get the decls from here
 	  -> IO ModDetails
 tcRnIface hsc_env iface
-  = initIfaceIO hsc_env (mi_deps iface) (typecheckIface iface)
+  = initIfaceTc hsc_env iface (typecheckIface iface)
 \end{code}
 
 

ghc/compiler/typecheck/TcRnMonad.lhs

@@ -11,7 +11,7 @@ import TcRnTypes	-- Re-export all
 import IOEnv		-- Re-export all
 
 import HsSyn		( MonoBinds(..) )
-import HscTypes		( HscEnv(..), 
+import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
 			  TyThing, Dependencies(..),
 			  ExternalPackageState(..), HomePackageTable,
 			  ModDetails(..), HomeModInfo(..), 
@@ -744,15 +744,38 @@ initIfaceExtCore thing_inside
 	  }
 	; setEnvs (if_env, if_lenv) thing_inside }
 
-initIfaceIO :: HscEnv -> Dependencies -> IfG a -> IO a
-initIfaceIO hsc_env deps do_this
+initIfaceCheck :: HscEnv -> IfG a -> IO a
+-- Used when checking the up-to-date-ness of the old Iface
+-- Initialise the environment with no useful info at all
+initIfaceCheck hsc_env do_this
+ = do	{ let { gbl_env = IfGblEnv { if_is_boot   = emptyModuleEnv,
+				     if_rec_types = Nothing } ;
+	   }
+	; initTcRnIf 'i' hsc_env gbl_env () do_this
+    }
+
+initIfaceTc :: HscEnv -> ModIface -> IfG a -> IO a
+-- Used when type-checking checking an up-to-date interface file
+-- No type envt from the current module, but we do know the module dependencies
+initIfaceTc hsc_env iface do_this
+ = do	{ let { gbl_env = IfGblEnv { if_is_boot   = mkModDeps (dep_mods (mi_deps iface)),
+				     if_rec_types = Nothing } ;
+	   }
+	; initTcRnIf 'i' hsc_env gbl_env () do_this
+    }
+
+initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
+-- Used when sucking in new Rules in SimplCore
+-- We have available the type envt of the module being compiled, and we must use it
+initIfaceRules hsc_env guts do_this
  = do	{ let {
-	     is_boot = mkModDeps (dep_mods deps)
+	     is_boot = mkModDeps (dep_mods (mg_deps guts))
 			-- Urgh!  But we do somehow need to get the info
 			-- on whether (for this particular compilation) we should
 			-- import a hi-boot file or not.
+	   ; type_info = (mg_module guts, return (mg_types guts))
 	   ; gbl_env = IfGblEnv { if_is_boot   = is_boot,
-				  if_rec_types = Nothing } ;
+				  if_rec_types = Just type_info } ;
 	   }
 
 	-- Run the thing; any exceptions just bubble out from here