[project @ 2003-10-10 09:39:33 by simonpj]

Make rule importing work properly

ghc/compiler/iface/LoadIface.lhs

@@ -29,7 +29,7 @@ import HscTypes		( HscEnv(..), ModIface(..), emptyModIface,
 			  lookupIfaceByModName, emptyPackageIfaceTable,
 			  IsBootInterface, mkIfaceFixCache, 
 			  Pool(..), DeclPool, InstPool, 
-			  RulePool, Gated, addRuleToPool
+			  RulePool, Gated, addRuleToPool, RulePoolContents
 			 )
 
 import BasicTypes	( Version, Fixity(..), FixityDirection(..) )
@@ -371,7 +371,7 @@ loadRules mod pool@(Pool rule_pool n_in n_out) rules
 	{ new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules
 	; returnM (Pool new_pool (n_in + length rules) n_out) } }
 
-loadRule :: ModuleName -> NameEnv [Gated IfaceRule] -> IfaceRule -> IfL (NameEnv [Gated IfaceRule])
+loadRule :: ModuleName -> RulePoolContents -> IfaceRule -> IfL RulePoolContents
 -- "Gate" the rule simply by a crude notion of the free vars of
 -- the LHS.  It can be crude, because having too few free vars is safe.
 loadRule mod_name pool decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
@@ -590,9 +590,9 @@ initExternalPackageState
       eps_PTE        = emptyTypeEnv,
       eps_inst_env   = emptyInstEnv,
       eps_rule_base  = emptyRuleBase,
-      eps_decls      = emptyPool,
-      eps_insts      = emptyPool,
-      eps_rules = foldr add emptyPool builtinRules
+      eps_decls      = emptyPool emptyNameEnv,
+      eps_insts      = emptyPool emptyNameEnv,
+      eps_rules      = foldr add (emptyPool []) builtinRules
     }
   where
 	-- Initialise the EPS rule pool with the built-in rules
@@ -640,7 +640,7 @@ ifaceStats eps
 
     Pool _ n_decls_in n_decls_out = eps_decls eps
     Pool _ n_insts_in n_insts_out = eps_insts eps
