[project @ 2000-11-03 17:10:57 by simonpj]

More renamer... not in a working state I fear

6 files changed, 263 insertions, 241 deletions

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index a54934d32a..c1e1dad097 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -30,7 +30,7 @@ import RnHiFiles	( readIface, removeContext,
 import RnEnv		( availName, 
 			  emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails,
 			  warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
-			  lookupOrigNames, lookupGlobalRn, newGlobalName
+			  lookupOrigNames, lookupSrcName, newGlobalName
 			)
 import Module           ( Module, ModuleName, WhereFrom(..),
 			  moduleNameUserString, moduleName,
@@ -41,7 +41,7 @@ import Name		( Name, NamedThing(..), getSrcLoc,
 			  nameOccName, nameModule,
 			)
 import Name		( mkNameEnv, nameEnvElts, extendNameEnv )
-import RdrName		( elemRdrEnv )
+import RdrName		( elemRdrEnv, foldRdrEnv, isQual )
 import OccName		( occNameFlavour )
 import NameSet
 import TysWiredIn	( unitTyCon, intTyCon, boolTyCon )
@@ -149,6 +149,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc)
 		-- when compiling the prelude, locally-defined (), Bool, etc
 		-- override the implicit ones. 
     in
+    traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList slurp_fvs)))	`thenRn_`
     slurpImpDecls slurp_fvs		`thenRn` \ rn_imp_decls ->
 
 	-- EXIT IF ERRORS FOUND
@@ -291,39 +292,31 @@ isOrphanDecl _ _  = False
 \begin{code}
 fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
 fixitiesFromLocalDecls gbl_env decls
-  = doptRn Opt_WarnUnusedBinds				  `thenRn` \ warn_unused ->
-    foldlRn (getFixities warn_unused) emptyNameEnv decls  `thenRn` \ env -> 
-    traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))
-							  `thenRn_`
+  = foldlRn getFixities emptyNameEnv decls				`thenRn` \ env -> 
+    traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))	`thenRn_`
     returnRn env
   where
-    getFixities :: Bool -> LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
-    getFixities warn_uu acc (FixD fix)
-      = fix_decl warn_uu acc fix
+    getFixities :: LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
+    getFixities acc (FixD fix)
+      = fix_decl acc fix
 
-    getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
-      = foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs]
+    getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
+      = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
 		-- Get fixities from class decl sigs too.
-    getFixities warn_uu acc other_decl
+    getFixities acc other_decl
       = returnRn acc
 
-    fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc)
+    fix_decl acc sig@(FixitySig rdr_name fixity loc)
 	= 	-- Check for fixity decl for something not declared
 	  pushSrcLocRn loc 			$
-	  lookupGlobalRn gbl_env rdr_name	`thenRn` \  maybe_name ->
-	  case maybe_name of {
-	    Nothing ->	checkRn (not warn_uu) (unusedFixityDecl rdr_name fixity)	`thenRn_` 
-			returnRn acc ;
-
-	    Just name ->
+	  lookupSrcName gbl_env rdr_name	`thenRn` \ name ->
 
 		-- Check for duplicate fixity decl
-	  case lookupNameEnv acc name of {
-	    Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
-					 `thenRn_` returnRn acc ;
+	  case lookupNameEnv acc name of
+	    Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')	`thenRn_`
+					 returnRn acc ;
 
-	    Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
-	  }}
+	    Nothing		      -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
 \end{code}
 
 
@@ -352,11 +345,9 @@ rnDeprecs gbl_env Nothing decls
     returnRn (DeprecSome (mkNameEnv (catMaybes pairs)))
  where
    rn_deprec (Deprecation rdr_name txt loc)
-     = pushSrcLocRn loc			$
-       lookupGlobalRn gbl_env rdr_name	`thenRn` \ maybe_name ->
-       case maybe_name of
-	 Just n  -> returnRn (Just (n,(n,txt)))
-	 Nothing -> returnRn Nothing
+     = pushSrcLocRn loc				$
+       lookupSrcName gbl_env rdr_name		`thenRn` \ name ->
+       returnRn (Just (name, (name,txt)))
 \end{code}
 
 
