From: simonpj <unknown>
Date: Mon, 5 Jul 1999 15:30:27 +0000 (+0000)
Subject: [project @ 1999-07-05 15:30:25 by simonpj]
X-Git-Tag: Approximately_9120_patches~6039
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8ae0e52a7f204cb36c110f7f6a6e970992417b83;p=ghc-hetmet.git

[project @ 1999-07-05 15:30:25 by simonpj]
Make sure that instance gates have their home modules
loaded by RnIfaces.getImportedInstDecls.  This was causing
Kevin Atkinson's missing-instance bug.
---

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index ab38df6..ca22b19 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -277,13 +277,10 @@ slurpSourceRefs source_binders source_fvs
 		-- No declaration... (already slurped, or local)
 	    Nothing   -> go decls fvs gates refs
 	    Just decl -> rnIfaceDecl decl		`thenRn` \ (new_decl, fvs1) ->
-			 let
-			    new_gates = getGates source_fvs new_decl
-			 in
 			 go (new_decl : decls)
 			    (fvs1 `plusFV` fvs)
-			    (gates `plusFV` new_gates)
-			    (nameSetToList new_gates ++ refs)
+			    (gates `plusFV` getGates source_fvs new_decl)
+			    refs
 
 	-- When we find a wired-in name we must load its
 	-- home module so that we find any instance decls therein
@@ -312,14 +309,17 @@ but not @Foo@; so we need to chase @Foo@ too.
 
 \begin{code}
 slurpInstDecls decls needed gates
-  | isEmptyFVs gates
-  = returnRn (decls, needed)
-
-  | otherwise
-  = getImportedInstDecls gates				`thenRn` \ inst_decls ->
-    rnInstDecls decls needed emptyFVs inst_decls	`thenRn` \ (decls1, needed1, gates1) ->
-    slurpInstDecls decls1 needed1 gates1
+  = go decls needed gates gates
   where
+    go decls needed all_gates new_gates
+	| isEmptyFVs new_gates
+	= returnRn (decls, needed)
+
+	| otherwise
+	= getImportedInstDecls all_gates		`thenRn` \ inst_decls ->
+	  rnInstDecls decls needed emptyFVs inst_decls	`thenRn` \ (decls1, needed1, new_gates) ->
+	  go decls1 needed1 (all_gates `plusFV` new_gates) new_gates
+
     rnInstDecls decls fvs gates []
 	= returnRn (decls, fvs, gates)
     rnInstDecls decls fvs gates (d:ds) 
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 9446bfd..f7276b8 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -80,9 +80,19 @@ import List	( nub )
 %*********************************************************
 
 \begin{code}
-loadHomeInterface :: SDoc -> Name -> RnM d (Module, Ifaces)
+loadHomeInterface :: SDoc -> Name -> RnM d Ifaces
 loadHomeInterface doc_str name
-  = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
+  = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem		`thenRn` \ (_, ifaces) ->
+    returnRn ifaces
+
+loadOrphanModules :: [ModuleName] -> RnM d ()
+loadOrphanModules mods
+  | null mods = returnRn ()
+  | otherwise = traceRn (text "Loading orphan modules:" <+> fsep (map pprModuleName mods))	`thenRn_` 
+		mapRn_ load mods	`thenRn_`
+		returnRn ()
+  where
+    load mod = loadInterface (pprModuleName mod <+> ptext SLIT("is a orphan-instance module")) mod ImportBySystem
 
 loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Module, Ifaces)
 loadInterface doc_str mod_name from
@@ -445,13 +455,9 @@ importDecl name
     if name `elemNameSet` already_slurped then
 	returnRn Nothing	-- Already dealt with
     else
-	getModuleRn 		`thenRn` \ this_mod ->
-	let
-	  mod = moduleName (nameModule name)
-	in
-	if mod == this_mod then		-- Don't bring in decls from
+	if isLocallyDefined name then	-- Don't bring in decls from
 					-- the renamed module's own interface file
-		  addWarnRn (importDeclWarn mod name) `thenRn_`
+		  addWarnRn (importDeclWarn name) `thenRn_`
 		  returnRn Nothing
 	else
 	getNonWiredInDecl name