-    Pool _ n_rules_in n_rules_out  = eps_rules eps
+    Pool _ n_rules_in n_rules_out = eps_rules eps
     
     stats = vcat 
     	[int n_mods <+> text "interfaces read",

ghc/compiler/iface/TcIface.lhs

@@ -6,7 +6,7 @@
 \begin{code}
 module TcIface ( 
 	tcImportDecl, typecheckIface,
-	tcIfaceKind, loadImportedInsts, 
+	tcIfaceKind, loadImportedInsts, loadImportedRules,
 	tcExtCoreBindings
  ) where
 #include "HsVersions.h"
@@ -25,13 +25,14 @@ import Type		( Kind, openTypeKind, liftedTypeKind,
 			  mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
 import TypeRep		( Type(..), PredType(..) )
 import TyCon		( TyCon, tyConName )
-import HscTypes		( ExternalPackageState(..), PackageInstEnv,
-			  TyThing(..), implicitTyThings, typeEnvIds,
+import HscTypes		( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
+			  HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
 			  ModIface(..), ModDetails(..), InstPool, 
 			  TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
 			  DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
 import InstEnv		( extendInstEnv )
 import CoreSyn
+import PprCore		( pprIdRules )
 import Rules		( extendRuleBaseList )
 import CoreUtils	( exprType )
 import CoreUnfold
@@ -152,7 +153,7 @@ recordImportOf :: TyThing -> IfG ()
 --	     whose gates are all in the type envt, is in eps_rule_base
 
 recordImportOf thing
-  = do 	{ (new_things, iface_rules) <- updateEps (\ eps -> 
+  = do 	{ new_things <- updateEps (\ eps -> 
 	    let { new_things   = thing : implicitTyThings thing 
 	 	; new_type_env = extendTypeEnvList (eps_PTE eps) new_things
 		-- NB: opportunity for a very subtle loop here!
@@ -163,24 +164,12 @@ recordImportOf thing
 		--	* which pokes the suspended forks
 		--	* which, to execute, need to consult type-env (to check
 		--	  entirely unrelated types, perhaps)
-
-	        ; (new_rules, iface_rules) = selectRules (eps_rules eps) 
-						         (map getName new_things)
-						         new_type_env }
-	    in (eps { eps_PTE = new_type_env, eps_rules = new_rules }, 
-	        (new_things, iface_rules))
+	    }
+	    in (eps { eps_PTE = new_type_env }, new_things)
 	  )
-
-    -- Now type-check those rules (which may side-effect the EPS again)
 	; traceIf (text "tcImport: extend type env" <+> ppr new_things)
-	; traceIf (text "tcImport: rules" <+> vcat (map ppr iface_rules))
-	; core_rules <- mapM tc_rule iface_rules
-	; updateEps_ (\ eps -> 
-	    eps { eps_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
-	  ) }
+	}
 	
-tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
-
 getThing :: Name -> IfG TyThing
 -- Find and typecheck the thing; the Name might be a "subordinate name"
 -- of the "main thing" (e.g. the constructor of a data type declaration)
@@ -503,30 +492,42 @@ 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}
-selectRules :: RulePool 
-	    -> [Name] 		-- Names of things being added
-	    -> TypeEnv 		-- New type env, including things being added
-	    -> (RulePool, [(ModuleName, IfaceRule)])
-selectRules (Pool rules n_in n_out) new_names type_env
-  = (Pool rules' n_in (n_out + length iface_rules), iface_rules)
+loadImportedRules :: HscEnv -> IO PackageRuleBase
+loadImportedRules hsc_env
+  = initIfaceIO hsc_env $ 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) )
+
+	; 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)
+	
+	-- Update the rule base and return it
+	; updateEps (\ eps -> 
+	    let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
+	    in (eps { eps_rule_base = new_rule_base }, new_rule_base)
+	  ) }
+
+
+selectRules :: RulePool -> TypeEnv -> (RulePool, [(ModuleName, IfaceRule)])
+-- Not terribly efficient.  Look at each rule in the pool to see if
+-- all its gates are in the type env.  If so, take it out of the pool.
+-- If not, trim its gates for next time.
+selectRules (Pool rules n_in n_out) type_env
+  = (Pool rules' n_in (n_out + length if_rules), if_rules)
   where
-    (rules', iface_rules) = foldl select_one (rules, []) new_names
-
-    select_one :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Name
-	       -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)])
-    select_one (rules, decls) name
-	= case lookupNameEnv rules name of
-	    Nothing 	     -> (rules, decls)
-	    Just gated_rules -> foldl filter_rule (delFromNameEnv rules name, decls) gated_rules
-
-    filter_rule :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Gated IfaceRule 
-		-> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)])
-    filter_rule (rules, decls) (rule_fvs, rule)
-	= case [fv | fv <- rule_fvs, not (fv `elemNameEnv` type_env)] of
-	    [] ->	-- No remaining FVs, so slurp it
-		 	(rules, rule:decls)
-	    fvs -> 	-- There leftover fvs, so toss it back in the pool
-			(addRuleToPool rules rule fvs, decls)
+    (rules', if_rules) = foldl do_one ([], []) rules
+
+    do_one (pool, if_rules) (gates, rule)
+	| null gates' = (pool, rule:if_rules)
+	| otherwise   = ((gates',rule) : pool, if_rules)
+	where
+	  gates' = filter (`elemNameEnv` type_env) gates
+
 
 tcIfaceRule :: IfaceRule -> IfL IdCoreRule
 tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,

ghc/compiler/main/HscTypes.lhs

@@ -39,7 +39,7 @@ module HscTypes (
 	Dependencies(..), noDependencies,
 	Pool(..), emptyPool, DeclPool, InstPool, 
 	Gated,
-	RulePool, addRuleToPool, 
+	RulePool, RulePoolContents, addRuleToPool, 
 	NameCache(..), OrigNameCache, OrigIParamCache,
 	Avails, availsToNameSet, availName, availNames,
 	GenAvailInfo(..), AvailInfo, RdrAvailInfo, 
@@ -739,14 +739,7 @@ data ExternalPackageState
 		-- available before this instance decl is needed.
 
 	eps_rules :: !RulePool
-		-- Rules move from here to eps_rule_base when 
-		-- all their LHS free vars are in the eps_PTE
-		-- To maintain this invariant, we need to check the pool
-		-- 	a) when adding to the rule pool by loading an interface
-		--	   (some of the new rules may alrady have all their
-		--	   gates in the eps_PTE)
-		--	b) when extending the eps_PTE when we load a decl
-		-- 	   from the eps_decls pool
+		-- The as-yet un-slurped rules
   }
 \end{code}
 
@@ -777,36 +770,35 @@ type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name)
 \end{code}
 
 \begin{code}