@@ -543,6 +534,7 @@ reportUnusedNames my_mod_iface imports avail_env
     warnUnusedImports bad_imp_names				`thenRn_`
     printMinimalImports this_mod minimal_imports		`thenRn_`
     warnDeprecations this_mod my_deprecs really_used_names	`thenRn_`
+    traceRn (text "Used" <+> fsep (map ppr (nameSetToList used_names)))	`thenRn_`
     returnRn ()
 
   where
@@ -569,10 +561,16 @@ reportUnusedNames my_mod_iface imports avail_env
 			    		other		   -> Nothing]
     	    ]
     
-    defined_names, defined_and_used, defined_but_not_used :: [(Name,Provenance)]
-    defined_names			     = concat (rdrEnvElts gbl_env)
+	-- Collect the defined names from the in-scope environment
+	-- Look for the qualified ones only, else get duplicates
+    defined_names :: [(Name,Provenance)]
+    defined_names = foldRdrEnv add [] gbl_env
+    add rdr_name ns acc | isQual rdr_name = ns ++ acc
+			| otherwise	  = acc
+
+    defined_and_used, defined_but_not_used :: [(Name,Provenance)]
     (defined_and_used, defined_but_not_used) = partition used defined_names
-    used (name,_)	  		     = not (name `elemNameSet` really_used_names)
+    used (name,_)	  		     = name `elemNameSet` really_used_names
     
     -- Filter out the ones only defined implicitly
     bad_locals :: [Name]
@@ -801,9 +799,6 @@ warnDeprec (name, txt)
           text "is deprecated:", nest 4 (ppr txt) ]
 
 
-unusedFixityDecl rdr_name fixity
-  = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
-
 dupFixityDecl rdr_name loc1 loc2
   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 	  ptext SLIT("at ") <+> ppr loc1,
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index a3c31d692e..b991dc8819 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -180,7 +180,8 @@ lookupTopBndrRn rdr_name
 			 -- if there are many with the same occ name
 			 -- There must *be* a binding
 		getModuleRn		`thenRn` \ mod ->
-		lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name)
+		getGlobalNameEnv	`thenRn` \ global_env ->
+    		lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
 
 -- lookupSigOccRn is used for type signatures and pragmas
 -- Is this valid?
@@ -209,19 +210,21 @@ lookupOccRn rdr_name
 --	class op names in class and instance decls
 
 lookupGlobalOccRn rdr_name
+  = getModeRn 		`thenRn` \ mode ->
+    case mode of 
+	SourceMode    -> getGlobalNameEnv			`thenRn` \ global_env ->
+    			 lookupSrcName global_env rdr_name
+
+	InterfaceMode -> lookupIfaceName rdr_name
+
+lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
+-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
+lookupSrcName global_env rdr_name
   | isOrig rdr_name	-- Can occur in source code too
   = lookupOrigName rdr_name
 
   | otherwise
-  = getModeRn 		`thenRn` \ mode ->
-    case mode of 
-	SourceMode    -> lookupSrcGlobalOcc rdr_name
-	InterfaceMode -> lookupIfaceUnqual rdr_name
-
-lookupSrcGlobalOcc rdr_name
-  -- Lookup a source-code rdr-name; may be qualified or not
-  = getGlobalNameEnv			`thenRn` \ global_env ->
-    case lookupRdrEnv global_env rdr_name of
+  = case lookupRdrEnv global_env rdr_name of
 	Just [(name,_)]		-> returnRn name
 	Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff	`thenRn_`
 		       		   returnRn name
@@ -246,15 +249,6 @@ lookupIfaceName :: RdrName -> RnM d Name
 lookupIfaceName rdr_name
   | isUnqual rdr_name = lookupIfaceUnqual rdr_name
   | otherwise	      = lookupOrigName rdr_name
