[project @ 2004-11-29 16:25:03 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcRnMonad.lhs

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index a2db330..d6227ab 100644 (file)
--- 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,