-data Pool p = Pool (NameEnv p) 	-- The pool itself, indexed by some primary key
+data Pool p = Pool p	 	-- The pool itself
 		   Int		-- Number of decls slurped into the map
 		   Int		-- Number of decls slurped out of the map
 
-emptyPool = Pool emptyNameEnv 0 0
+emptyPool p = Pool p 0 0
 
 instance Outputable p => Outputable (Pool p) where
   ppr (Pool p n_in n_out) 	-- Debug printing only
 	= vcat [ptext SLIT("Pool") <+> int n_in <+> int n_out,
 		nest 2 (ppr p)]
   
-type DeclPool = Pool IfaceDecl
+type DeclPool = Pool (NameEnv IfaceDecl)	-- Keyed by the "main thing" of the decl
 
 -------------------------
 type Gated d = ([Name], (ModuleName, d))	-- The [Name] 'gate' the declaration
 						-- ModuleName records which iface file this
 						-- decl came from
 
-type RulePool = Pool [Gated IfaceRule]
+type RulePool = Pool RulePoolContents
+type RulePoolContents = [Gated IfaceRule]
 
-addRuleToPool :: NameEnv [Gated IfaceRule] 
+addRuleToPool :: RulePoolContents
 	      -> (ModuleName, IfaceRule)
 	      -> [Name] 	-- Free vars of rule; always non-empty
-	      -> NameEnv [Gated IfaceRule]
-addRuleToPool rules rule (fv:fvs) = extendNameEnv_C combine rules fv [(fvs,rule)]
-				  where
-				    combine old _ = (fvs,rule) : old
+	      -> RulePoolContents
+addRuleToPool rules rule fvs = (fvs,rule) : rules
 
 -------------------------
-type InstPool = Pool [Gated IfaceInst]
+type InstPool = Pool (NameEnv [Gated IfaceInst])
 	-- The key of the Pool is the Class
 	-- The Names are the TyCons in the instance head
 	-- For example, suppose this is in an interface file

ghc/compiler/simplCore/SimplCore.lhs

@@ -14,6 +14,7 @@ import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..),
 			)
 import CoreSyn
 import CoreFVs		( ruleRhsFreeVars )
+import TcIface		( loadImportedRules )
 import HscTypes		( HscEnv(..), GhciMode(..),
 			  ModGuts(..), ModGuts, Avails, availsToNameSet, 
 			  ModDetails(..),
@@ -224,7 +225,7 @@ prepareRules :: HscEnv
 
 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 	     us binds local_rules
-  = do	{ eps <- hscEPS hsc_env
+  = do	{ pkg_rule_base <- loadImportedRules hsc_env
 
 	; let env	       = emptySimplEnv SimplGently [] local_ids 
 	      (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
@@ -242,7 +243,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 	      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 (eps_rule_base eps) (moduleEnvElts hpt)
+	      imp_rule_base   = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
 	      final_rule_base = extendRuleBaseList imp_rule_base orphan_rules
 
 	; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"