-
-lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
-  -- Checks that there is exactly one
-lookupGlobalRn global_env rdr_name
-  = case lookupRdrEnv global_env rdr_name of
-	Just [(name,_)]		-> returnRn (Just name)
-	Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff	`thenRn_`
-		       		   returnRn (Just name)
-	Nothing			-> returnRn Nothing
 \end{code}
 
 @lookupOrigName@ takes an RdrName representing an {\em original}
diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index 4af718ed1a..7a2cd23fca 100644
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -342,7 +342,7 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
     in
     setModuleRn mod $
     mapRn lookupIfaceName free_names	`thenRn` \ gate_names ->
-    returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
+    returnRn ((gate_names, (mod, InstD decl)) `consBag` insts)
 
 
 -- In interface files, the instance decls now look like
@@ -376,7 +376,7 @@ loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
 -- needed.  We can refine this later.
 loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
   = lookupIfaceName var		`thenRn` \ var_name ->
-    returnRn (unitNameSet var_name, (mod, RuleD decl))
+    returnRn ([var_name], (mod, RuleD decl))
 
 
 -----------------------------------------------------
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index b1a9d0f8ee..c8691df89a 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -33,6 +33,7 @@ import RnSource		( rnTyClDecl, rnDecl )
 import RnEnv
 import RnMonad
 import Id		( idType )
+import DataCon		( classDataCon, dataConId )
 import Type		( namesOfType )
 import TyCon		( isSynTyCon, getSynTyConDefn )
 import Name		( Name {-instance NamedThing-}, nameOccName,
@@ -78,80 +79,6 @@ getInterfaceExports mod_name from
 
 %*********************************************************
 %*							*
-\subsection{Instance declarations are handled specially}
-%*							*
-%*********************************************************
-
-\begin{code}
-getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
-getImportedInstDecls gates
-  =    	-- First, load any orphan-instance modules that aren't aready loaded
-	-- Orphan-instance modules are recorded in the module dependecnies
-    getIfacesRn 					`thenRn` \ ifaces ->
-    let
-	orphan_mods =
-	  [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
-    in
-    loadOrphanModules orphan_mods			`thenRn_` 
-
-	-- Now we're ready to grab the instance declarations
-	-- Find the un-gated ones and return them, 
-	-- removing them from the bag kept in Ifaces
-    getIfacesRn 					`thenRn` \ ifaces ->
-    let
-	(decls, new_insts) = selectGated gates (iInsts ifaces)
-    in
-    setIfacesRn (ifaces { iInsts = new_insts })		`thenRn_`
-
-    traceRn (sep [text "getImportedInstDecls:", 
-		  nest 4 (fsep (map ppr gate_list)),
-		  text "Slurped" <+> int (length decls) <+> text "instance declarations",
-		  nest 4 (vcat (map ppr_brief_inst_decl decls))])	`thenRn_`
-    returnRn decls
-  where
-    gate_list      = nameSetToList gates
-
-ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _))
-  = case inst_ty of
-	HsForAllTy _ _ tau -> ppr tau
-	other		   -> ppr inst_ty
-
-getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
-getImportedRules 
-  | opt_IgnoreIfacePragmas = returnRn []
-  | otherwise
-  = getIfacesRn 	`thenRn` \ ifaces ->
-    let
-	gates		   = iSlurp ifaces	-- Anything at all that's been slurped
-	rules		   = iRules ifaces
-	(decls, new_rules) = selectGated gates rules
-    in
-    if null decls then
-	returnRn []
-    else
-    setIfacesRn (ifaces { iRules = new_rules })		     `thenRn_`
-    traceRn (sep [text "getImportedRules:", 
-		  text "Slurped" <+> int (length decls) <+> text "rules"])   `thenRn_`
-    returnRn decls
-
-selectGated gates decl_bag
-	-- Select only those decls whose gates are *all* in 'gates'
-#ifdef DEBUG
-  | opt_NoPruneDecls	-- Just to try the effect of not gating at all
-  = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag)	-- Grab them all
-
-  | otherwise
-#endif
-  = foldrBag select ([], emptyBag) decl_bag
-  where
-    select (reqd, decl) (yes, no)
-	| isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no)
-	| otherwise				     = (yes,      (reqd,decl) `consBag` no)
-\end{code}
-
-
-%*********************************************************
-%*							*
 \subsection{Keeping track of what we've slurped, and version numbers}
 %*							*
 %*********************************************************
@@ -379,9 +306,9 @@ slurpSourceRefs source_binders source_fvs
     go_inner (decls, fvs, gates) wanted_name
 	= importDecl wanted_name 		`thenRn` \ import_result ->
 	  case import_result of
-	    AlreadySlurped -> returnRn (decls, fvs, gates)
-	    WiredIn        -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
-	    Deferred       -> returnRn (decls, fvs, gates `addOneFV` wanted_name)	-- It's a type constructor
+	    AlreadySlurped     -> returnRn (decls, fvs, gates)
+	    InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing)
+	    Deferred           -> returnRn (decls, fvs, gates `addOneFV` wanted_name)	-- It's a type constructor
 			
 	    HereItIs decl -> rnIfaceTyClDecl decl		`thenRn` \ (new_decl, fvs1) ->
 			     returnRn (TyClD new_decl : decls, 
@@ -530,33 +457,73 @@ stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2))
 %*							 *
 %*********************************************************
 
