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 )
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 )
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 )
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 )
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,
= mkGlobalId VanillaGlobal breakpointCondJumpName
(basicType (FunTy boolTy)) vanillaIdInfo;
new_env = mkNameEnv [(breakpointJumpName
- , AGlobal (AnId breakpointJumpType))
- ,(breakpointCondJumpName
- , AGlobal (AnId breakpointCondJumpType))];
+ , ATcId breakpointJumpType topLevel False)
+ ,(breakpointCondJumpName
+ , ATcId breakpointCondJumpType topLevel False)];
};
r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
#else
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
(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}
\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
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)
= 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) }
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) }
forkM_maybe doc thing_inside
= do { unsafeInterleaveM $
do { traceIf (text "Starting fork {" <+> doc)
- ; mb_res <- tryM thing_inside ;
- case mb_res of
+ ; mb_res <- tryM $
+ updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
+ thing_inside
+ ; case mb_res of
Right r -> do { traceIf (text "} ending fork" <+> doc)
; return (Just r) }
Left exn -> do {