projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2003-02-21 12:28:35 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
e54725d
..
927f7e2
100644
(file)
--- a/
ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/
ghc/compiler/typecheck/TcRnMonad.lhs
@@
-14,7
+14,7
@@
import HscTypes ( HscEnv(..), PersistentCompilerState(..),
GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv,
GhciMode, lookupType, unQualInScope )
import TcRnTypes
GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv,
GhciMode, lookupType, unQualInScope )
import TcRnTypes
-import Module ( Module, moduleName, unitModuleEnv, foldModuleEnv )
+import Module ( Module, unitModuleEnv, foldModuleEnv )
import Name ( Name, isInternalName )
import Type ( Type )
import NameEnv ( extendNameEnvList )
import Name ( Name, isInternalName )
import Type ( Type )
import NameEnv ( extendNameEnvList )
@@
-116,7
+116,8
@@
initTc (HscEnv { hsc_mode = ghci_mode,
usg_var <- newIORef emptyUsages ;
nc_var <- newIORef (pcs_nc pcs) ;
eps_var <- newIORef eps ;
usg_var <- newIORef emptyUsages ;
nc_var <- newIORef (pcs_nc pcs) ;
eps_var <- newIORef eps ;
-
+ ie_var <- newIORef (mkImpInstEnv dflags eps hpt) ;
+
let {
env = Env { env_top = top_env,
env_gbl = gbl_env,
let {
env = Env { env_top = top_env,
env_gbl = gbl_env,
@@
-139,8
+140,7
@@
initTc (HscEnv { hsc_mode = ghci_mode,
tcg_fix_env = emptyFixityEnv,
tcg_default = defaultDefaultTys,
tcg_type_env = emptyNameEnv,
tcg_fix_env = emptyFixityEnv,
tcg_default = defaultDefaultTys,
tcg_type_env = emptyNameEnv,
- tcg_ist = mkImpTypeEnv eps hpt,
- tcg_inst_env = mkImpInstEnv dflags eps hpt,
+ tcg_inst_env = ie_var,
tcg_exports = [],
tcg_imports = init_imports,
tcg_binds = EmptyMonoBinds,
tcg_exports = [],
tcg_imports = init_imports,
tcg_binds = EmptyMonoBinds,
@@
-189,6
+189,12
@@
defaultDefaultTys :: [Type]
defaultDefaultTys = [integerTy, doubleTy]
mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv
defaultDefaultTys = [integerTy, doubleTy]
mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv
+-- At the moment we (wrongly) build an instance environment from all the
+-- modules we have already compiled:
+-- (a) eps_inst_env from the external package state
+-- (b) all the md_insts in the home package table
+-- We should really only get instances from modules below us in the
+-- module import tree.
mkImpInstEnv dflags eps hpt
= foldModuleEnv (add . md_insts . hm_details)
(eps_inst_env eps)
mkImpInstEnv dflags eps hpt
= foldModuleEnv (add . md_insts . hm_details)
(eps_inst_env eps)
@@
-240,6
+246,12
@@
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
setLclEnv :: m -> TcRn m a -> TcRn n a
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
setLclEnv :: m -> TcRn m a -> TcRn n a
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+
+getEnvs :: TcRn m (TcGblEnv, m)
+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
+
+setEnvs :: (TcGblEnv, m) -> TcRn m a -> TcRn m a
+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
\end{code}
Command-line flags
\end{code}
Command-line flags
@@
-470,6
+482,7
@@
forkM :: SDoc -> TcM a -> TcM (Maybe a)
-- Run thing_inside in an interleaved thread. It gets a separate
-- * errs_var, and
-- * unique supply,
-- Run thing_inside in an interleaved thread. It gets a separate
-- * errs_var, and
-- * unique supply,
+-- * LIE var is set to bottom (should never be used)
-- but everything else is shared, so this is DANGEROUS.
--
-- It returns Nothing if the computation fails
-- but everything else is shared, so this is DANGEROUS.
--
-- It returns Nothing if the computation fails
@@
-481,7
+494,8
@@
forkM doc thing_inside
= do { us <- newUniqueSupply ;
unsafeInterleaveM $
do { us_var <- newMutVar us ;
= do { us <- newUniqueSupply ;
unsafeInterleaveM $
do { us_var <- newMutVar us ;
- (msgs, mb_res) <- tryTcLIE (setUsVar us_var thing_inside) ;
+ (msgs, mb_res) <- tryTc (setLIEVar (panic "forkM: LIE used") $
+ setUsVar us_var thing_inside) ;
case mb_res of
Just r -> return (Just r)
Nothing -> do {
case mb_res of
Just r -> return (Just r)
Nothing -> do {