X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=92fa190642d30e3b884a1cdcc53b50e55700b2fa;hp=456bd7e45b4c2cdbfba46f83ed1cb4b2f09ea6f8;hb=61f93d4611724685c5808bcfd41e3d3e0f3aa94f;hpb=92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 456bd7e..92fa190 100644 --- 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) }