[project @ 2003-10-16 10:19:27 by simonpj]

When type-checking an interface in --make, when the source file hasn't
changed, we must bring into scope all the things defined in the interface.
This was breaking --make badly.

The epicentre here is TcIface.typecheckIface

ghc/compiler/iface/IfaceEnv.lhs

@@ -296,7 +296,7 @@ tcIfaceGlobal name
     }}}
 
 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-tcIfaceTyCon IfaceIntTc = return intTyCon
+tcIfaceTyCon IfaceIntTc  = return intTyCon
 tcIfaceTyCon IfaceBoolTc = return boolTyCon
 tcIfaceTyCon IfaceCharTc = return charTyCon
 tcIfaceTyCon IfaceListTc = return listTyCon
@@ -362,24 +362,6 @@ extendIfaceTyVarEnv tyvars thing_inside
 %*									*
 %************************************************************************
 
-IfaceDecls etc are populated with RdrNames.  The RdrNames may either be
-
-  Orig or Unqual	when the interface is read from a file
-
-  Exact			when the interface is kept by GHCi, and is now 
-			being re-linked with the type environment
-
-At an occurrence site, to convert the RdrName to Name:
-  Unqual	look up in LocalRdrEnv
-  Orig		look up in OrigNameCache
-  Exact	 	return the Name
-
-At a binding site, to bind the RdrName
-  Unqual		we extend the LocalRdrEnv
-  Orig or Unqual	we don't extend the LocalRdrEnv (no need)
-
-First, we deal with the RdrName -> Name mapping
- 
 \begin{code}
 lookupIfaceTc :: IfaceTyCon -> IfL Name
 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext

ghc/compiler/iface/TcIface.lhs

@@ -32,6 +32,7 @@ import HscTypes		( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
 			  DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
 import InstEnv		( extendInstEnv )
 import CoreSyn
+import PprType		( pprClassPred )
 import PprCore		( pprIdRules )
 import Rules		( extendRuleBaseList )
 import CoreUtils	( exprType )
@@ -58,7 +59,7 @@ import Module		( Module, ModuleName, moduleName )
 import UniqSupply	( initUs_ )
 import Outputable	
 import SrcLoc		( noSrcLoc )
-import Util		( zipWithEqual, dropList, equalLength )
+import Util		( zipWithEqual, dropList, equalLength, zipLazy )
 import Maybes		( expectJust )
 import CmdLineOpts	( DynFlag(..) )
 \end{code}
@@ -208,22 +209,50 @@ selectDecl (Pool decls_map n_in n_out) name
 
 %************************************************************************
 %*									*
-		Other interfaces
+		Type-checking a complete interface
 %*									*
 %************************************************************************
 
+Suppose we discover we don't need to recompile.  Then we must type
+check the old interface file.  This is a bit different to the
+incremental type checking we do as we suck in interface files.  Instead
+we do things similarly as when we are typechecking source decls: we
+bring into scope the type envt for the interface all at once, using a
+knot.  Remember, the decls aren't necessarily in dependency order --
+and even if they were, the type decls might be mutually recursive.
+
 \begin{code}
-typecheckIface :: ModIface -> IfG ModDetails
--- Used when we decide not to recompile, but intead to use the
--- interface to construct the type environment for the module
-typecheckIface iface
-  = initIfaceLcl (moduleName (mi_module iface)) $
-    do	{ ty_things <- mapM (tcIfaceDecl . snd) (mi_decls iface)
-	; rules <- mapM tcIfaceRule (mi_rules iface)
+typecheckIface :: HscEnv
+	       -> ModIface 	-- Get the decls from here
+	       -> IO ModDetails
+typecheckIface hsc_env iface@(ModIface { mi_module = mod, mi_decls = ver_decls,
+				         mi_rules = rules, mi_insts = dfuns })
+  = initIfaceTc hsc_env iface $ \ tc_env_var -> do
+	{ 	-- Typecheck the decls
+	  names <- mappM (lookupOrig (moduleName mod) . ifName) decls
+	; ty_things <- fixM (\ rec_ty_things -> do
+		{ writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things))
+			-- This only makes available the "main" things,
+			-- but that's enough for the strictly-checked part
+		; mapM tcIfaceDecl decls })
+	
+		-- Now augment the type envt with all the implicit things
+		-- These will be needed when type-checking the unfoldings for
+		-- the IfaceIds, but this is done lazily, so writing the thing
+		-- now is sufficient
+	; let	{ add_implicits main_thing = main_thing : implicitTyThings main_thing
+		; type_env = mkTypeEnv (concatMap add_implicits ty_things) }
+	; writeMutVar tc_env_var type_env
+
+		-- Now do those rules and instances
 	; dfuns <- mapM tcIfaceInst (mi_insts iface)
-	; return (ModDetails { md_types = mkTypeEnv ty_things,
-			       md_insts = dfuns,
-			       md_rules = rules }) }
+	; rules <- mapM tcIfaceRule (mi_rules iface)
+
+		-- Finished
+	; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules }) 
+    }
+  where
+    decls = map snd ver_decls
 \end{code}
 
 
@@ -441,6 +470,9 @@ loadImportedInsts cls tys
 	  else do
 	{ writeMutVar eps_var (eps {eps_insts = inst_pool'})
 
+	; traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys, 
+			nest 2 (vcat (map ppr iface_insts))])
+
 	-- Typecheck the new instances
 	; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
 

ghc/compiler/main/HscMain.lhs

@@ -42,7 +42,8 @@ import StringBuffer	( hGetStringBuffer )
 import Parser
 import Lexer		( P(..), ParseResult(..), mkPState, showPFailed )
 import SrcLoc		( mkSrcLoc )
-import TcRnDriver	( tcRnModule, tcRnExtCore, tcRnIface )
+import TcRnDriver	( tcRnModule, tcRnExtCore )
+import TcIface		( typecheckIface )
 import IfaceEnv		( initNameCache )
 import LoadIface	( ifaceStats, initExternalPackageState )
 import PrelInfo		( wiredInThings, basicKnownKeyNames )
@@ -182,7 +183,7 @@ hscNoRecomp hsc_env have_object
 			showModMsg have_object mod location);
 
       new_details <- _scc_ "tcRnIface"
