Fix a recomp bug: make classes/datatypes depend directly on DFuns (#4469)

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

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 456bd7e..92fa190 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -69,9 +69,9 @@ initTc :: HscEnv
 
 initTc hsc_env hsc_src keep_rn_syntax mod do_this
  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
+        meta_var     <- newIORef initTyVarUnique ;
        tvs_var      <- newIORef emptyVarSet ;
-       dfuns_var    <- newIORef emptyNameSet ;
-       keep_var     <- newIORef emptyNameSet ;
+        keep_var     <- newIORef emptyNameSet ;
         used_rdr_var <- newIORef Set.empty ;
        th_var       <- newIORef False ;
        lie_var      <- newIORef emptyBag ;
@@ -88,16 +88,15 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
             gbl_env = TcGblEnv {
                tcg_mod       = mod,
                tcg_src       = hsc_src,
-               tcg_rdr_env   = hsc_global_rdr_env hsc_env,
+               tcg_rdr_env   = emptyGlobalRdrEnv,
                tcg_fix_env   = emptyNameEnv,
                tcg_field_env = RecFields emptyNameEnv emptyNameSet,
                tcg_default   = Nothing,
-               tcg_type_env  = hsc_global_type_env hsc_env,
+               tcg_type_env  = emptyNameEnv,
                tcg_type_env_var = type_env_var,
                tcg_inst_env  = emptyInstEnv,
                tcg_fam_inst_env  = emptyFamInstEnv,
-               tcg_inst_uses = dfuns_var,
-               tcg_th_used   = th_var,
+                tcg_th_used   = th_var,
                tcg_exports  = [],
                tcg_imports  = emptyImportAvails,
                 tcg_used_rdrnames = used_rdr_var,
@@ -133,7 +132,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcl_env        = emptyNameEnv,
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
-               tcl_untch      = emptyVarSet
+                tcl_meta       = meta_var,
+               tcl_untch      = initTyVarUnique
             } ;
        } ;
    
@@ -166,9 +166,8 @@ initTcPrintErrors   -- Used from the interactive loop only
        -> Module 
        -> TcM r
        -> IO (Messages, Maybe r)
-initTcPrintErrors env mod todo = do
-  (msgs, res) <- initTc env HsSrcFile False mod todo
-  return (msgs, res)
+
+initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
 \end{code}
 
 %************************************************************************
@@ -251,7 +250,7 @@ doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
 
 setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
-                        env { env_top = top { hsc_dflags = xopt_set_flattened (hsc_dflags top) flag}} )
+                        env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
 
 unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
@@ -315,14 +314,24 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
 %************************************************************************
 
 \begin{code}
+newMetaUnique :: TcM Unique
+-- The uniques for TcMetaTyVars are allocated specially
+-- in guaranteed linear order, starting at zero for each module
+newMetaUnique 
+ = do { env <- getLclEnv
+      ; let meta_var = tcl_meta env
+      ; uniq <- readMutVar meta_var
+      ; writeMutVar meta_var (incrUnique uniq)
+      ; return uniq }
+
 newUnique :: TcRnIf gbl lcl Unique
 newUnique
  = do { env <- getEnv ;
-       let { u_var = env_us env } ;
-       us <- readMutVar u_var ;
-        case splitUniqSupply us of { (us1,_) -> do {
-       writeMutVar u_var us1 ;
-       return $! uniqFromSupply us }}}
+        let { u_var = env_us env } ;
+        us <- readMutVar u_var ;
+        case takeUniqFromSupply us of { (uniq, us') -> do {
+        writeMutVar u_var us' ;
+        return $! uniq }}}
    -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
    -- a chain of unevaluated supplies behind.
    -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
@@ -333,11 +342,11 @@ newUnique
 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
 newUniqueSupply
  = do { env <- getEnv ;
-       let { u_var = env_us env } ;
-       us <- readMutVar u_var ;
+        let { u_var = env_us env } ;
+        us <- readMutVar u_var ;
         case splitUniqSupply us of { (us1,us2) -> do {
-       writeMutVar u_var us1 ;
-       return us2 }}}
+        writeMutVar u_var us1 ;
+        return us2 }}}
 
 newLocalName :: Name -> TcRnIf gbl lcl Name
 newLocalName name      -- Make a clone
@@ -678,7 +687,7 @@ tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 -- for the thing is propagated only if there are no errors
 -- Hence it's restricted to the type-check monad
 tryTcLIE thing_inside
-  = do  { ((msgs, mb_res), lie) <- getConstraints (tryTcErrs thing_inside) ;
+  = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
        ; case mb_res of
            Nothing  -> return (msgs, Nothing)
            Just val -> do { emitConstraints lie; return (msgs, Just val) }
@@ -951,25 +960,27 @@ emitConstraint ct
   = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`extendWanteds` ct) }
 
-getConstraints :: TcM a -> TcM (a, WantedConstraints)
--- (getConstraints m) runs m, and returns the type constraints it generates
-getConstraints thing_inside
+captureConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureConstraints m) runs m, and returns the type constraints it generates
+captureConstraints thing_inside
   = do { lie_var <- newTcRef emptyWanteds ;
         res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
                          thing_inside ;
         lie <- readTcRef lie_var ;
         return (res, lie) }
 
-setUntouchables :: TcTyVarSet -> TcM a -> TcM a
-setUntouchables untch_tvs thing_inside
-  = updLclEnv (\ env -> env { tcl_untch = untch_tvs }) thing_inside 
-
-getUntouchables :: TcM TcTyVarSet 
-getUntouchables = do { env <- getLclEnv; return (tcl_untch env) } 
-   -- NB: no need to zonk this TcTyVarSet: they are, after all, untouchable!
+captureUntouchables :: TcM a -> TcM (a, Untouchables)
+captureUntouchables thing_inside
+  = do { env <- getLclEnv
+       ; low_meta <- readTcRef (tcl_meta env)
+       ; res <- setLclEnv (env { tcl_untch = low_meta }) 
+                thing_inside 
+       ; high_meta <- readTcRef (tcl_meta env)
+       ; return (res, TouchableRange low_meta high_meta) }
 
 isUntouchable :: TcTyVar -> TcM Bool
-isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) }
+isUntouchable tv = do { env <- getLclEnv
+                      ; return (varUnique tv < tcl_untch env) }
 
 getLclTypeEnv :: TcM (NameEnv TcTyThing)
 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }