X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=306a71b6edcb48ce68c3a8e1f478a446909160d1;hb=cb205eb46927f79850b89b5598989ca86a168c18;hp=374c9ccb6f77b21ea932a173764375b88c4dc478;hpb=1dfb756e01201c62ddde93010b3384d4d9644ad6;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 374c9cc..306a71b 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -15,7 +15,7 @@ import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
 			  TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
 			  ExternalPackageState(..), HomePackageTable,
 			  Deprecs(..), FixityEnv, FixItem, 
-			  GhciMode, lookupType, unQualInScope )
+			  lookupType, unQualInScope )
 import Module		( Module, unitModuleEnv )
 import RdrName		( GlobalRdrEnv, emptyGlobalRdrEnv, 	
 			  LocalRdrEnv, emptyLocalRdrEnv )
@@ -37,7 +37,8 @@ import Bag		( emptyBag )
 import Outputable
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
 import Unique		( Unique )
-import CmdLineOpts	( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug, dopt_set )
+import DynFlags		( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
+import StaticFlags	( opt_PprStyle_Debug )
 import Bag		( snocBag, unionBags )
 import Panic		( showException )
  
@@ -76,6 +77,7 @@ initTc hsc_env hsc_src mod do_this
 	dfuns_var    <- newIORef emptyNameSet ;
 	keep_var     <- newIORef emptyNameSet ;
 	th_var	     <- newIORef False ;
+	dfun_n_var   <- newIORef 1 ;
 
       	let {
 	     gbl_env = TcGblEnv {
@@ -92,11 +94,13 @@ initTc hsc_env hsc_src mod do_this
 		tcg_exports  = emptyNameSet,
 		tcg_imports  = init_imports,
 		tcg_dus      = emptyDUs,
+		tcg_rn_decls = Nothing,
 		tcg_binds    = emptyLHsBinds,
 		tcg_deprecs  = NoDeprecs,
 		tcg_insts    = [],
 		tcg_rules    = [],
 		tcg_fords    = [],
+		tcg_dfun_n   = dfun_n_var,
 		tcg_keep     = keep_var
 	     } ;
 	     lcl_env = TcLclEnv {
@@ -105,7 +109,7 @@ initTc hsc_env hsc_src mod do_this
 		tcl_ctxt       = [],
 		tcl_rdr	       = emptyLocalRdrEnv,
 		tcl_th_ctxt    = topStage,
-		tcl_arrow_ctxt = topArrowCtxt,
+		tcl_arrow_ctxt = NoArrowCtxt,
 		tcl_env        = emptyNameEnv,
 		tcl_tyvars     = tvs_var,
 		tcl_lie	       = panic "initTc:LIE",	-- LIE only valid inside a getLIE
@@ -238,8 +242,8 @@ ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()	-- Do it flag is tru
 ifOptM flag thing_inside = do { b <- doptM flag; 
 				if b then thing_inside else return () }
 
-getGhciMode :: TcRnIf gbl lcl GhciMode
-getGhciMode = do { env <- getTopEnv; return (hsc_mode env) }
+getGhciMode :: TcRnIf gbl lcl GhcMode
+getGhciMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 \end{code}
 
 \begin{code}
@@ -713,6 +717,13 @@ debugTc thing = return ()
 %************************************************************************
 
 \begin{code}
+nextDFunIndex :: TcM Int	-- Get the next dfun index
+nextDFunIndex = do { env <- getGblEnv
+		   ; let dfun_n_var = tcg_dfun_n env
+		   ; n <- readMutVar dfun_n_var
+		   ; writeMutVar dfun_n_var (n+1)
+		   ; return n }
+
 getLIEVar :: TcM (TcRef LIE)
 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
 
@@ -783,32 +794,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 
 %************************************************************************
 %*									*
-	     Arrow context
-%*									*
-%************************************************************************
-
-\begin{code}
-popArrowBinders :: TcM a -> TcM a	-- Move to the left of a (-<); see comments in TcRnTypes
-popArrowBinders 
-  = updLclEnv (\ env -> env { tcl_arrow_ctxt = pop (tcl_arrow_ctxt env)  })
-  where
-    pop (ArrCtxt {proc_level = curr_lvl, proc_banned = banned})
-	= ASSERT( not (curr_lvl `elem` banned) )
-	  ArrCtxt {proc_level = curr_lvl + 1, proc_banned = curr_lvl : banned}
-
-getBannedProcLevels :: TcM [ProcLevel]
-  = do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) }
-
-incProcLevel :: TcM a -> TcM a
-incProcLevel 
-  = updLclEnv (\ env -> env { tcl_arrow_ctxt = inc (tcl_arrow_ctxt env) })
-  where
-    inc ctxt = ctxt { proc_level = proc_level ctxt + 1 }
-\end{code}
-
-
-%************************************************************************
-%*									*
 	     Stuff for the renamer's local env
 %*									*
 %************************************************************************
@@ -862,16 +847,16 @@ initIfaceCheck hsc_env do_this
 	; initTcRnIf 'i' hsc_env gbl_env () do_this
     }
 
-initIfaceTc :: HscEnv -> ModIface 
- 	    -> (TcRef TypeEnv -> IfL a) -> IO a
+initIfaceTc :: ModIface 
+ 	    -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl 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	{ tc_env_var <- newIORef emptyTypeEnv
+initIfaceTc iface do_this
+ = do	{ tc_env_var <- newMutVar emptyTypeEnv
 	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
 	      ; if_lenv = mkIfLclEnv mod doc
 	   }
-	; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
+	; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
     }
   where
     mod = mi_module iface