@@ -461,7 +467,7 @@ importDecl name
 getNonWiredInDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl))
 getNonWiredInDecl needed_name 
   = traceRn doc_str				`thenRn_`
-    loadHomeInterface doc_str needed_name	`thenRn` \ (_, ifaces) ->
+    loadHomeInterface doc_str needed_name	`thenRn` \ ifaces ->
     case lookupNameEnv (iDecls ifaces) needed_name of
 
       Just (version,avail,_,decl)
@@ -531,33 +537,40 @@ getInterfaceExports mod_name from
 \begin{code}
 getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
 getImportedInstDecls gates
-  = 	-- First load any orphan-instance modules that aren't aready loaded
+  = 	-- First, ensure that the home module of each gate is loaded
+    mapRn_ load_home gate_list				`thenRn_`	
+
+   	-- Next, load any orphan-instance modules that aren't aready loaded
 	-- Orphan-instance modules are recorded in the module dependecnies
-    getIfacesRn 						`thenRn` \ ifaces ->
+    getIfacesRn 					`thenRn` \ ifaces ->
     let
 	orphan_mods =
 	  [mod | (mod, (_, True, Nothing)) <- fmToList (iImpModInfo ifaces)]
     in
-    traceRn (text "Loading orphan modules" <+> fsep (map pprModuleName orphan_mods))
-    `thenRn_` mapRn_ load_it orphan_mods 	`thenRn_`
+    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 ->
+    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 (nameSetToList gates))),
+		  nest 4 (fsep (map ppr gate_list)),
 		  text "Slurped" <+> int (length decls)
 			         <+> text "instance declarations"]) `thenRn_`
     returnRn decls
   where
-    load_it mod = loadInterface (doc_str mod) mod ImportBySystem
-    doc_str mod = sep [pprModuleName mod, ptext SLIT("is a orphan-instance module")]
+    gate_list      = nameSetToList gates
+
+    load_home gate | isLocallyDefined gate
+		   = returnRn ()
+		   | otherwise
+		   = loadHomeInterface (ppr gate <+> text "is an instance gate") gate	`thenRn_`
+		     returnRn ()
 
 getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
 getImportedRules
@@ -572,6 +585,7 @@ getImportedRules
     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
@@ -593,7 +607,7 @@ lookupFixity name
 	Nothing		  	 -> returnRn defaultFixity
 
   | otherwise	-- Imported
-  = loadHomeInterface doc name		`thenRn` \ (_, ifaces) ->
+  = loadHomeInterface doc name		`thenRn` \ ifaces ->
     case lookupNameEnv (iFixes ifaces) name of
 	Just (FixitySig _ fix _) -> returnRn fix 
 	Nothing 		 -> returnRn defaultFixity
@@ -933,14 +947,13 @@ getDeclWarn name loc
   = sep [ptext SLIT("Failed to find (optional) interface decl for") <+> quotes (ppr name),
 	 ptext SLIT("desired at") <+> ppr loc]
 
-importDeclWarn mod name
+importDeclWarn name
   = sep [ptext SLIT(
     "Compiler tried to import decl from interface file with same name as module."), 
 	 ptext SLIT(
     "(possible cause: module name clashes with interface file already in scope.)")
 	] $$
-    hsep [ptext SLIT("Interface:"), quotes (pprModuleName mod), 
-	  comma, ptext SLIT("name:"), quotes (ppr name)]
+    hsep [ptext SLIT("name:"), quotes (ppr name)]
 
 warnRedundantSourceImport mod_name
   = ptext SLIT("Unnecessary {- SOURCE -} in the import of module")
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 96bf4ef..9f46d36 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -153,8 +153,6 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
 	Nothing -> returnRn Nothing ;
 	Just all_avails ->
 
-   traceRn (text "updateProv" <+> fsep (map ppr (rdrEnvElts gbl_env)))	`thenRn_`
-    
 	-- DEAL WITH FIXITIES
    fixitiesFromLocalDecls gbl_env decls		`thenRn` \ local_fixity_env ->
    let