+The gating story
+~~~~~~~~~~~~~~~~~
+We want to avoid sucking in too many instance declarations.
+An instance decl is only useful if the types and classes mentioned in
+its 'head' are all available in the program being compiled.  E.g.
+
+	instance (..) => C (T1 a) (T2 b) where ...
+
+is only useful if C, T1 and T2 are all available.  So we keep
+instance decls that have been parsed from .hi files, but not yet
+slurped in, in a pool called the 'gated instance pool'.
+Each has its set of 'gates': {C, T1, T2} in the above example.
+
+THE GATING INVARIANT 
+
+    *All* the instances whose gates are entirely in the stuff that's
+    already been through the type checker (i.e. are already in the
+    Persistent Type Environment or Home Symbol Table) have already been
+    slurped in, and are no longer in the gated instance pool.
+
+Hence, when we read a new module, we see what new gates we have,
+and let in any instance decls whose gates are 
+	either	in the new gates, 
+	or	in the HST/PTE
+
+An earlier optimisation: now infeasible
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we import a declaration like
 \begin{verbatim}
 	data T = T1 Wibble | T2 Wobble
 \end{verbatim}
-we don't want to treat @Wibble@ and @Wobble@ as gates
-{\em unless} @T1@, @T2@ respectively are mentioned by the user program.
-If only @T@ is mentioned
-we want only @T@ to be a gate;
-that way we don't suck in useless instance
-decls for (say) @Eq Wibble@, when they can't possibly be useful.
+we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless}
+@T1@, @T2@ respectively are mentioned by the user program.  If only
+@T@ is mentioned we want only @T@ to be a gate; that way we don't suck
+in useless instance decls for (say) @Eq Wibble@, when they can't
+possibly be useful.
+
+BUT, I can't see how to do this and still maintain the GATING INVARIANT.
+So I've simply ditched the optimisation to get things working.
+
+
+
 
 @getGates@ takes a newly imported (and renamed) decl, and the free
 vars of the source program, and extracts from the decl the gate names.
 
 \begin{code}
-getGates source_fvs (IfaceSig _ ty _ _)
+getGates :: FreeVars		-- Things mentioned in the source program
+	 -> RenamedHsDecl
+	 -> FreeVars
+
+get_gates source_fvs decl = get_gates (\n -> True) decl
+	-- We'd use (\n -> n `elemNameSet` source_fvs)
+	-- if we were using the 'earlier optimisation above
+
+get_gates is_used (IfaceSig _ ty _ _)
   = extractHsTyNames ty
 
-getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
+get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ )
   = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
 		        (hsTyVarNames tvs)
      `addOneToNameSet` cls)
     `plusFV` maybe_double
   where
     get (ClassOpSig n _ ty _) 