-		     tcRnIface hsc_env old_iface ;
+		     typecheckIface hsc_env old_iface ;
       dumpIfaceStats hsc_env ;
 
       return (HscNoRecomp new_details old_iface)

ghc/compiler/typecheck/TcRnDriver.lhs

@@ -10,7 +10,7 @@ module TcRnDriver (
 #endif
 	tcRnModule, 
 	tcTopSrcDecls,
-	tcRnIface, tcRnExtCore
+	tcRnExtCore
     ) where
 
 #include "HsVersions.h"
@@ -42,7 +42,7 @@ import TcEnv		( tcExtendGlobalValEnv, tcLookupGlobal )
 import TcRules		( tcRules )
 import TcForeign	( tcForeignImports, tcForeignExports )
 import TcInstDcls	( tcInstDecls1, tcInstDecls2 )
-import TcIface		( typecheckIface, tcExtCoreBindings )
+import TcIface		( tcExtCoreBindings )
 import TcSimplify	( tcSimplifyTop )
 import TcTyClsDecls	( tcTyAndClassDecls )
 import LoadIface	( loadOrphanModules )
@@ -199,24 +199,6 @@ tcRnModule hsc_env
 \end{code}
 
 
-%*********************************************************
-%*						 	 *
-\subsection{Closing up the interface decls}
-%*							 *
-%*********************************************************
-
-Suppose we discover we don't need to recompile.   Then we start from the
-IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
-
-\begin{code}
-tcRnIface :: HscEnv
-	  -> ModIface 	-- Get the decls from here
-	  -> IO ModDetails
-tcRnIface hsc_env iface
-  = initIfaceTc hsc_env iface (typecheckIface iface)
-\end{code}
-
-
 %************************************************************************
 %*									*
 		The interactive interface 

ghc/compiler/typecheck/TcRnMonad.lhs

@@ -12,7 +12,7 @@ import IOEnv		-- Re-export all
 
 import HsSyn		( MonoBinds(..) )
 import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
-			  TyThing, Dependencies(..),
+			  TyThing, Dependencies(..), TypeEnv, emptyTypeEnv,
 			  ExternalPackageState(..), HomePackageTable,
 			  ModDetails(..), HomeModInfo(..), 
 			  Deprecs(..), FixityEnv, FixItem,
@@ -754,15 +754,22 @@ initIfaceCheck hsc_env do_this
 	; initTcRnIf 'i' hsc_env gbl_env () do_this
     }
 
-initIfaceTc :: HscEnv -> ModIface -> IfG a -> IO a
+initIfaceTc :: HscEnv -> ModIface 
+ 	    -> (TcRef TypeEnv -> IfL 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 } ;
+ = do	{ tc_env_var <- newIORef emptyTypeEnv
+	; let { gbl_env = IfGblEnv { if_is_boot   = mkModDeps (dep_mods (mi_deps iface)),
+				     if_rec_types = Just (mod, readMutVar tc_env_var) } ;
+	      ; if_lenv = IfLclEnv { if_mod     = moduleName mod,
+				     if_tv_env  = emptyOccEnv,
+				     if_id_env  = emptyOccEnv }
 	   }
-	; initTcRnIf 'i' hsc_env gbl_env () do_this
+	; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
     }
+  where
+    mod = mi_module iface
 
 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
 -- Used when sucking in new Rules in SimplCore

ghc/compiler/typecheck/TcTyClsDecls.lhs

@@ -289,7 +289,7 @@ tcTyClDecl calc_vrcs calc_isrec decl
   = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
 
 tcTyClDecl1 calc_vrcs calc_isrec 
-	  (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+  (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
   =   tcTyVarBndrs tvs		$ \ tvs' -> do 
     { rhs_ty' <- tcHsKindedType rhs_ty
     ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) }
@@ -297,8 +297,8 @@ tcTyClDecl1 calc_vrcs calc_isrec
     arg_vrcs = calc_vrcs tc_name
 
 tcTyClDecl1 calc_vrcs calc_isrec 
-	  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
-		   tcdName = tc_name, tcdCons = cons})
+  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
+	   tcdName = tc_name, tcdCons = cons})
   = tcTyVarBndrs tvs		$ \ tvs' -> do 
   { ctxt' 	 <- tcHsKindedContext ctxt
   ; want_generic <- doptM Opt_Generics
@@ -315,9 +315,9 @@ tcTyClDecl1 calc_vrcs calc_isrec
     is_rec   = calc_isrec tc_name
 
 tcTyClDecl1 calc_vrcs calc_isrec 
-	  (ClassDecl {tcdName = class_name, tcdTyVars = tvs, 
-		      tcdCtxt = ctxt, tcdMeths = meths,
-		      tcdFDs = fundeps, tcdSigs = sigs} )
+  (ClassDecl {tcdName = class_name, tcdTyVars = tvs, 
+	      tcdCtxt = ctxt, tcdMeths = meths,
+	      tcdFDs = fundeps, tcdSigs = sigs} )
   = tcTyVarBndrs tvs		$ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM tc_fundep fundeps
@@ -340,7 +340,7 @@ tcTyClDecl1 calc_vrcs calc_isrec
 
 
 tcTyClDecl1 calc_vrcs calc_isrec 
-	  (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name})
+  (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name})
   = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
 
 -----------------------------------