X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=1fa44ca308ec26c2aa184d8bebdad2486c5b3a3c;hb=7a59afcebe45ea87c42006873f77eb4600d7316f;hp=ee3c6c6bf017b431f5f0bde7cb9f592848751e49;hpb=b1a8c262a046812d70371b1caaea21ffe039ced6;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ee3c6c6..1fa44ca 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -11,7 +11,7 @@ import TcRnTypes -- Re-export all import IOEnv -- Re-export all #if defined(GHCI) && defined(BREAKPOINT) -import TypeRep ( Type(..), liftedTypeKind, TyThing(..) ) +import TypeRep ( Type(..), liftedTypeKind ) import Var ( mkTyVar, mkGlobalId ) import IdInfo ( GlobalIdDetails(..), vanillaIdInfo ) import OccName ( mkOccName, tvName ) @@ -23,14 +23,13 @@ import NameEnv ( mkNameEnv ) import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, TypeEnv, emptyTypeEnv, HscSource(..), - isHsBoot, ModSummary(..), + TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, ExternalPackageState(..), HomePackageTable, Deprecs(..), FixityEnv, FixItem, - lookupType, unQualInScope ) -import Module ( Module, unitModuleEnv ) + mkPrintUnqualified ) +import Module ( Module, moduleName ) import RdrName ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc ) +import Name ( Name, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc ) import Type ( Type ) import TcType ( tcIsTyVarTy, tcGetTyVar ) import NameEnv ( extendNameEnvList, nameEnvElts ) @@ -42,7 +41,6 @@ import VarEnv ( TidyEnv, emptyTidyEnv, extendVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, mkWarnMsg, printErrorsAndWarnings, mkLocMessage, mkLongErrMsg ) -import Packages ( mkHomeModules ) import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) @@ -50,6 +48,7 @@ import OccName ( emptyOccEnv, tidyOccName ) import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) +import UniqFM ( unitUFM ) import Unique ( Unique ) import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode ) import StaticFlags ( opt_PprStyle_Debug ) @@ -105,7 +104,6 @@ initTc hsc_env hsc_src mod do_this tcg_th_used = th_var, tcg_exports = emptyNameSet, tcg_imports = init_imports, - tcg_home_mods = home_mods, tcg_dus = emptyDUs, tcg_rn_imports = Nothing, tcg_rn_exports = Nothing, @@ -174,17 +172,8 @@ initTc hsc_env hsc_src mod do_this return (msgs, final_res) } where - home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env)) - -- A guess at the home modules. This will be correct in - -- --make and GHCi modes, but in one-shot mode we need to - -- fix it up after we know the real dependencies of the current - -- module (see tcRnModule). - -- Setting it here is necessary for the typechecker entry points - -- other than tcRnModule: tcRnGetInfo, for example. These are - -- all called via the GHC module, so hsc_mod_graph will contain - -- something sensible. - - init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet} + init_imports = emptyImportAvails {imp_env = + unitUFM (moduleName 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 @@ -199,15 +188,6 @@ initTcPrintErrors env mod todo = do (msgs, res) <- initTc env HsSrcFile mod todo printErrorsAndWarnings (hsc_dflags env) msgs return res - --- mkImpTypeEnv makes the imported symbol table -mkImpTypeEnv :: ExternalPackageState -> HomePackageTable - -> Name -> Maybe TyThing -mkImpTypeEnv pcs hpt = lookup - where - pte = eps_PTE pcs - lookup name | isInternalName name = Nothing - | otherwise = lookupType hpt pte name \end{code} @@ -343,17 +323,28 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) \begin{code} newUnique :: TcRnIf gbl lcl Unique -newUnique = do { us <- newUniqueSupply ; - return (uniqFromSupply us) } +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 }}} + -- 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 + -- throw away one half of the new split supply. This is safe because this + -- is the only place we use that unique. Using the other half of the split + -- supply is safer, but slower. newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply = do { env <- getEnv ; let { u_var = env_us env } ; us <- readMutVar u_var ; - let { (us1, us2) = splitUniqSupply us } ; + case splitUniqSupply us of { (us1,us2) -> do { writeMutVar u_var us1 ; - return us2 } + return us2 }}} newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone @@ -395,7 +386,7 @@ traceOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } + ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) } dumpOptTcRn :: DynFlag -> SDoc -> TcRn () dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) @@ -493,7 +484,7 @@ addLongErrAt loc msg extra = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ; + let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } @@ -509,7 +500,7 @@ addReportAt :: SrcSpan -> Message -> TcRn () addReportAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ; + let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) }