-	| n `elemNameSet` source_fvs = extractHsTyNames ty
-	| otherwise		     = emptyFVs
+	| is_used n = extractHsTyNames ty
+	| otherwise = emptyFVs
 
 	-- If we load any numeric class that doesn't have
 	-- Int as an instance, add Double to the gates. 
@@ -568,18 +535,17 @@ getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
 		 | otherwise
 		 = emptyFVs
 
-getGates source_fvs (TySynonym tycon tvs ty _)
-  = delListFromNameSet (extractHsTyNames ty)
-		       (hsTyVarNames tvs)
+get_gates is_used (TySynonym tycon tvs ty _)
+  = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
 	-- A type synonym type constructor isn't a "gate" for instance decls
 
-getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
+get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _)
   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
 		       (hsTyVarNames tvs)
     `addOneToNameSet` tycon
   where
     get (ConDecl n _ tvs ctxt details _)
-	| n `elemNameSet` source_fvs
+	| is_used n
 		-- If the constructor is method, get fvs from all its fields
 	= delListFromNameSet (get_details details `plusFV` 
 		  	      extractHsCtxtTyNames ctxt)
@@ -597,8 +563,8 @@ getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
 
-    get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
-		     | otherwise			 = emptyFVs
+    get_field (fs,t) | any is_used fs = get_bang t
+		     | otherwise      = emptyFVs
 
     get_bang bty = extractHsTyNames (getBangType bty)
 \end{code}
@@ -607,18 +573,23 @@ getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
 rather than a declaration.
 
 \begin{code}
-getWiredInGates :: Name -> FreeVars
-getWiredInGates name 	-- No classes are wired in
-  = case lookupNameEnv wiredInThingEnv name of
-	Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id))
-
-	Just (ATyCon tc)
-	  |  isSynTyCon tc
-	  -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
-	  where
-	     (tyvars,ty)  = getSynTyConDefn tc
-
-	other -> unitFV name
+getWiredInGates :: TyThing -> FreeVars
+-- The TyThing is one that we already have in our type environment, either
+--	a) because the TyCon or Id is wired in, or
+--	b) from a previous compile
+-- Either way, we might have instance decls in the (persistend) collection
+-- of parsed-but-not-slurped instance decls that should be slurped in.
+-- This might be the first module that mentions both the type and the class
+-- for that instance decl, even though both the type and the class were
+-- mentioned in other modules, and hence are in the type environment
+
+getWiredInGates (AnId the_id) = getWiredInGates_s (namesOfType (idType the_id))
+getWiredInGates (AClass cl)   = namesOfType (idType (dataConId (classDataCon cl)))	-- Cunning
+getWiredInGates (ATyCon tc)
+  | isSynTyCon tc = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
+  | otherwise	  = unitFV (getName tc)
+  where
+    (tyvars,ty)  = getSynTyConDefn tc
 
 getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
 \end{code}
@@ -628,6 +599,77 @@ getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
 getInstDeclGates other				    = emptyFVs
 \end{code}
 
