X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=d6227abea0c5a2c8a2e994121c719889b74e4125;hb=b3fe66bb78fe11ee322f7442a5676e628f678b29;hp=a2db330dc168dab17ec070773df6e042a0f2fad5;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index a2db330..d6227ab 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -1,4 +1,4 @@
- \begin{code}
+\begin{code}
 module TcRnMonad(
 	module TcRnMonad,
 	module TcRnTypes,
@@ -17,7 +17,7 @@ import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
 			  ModDetails(..), HomeModInfo(..), 
 			  Deprecs(..), FixityEnv, FixItem,
 			  GhciMode, lookupType, unQualInScope )
-import Module		( Module, ModuleName, unitModuleEnv, foldModuleEnv )
+import Module		( Module, unitModuleEnv, foldModuleEnv )
 import RdrName		( GlobalRdrEnv, emptyGlobalRdrEnv, 	
 			  LocalRdrEnv, emptyLocalRdrEnv )
 import Name		( Name, isInternalName )
@@ -32,9 +32,8 @@ import ErrUtils		( Message, Messages, emptyMessages, errorsFound,
 			  mkLocMessage, mkLongErrMsg )
 import SrcLoc		( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
 import NameEnv		( emptyNameEnv )
-import NameSet		( emptyDUs, emptyNameSet )
+import NameSet		( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
 import OccName		( emptyOccEnv )
-import Module		( moduleName )
 import Bag		( emptyBag )
 import Outputable
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
@@ -75,6 +74,7 @@ initTc hsc_env mod do_this
       	tvs_var      <- newIORef emptyVarSet ;
 	type_env_var <- newIORef emptyNameEnv ;
 	dfuns_var    <- newIORef emptyNameSet ;
+	keep_var     <- newIORef emptyNameSet ;
 	th_var	     <- newIORef False ;
 
       	let {
@@ -96,7 +96,7 @@ initTc hsc_env mod do_this
 		tcg_insts    = [],
 		tcg_rules    = [],
 		tcg_fords    = [],
-		tcg_keep     = emptyNameSet
+		tcg_keep     = keep_var
 	     } ;
 	     lcl_env = TcLclEnv {
 		tcl_errs       = errs_var,
@@ -129,7 +129,7 @@ initTc hsc_env mod do_this
 	return (msgs, final_res)
     }
   where
-    init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv }
+    init_imports = emptyImportAvails { imp_env = unitModuleEnv mod emptyNameSet }
 	-- Initialise tcg_imports with an empty set of bindings for
 	-- this module, so that if we see 'module M' in the export
 	-- list, and there are no bindings in M, we don't bleat 
@@ -771,6 +771,14 @@ setLclTypeEnv lcl_env thing_inside
 recordThUse :: TcM ()
 recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
 
+keepAliveTc :: Name -> TcM ()  	-- Record the name in the keep-alive set
+keepAliveTc n = do { env <- getGblEnv; 
+		   ; updMutVar (tcg_keep env) (`addOneToNameSet` n) }
+
+keepAliveSetTc :: NameSet -> TcM ()  	-- Record the name in the keep-alive set
+keepAliveSetTc ns = do { env <- getGblEnv; 
+		       ; updMutVar (tcg_keep env) (`unionNameSets` ns) }
+
 getStage :: TcM ThStage
 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
 
@@ -842,7 +850,7 @@ initIfaceExtCore thing_inside
 	; let { mod = tcg_mod tcg_env
 	      ; if_env = IfGblEnv { 
 			if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
-	      ; if_lenv = IfLclEnv { if_mod     = moduleName mod,
+	      ; if_lenv = IfLclEnv { if_mod     = mod,
 				     if_tv_env  = emptyOccEnv,
 				     if_id_env  = emptyOccEnv }
 	  }
@@ -864,7 +872,7 @@ initIfaceTc :: HscEnv -> ModIface
 initIfaceTc hsc_env iface do_this
  = do	{ tc_env_var <- newIORef emptyTypeEnv
 	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
-	      ; if_lenv = IfLclEnv { if_mod     = moduleName mod,
+	      ; if_lenv = IfLclEnv { if_mod     = mod,
 				     if_tv_env  = emptyOccEnv,
 				     if_id_env  = emptyOccEnv }
 	   }
@@ -886,7 +894,7 @@ initIfaceRules hsc_env guts do_this
 	; initTcRnIf 'i' hsc_env gbl_env () do_this
     }
 
-initIfaceLcl :: ModuleName -> IfL a -> IfM lcl a
+initIfaceLcl :: Module -> IfL a -> IfM lcl a
 initIfaceLcl mod thing_inside 
   = setLclEnv (IfLclEnv { if_mod      = mod,
 			   if_tv_env  = emptyOccEnv,