+\begin{code}
+getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
+getImportedInstDecls gates
+  =    	-- First, load any orphan-instance modules that aren't aready loaded
+	-- Orphan-instance modules are recorded in the module dependecnies
+    getIfacesRn 					`thenRn` \ ifaces ->
+    let
+	orphan_mods =
+	  [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
+    in
+    loadOrphanModules orphan_mods			`thenRn_` 
+
+	-- Now we're ready to grab the instance declarations
+	-- Find the un-gated ones and return them, 
+	-- removing them from the bag kept in Ifaces
+    getIfacesRn 					`thenRn` \ ifaces ->
+    getTypeEnvRn					`thenRn` \ lookup ->
+    let
+	(decls, new_insts) = selectGated gates lookup (iInsts ifaces)
+    in
+    setIfacesRn (ifaces { iInsts = new_insts })		`thenRn_`
+
+    traceRn (sep [text "getImportedInstDecls:", 
+		  nest 4 (fsep (map ppr gate_list)),
+		  text "Slurped" <+> int (length decls) <+> text "instance declarations",
+		  nest 4 (vcat (map ppr_brief_inst_decl decls))])	`thenRn_`
+    returnRn decls
+  where
+    gate_list      = nameSetToList gates
+
+ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _))
+  = case inst_ty of
+	HsForAllTy _ _ tau -> ppr tau
+	other		   -> ppr inst_ty
+
+getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
+getImportedRules 
+  | opt_IgnoreIfacePragmas = returnRn []
+  | otherwise
+  = getIfacesRn 	`thenRn` \ ifaces ->
+    getTypeEnvRn	`thenRn` \ lookup ->
+    let
+	gates		   = iSlurp ifaces	-- Anything at all that's been slurped
+	rules		   = iRules ifaces
+	(decls, new_rules) = selectGated gates lookup rules
+    in
+    if null decls then
+	returnRn []
+    else
+    setIfacesRn (ifaces { iRules = new_rules })		     `thenRn_`
+    traceRn (sep [text "getImportedRules:", 
+		  text "Slurped" <+> int (length decls) <+> text "rules"])   `thenRn_`
+    returnRn decls
+
+selectGated gates lookup decl_bag
+	-- Select only those decls whose gates are *all* in 'gates'
+	-- or are in the range of lookup
+#ifdef DEBUG
+  | opt_NoPruneDecls	-- Just to try the effect of not gating at all
+  = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag)	-- Grab them all
+
+  | otherwise
+#endif
+  = foldrBag select ([], emptyBag) decl_bag
+  where
+    available n = n `elemNameSet` gates || maybeToBool (lookup n)
+    select (reqd, decl) (yes, no)
+	| all available reqd = (decl:yes, no)
+	| otherwise	     = (yes,      (reqd,decl) `consBag` no)
+\end{code}
+
 
 %*********************************************************
 %*							*
@@ -640,42 +682,57 @@ importDecl :: Name -> RnMG ImportDeclResult
 
 data ImportDeclResult
   = AlreadySlurped
-  | WiredIn	
+  | InTypeEnv TyThing
   | Deferred
   | HereItIs (Module, RdrNameTyClDecl)
 
 importDecl name
-  = 	-- Check if it was loaded before beginning this module
+  = 	-- STEP 1: Check if it was loaded before beginning this module
     if isLocalName name then
+	traceRn (text "Already (local)" <+> ppr name) `thenRn_`
 	returnRn AlreadySlurped
     else
-    checkAlreadyAvailable name		`thenRn` \ done ->
-    if done then
-	returnRn AlreadySlurped
-    else
 
-	-- Check if we slurped it in while compiling this module
+	-- STEP 2: Check if it's already in the type environment
+    getTypeEnvRn 			`thenRn` \ lookup ->
+    case lookup name of {
+	Just ty_thing | name `elemNameEnv` wiredInThingEnv
+		      -> 	-- When we find a wired-in name we must load its home
+				-- module so that we find any instance decls lurking therein
+			 loadHomeInterface wi_doc name	`thenRn_`
+			 returnRn (InTypeEnv (getWiredInGates ty_thing))
+
+		      | otherwise
+		      ->  returnRn (InTypeEnv ty_thing) ;
+
+	Nothing -> 
+
+	-- STEP 3: Check if we've slurped it in while compiling this module
     getIfacesRn				`thenRn` \ ifaces ->
     if name `elemNameSet` iSlurp ifaces then	
 	returnRn AlreadySlurped	
-    else 
+    else
 
-	-- When we find a wired-in name we must load its home
-	-- module so that we find any instance decls lurking therein
-    if name `elemNameEnv` wiredInThingEnv then
-	loadHomeInterface doc name	`thenRn_`
-	returnRn WiredIn
+	-- STEP 4: OK, we have to slurp it in from an interface file
+	--	   First load the interface file
+    traceRn nd_doc			`thenRn_`
+    loadHomeInterface nd_doc name	`thenRn_`
+    getIfacesRn				`thenRn` \ ifaces ->
+
+	-- STEP 5: Get the declaration out
+    case lookupNameEnv (iDecls ifaces) name of
+      Just (avail,_,decl)
+	-> setIfacesRn (recordSlurp ifaces avail)	`thenRn_`
+	   returnRn (HereItIs decl)
 
-    else getNonWiredInDecl name
+      Nothing 
+	-> addErrRn (getDeclErr name)	`thenRn_` 
+	   returnRn AlreadySlurped
+    }
   where
-    doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+    wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+    nd_doc = ptext SLIT("need decl for") <+> ppr name
 
-getNonWiredInDecl :: Name -> RnMG ImportDeclResult
-getNonWiredInDecl needed_name 
-  = traceRn doc_str				`thenRn_`
-    loadHomeInterface doc_str needed_name	`thenRn_`
-    getIfacesRn					`thenRn` \ ifaces ->
-    case lookupNameEnv (iDecls ifaces) needed_name of
 
 {- 		OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS
       Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _)))
@@ -716,16 +773,6 @@ getNonWiredInDecl needed_name
 	   tycon_name = availName avail
 -}
 
-      Just (avail,_,decl)
-	-> setIfacesRn (recordSlurp ifaces avail)	`thenRn_`
-	   returnRn (HereItIs decl)
-
-      Nothing 
-	-> addErrRn (getDeclErr needed_name)	`thenRn_` 
-	   returnRn AlreadySlurped
-  where
-     doc_str = ptext SLIT("need decl for") <+> ppr needed_name
-
 {-		OMIT FOR NOW
 getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)]
 getDeferredDecls 
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index a1b9d7732d..0d562d3114 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -40,7 +40,7 @@ import HscTypes		( AvailEnv, lookupType,
 			  WhetherHasOrphans, ImportVersion, 
 			  PersistentRenamerState(..), IsBootInterface, Avails,
 			  DeclsMap, IfaceInsts, IfaceRules, 
-			  HomeSymbolTable, PackageTypeEnv,
+			  HomeSymbolTable, TyThing,
 			  PersistentCompilerState(..), GlobalRdrEnv,
 			  HomeIfaceTable, PackageIfaceTable,
 			  RdrAvailInfo )
@@ -67,7 +67,6 @@ import Bag		( Bag, emptyBag, isEmptyBag, snocBag )
 import UniqSupply
 import Outputable
 import PrelNames	( mkUnboundName )
-import Maybes		( maybeToBool )
 import ErrUtils		( printErrorsAndWarnings )
 
 infixr 9 `thenRn`, `thenRn_`
@@ -127,11 +126,13 @@ data RnDown
 	rn_dflags  :: DynFlags,
 
 	rn_hit     :: HomeIfaceTable,
-	rn_done    :: Name -> Bool,	-- Tells what things (both in the
-					-- home package and other packages)
-					-- were already available (i.e. in
-					-- the relevant SymbolTable) before 
-					-- compiling this module
+	rn_done    :: Name -> Maybe TyThing,	-- Tells what things (both in the
+						-- home package and other packages)
+						-- were already available (i.e. in
+						-- the relevant SymbolTable) before 
+						-- compiling this module
+			-- The Name passed to rn_done is guaranteed to be a Global,
+			-- so it has a Module, so it can be looked up
 
 	rn_errs    :: IORef (Bag WarnMsg, Bag ErrMsg),
 
@@ -330,7 +331,7 @@ initRn dflags hit hst pcs mod do_rn
 	
 			       rn_dflags = dflags,
 			       rn_hit    = hit,
-			       rn_done   = is_done hst pte,
+			       rn_done   = lookupType hst pte,
 					     
 			       rn_ns     = names_var, 
 			       rn_errs   = errs_var, 
@@ -358,11 +359,6 @@ initRn dflags hit hst pcs mod do_rn
 
 	return (new_pcs, not (isEmptyBag errs), res)
 
-is_done :: HomeSymbolTable -> PackageTypeEnv -> Name -> Bool
--- Returns True iff the name is in either symbol table
--- The name is a Global, so it has a Module
-is_done hst pte n = maybeToBool (lookupType hst pte n)
-
 initRnMS rn_env fixity_env mode thing_inside rn_down g_down
 	-- The fixity_env appears in both the rn_fixenv field
 	-- and in the HIT.  See comments with RnHiFiles.lookupFixityRn
@@ -589,9 +585,8 @@ getSrcLocRn down l_down
 getHomeIfaceTableRn :: RnM d HomeIfaceTable
 getHomeIfaceTableRn down l_down = return (rn_hit down)
 
-checkAlreadyAvailable :: Name -> RnM d Bool
-	-- Name is a Global name
-checkAlreadyAvailable name down l_down = return (rn_done down name)
+getTypeEnvRn :: RnM d (Name -> Maybe TyThing)
+getTypeEnvRn down l_down = return (rn_done down)
 \end{code}
 
 %================
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index f62fc86f3f..a66c4510bf 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -542,46 +542,37 @@ exportsFromAvail this_mod (Just export_items)
 				   returnRn (mod:mods, occs', avails')
 
     exports_from_item warn_dups acc@(mods, occs, avails) ie
-	| not (maybeToBool maybe_in_scope) 
-	= failWithRn acc (unknownNameErr (ieName ie))
+	= lookupSrcName global_name_env (ieName ie)	`thenRn` \ name -> 
 
-	| not (null dup_names)
-	= addNameClashErrRn rdr_name ((name,prov):dup_names)	`thenRn_`
-	  returnRn acc
-
-#ifdef DEBUG
-	-- I can't see why this should ever happen; if the thing is in scope
-	-- at all it ought to have some availability
-	| not (maybeToBool maybe_avail)
-	= pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
-	  returnRn acc
-#endif
+		-- See what's available in the current environment
+	  case lookupUFM entity_avail_env name of {
+	    Nothing -> 	-- I can't see why this should ever happen; if the thing 
+			-- is in scope at all it ought to have some availability
+			pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
+			returnRn acc ;
 
-	| not enough_avail
-	= failWithRn acc (exportItemErr ie)
+	    Just avail ->
 
-	| otherwise	-- Phew!  It's OK!  Now to check the occurrence stuff!
+		-- Filter out the bits we want
+	  case filterAvail ie avail of {
+	    Nothing -> 	-- Not enough availability
+			   failWithRn acc (exportItemErr ie) ;
 
+	    Just export_avail -> 	
 
-	= warnCheckRn (ok_item ie avail) (dodgyExportWarn ie)	`thenRn_`
+		-- Phew!  It's OK!  Now to check the occurrence stuff!
+	  warnCheckRn (ok_item ie avail) (dodgyExportWarn ie)	`thenRn_`
           check_occs ie occs export_avail			`thenRn` \ occs' ->
 	  returnRn (mods, occs', addAvail avails export_avail)
+	  }}
+
+
 
-       where
-	  rdr_name	  = ieName ie
-          maybe_in_scope  = lookupFM global_name_env rdr_name
-	  Just ((name,prov):dup_names) = maybe_in_scope
-	  maybe_avail        = lookupUFM entity_avail_env name
-	  Just avail         = maybe_avail
- 	  maybe_export_avail = filterAvail ie avail
-	  enough_avail	     = maybeToBool maybe_export_avail
-	  Just export_avail  = maybe_export_avail
-
-    ok_item (IEThingAll _) (AvailTC _ [n]) = False
-		-- This occurs when you import T(..), but
-		-- only export T abstractly.  The single [n]
-		-- in the AvailTC is the type or class itself
-    ok_item _ _ = True
+ok_item (IEThingAll _) (AvailTC _ [n]) = False
+  -- This occurs when you import T(..), but
+  -- only export T abstractly.  The single [n]
+  -- in the AvailTC is the type or class itself
+ok_item _ _ = True
 
 check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
 check_occs ie occs avail