X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=41e1133a605f6881baab7b4f0713eebeefcfed0c;hb=dd313897eb9a14bcc7b81f97e4f2292c30039efd;hp=a2db330dc168dab17ec070773df6e042a0f2fad5;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index a2db330..41e1133 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -1,4 +1,4 @@ - \begin{code} +\begin{code} module TcRnMonad( module TcRnMonad, module TcRnTypes, @@ -12,18 +12,17 @@ import IOEnv -- Re-export all import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, TypeEnv, emptyTypeEnv, + TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, ExternalPackageState(..), HomePackageTable, - ModDetails(..), HomeModInfo(..), - Deprecs(..), FixityEnv, FixItem, - GhciMode, lookupType, unQualInScope ) -import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv ) + Deprecs(..), FixityEnv, FixItem, + lookupType, unQualInScope ) +import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) import Name ( Name, isInternalName ) import Type ( Type ) import NameEnv ( extendNameEnvList ) -import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv ) +import InstEnv ( emptyInstEnv ) import VarSet ( emptyVarSet ) import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv ) @@ -32,14 +31,14 @@ import ErrUtils ( Message, Messages, emptyMessages, errorsFound, mkLocMessage, mkLongErrMsg ) import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) -import NameSet ( emptyDUs, emptyNameSet ) +import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) import OccName ( emptyOccEnv ) -import Module ( moduleName ) import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) import Unique ( Unique ) -import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug, dopt_set ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode ) +import StaticFlags ( opt_PprStyle_Debug ) import Bag ( snocBag, unionBags ) import Panic ( showException ) @@ -64,39 +63,45 @@ ioToTcRn = ioToIOEnv \begin{code} initTc :: HscEnv + -> HscSource -> Module -> TcM r -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) -initTc hsc_env mod do_this +initTc hsc_env hsc_src mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; tvs_var <- newIORef emptyVarSet ; type_env_var <- newIORef emptyNameEnv ; dfuns_var <- newIORef emptyNameSet ; + keep_var <- newIORef emptyNameSet ; th_var <- newIORef False ; + dfun_n_var <- newIORef 1 ; let { gbl_env = TcGblEnv { tcg_mod = mod, + tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, tcg_default = Nothing, tcg_type_env = emptyNameEnv, tcg_type_env_var = type_env_var, - tcg_inst_env = mkImpInstEnv hsc_env, + tcg_inst_env = emptyInstEnv, tcg_inst_uses = dfuns_var, tcg_th_used = th_var, tcg_exports = emptyNameSet, tcg_imports = init_imports, tcg_dus = emptyDUs, + tcg_rn_decls = Nothing, tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], tcg_fords = [], - tcg_keep = emptyNameSet + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -104,7 +109,6 @@ initTc hsc_env mod do_this tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, - tcl_arrow_ctxt = topArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE @@ -129,32 +133,22 @@ initTc hsc_env mod do_this return (msgs, final_res) } where - init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv } + init_imports = emptyImportAvails { imp_env = unitModuleEnv 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 -- "unknown module M". -initTcPrintErrors +initTcPrintErrors -- Used from the interactive loop only :: HscEnv -> Module -> TcM r -> IO (Maybe r) initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env mod todo + (msgs, res) <- initTc env HsSrcFile mod todo printErrorsAndWarnings msgs return res -mkImpInstEnv :: HscEnv -> InstEnv --- At the moment we (wrongly) build an instance environment from all the --- home-package modules we have already compiled. --- We should really only get instances from modules below us in the --- module import tree. -mkImpInstEnv (HscEnv {hsc_dflags = dflags, hsc_HPT = hpt}) - = foldModuleEnv (add . md_insts . hm_details) emptyInstEnv hpt - where - add dfuns inst_env = foldl extendInstEnv inst_env dfuns - -- mkImpTypeEnv makes the imported symbol table mkImpTypeEnv :: ExternalPackageState -> HomePackageTable -> Name -> Maybe TyThing @@ -247,8 +241,8 @@ ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is tru ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } -getGhciMode :: TcRnIf gbl lcl GhciMode -getGhciMode = do { env <- getTopEnv; return (hsc_mode env) } +getGhciMode :: TcRnIf gbl lcl GhcMode +getGhciMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } \end{code} \begin{code} @@ -358,6 +352,9 @@ dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; getModule :: TcRn Module getModule = do { env <- getGblEnv; return (tcg_mod env) } +tcIsHsBoot :: TcRn Bool +tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } + getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } @@ -719,6 +716,13 @@ debugTc thing = return () %************************************************************************ \begin{code} +nextDFunIndex :: TcM Int -- Get the next dfun index +nextDFunIndex = do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; n <- readMutVar dfun_n_var + ; writeMutVar dfun_n_var (n+1) + ; return n } + getLIEVar :: TcM (TcRef LIE) getLIEVar = do { env <- getLclEnv; return (tcl_lie env) } @@ -771,6 +775,14 @@ setLclTypeEnv lcl_env thing_inside recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True } +keepAliveTc :: Name -> TcM () -- Record the name in the keep-alive set +keepAliveTc n = do { env <- getGblEnv; + ; updMutVar (tcg_keep env) (`addOneToNameSet` n) } + +keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set +keepAliveSetTc ns = do { env <- getGblEnv; + ; updMutVar (tcg_keep env) (`unionNameSets` ns) } + getStage :: TcM ThStage getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } @@ -781,32 +793,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) %************************************************************************ %* * - Arrow context -%* * -%************************************************************************ - -\begin{code} -popArrowBinders :: TcM a -> TcM a -- Move to the left of a (-<); see comments in TcRnTypes -popArrowBinders - = updLclEnv (\ env -> env { tcl_arrow_ctxt = pop (tcl_arrow_ctxt env) }) - where - pop (ArrCtxt {proc_level = curr_lvl, proc_banned = banned}) - = ASSERT( not (curr_lvl `elem` banned) ) - ArrCtxt {proc_level = curr_lvl, proc_banned = curr_lvl : banned} - -getBannedProcLevels :: TcM [ProcLevel] - = do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) } - -incProcLevel :: TcM a -> TcM a -incProcLevel - = updLclEnv (\ env -> env { tcl_arrow_ctxt = inc (tcl_arrow_ctxt env) }) - where - inc ctxt = ctxt { proc_level = proc_level ctxt + 1 } -\end{code} - - -%************************************************************************ -%* * Stuff for the renamer's local env %* * %************************************************************************ @@ -828,11 +814,16 @@ setLocalRdrEnv rdr_env thing_inside %************************************************************************ \begin{code} +mkIfLclEnv :: Module -> SDoc -> IfLclEnv +mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, + if_loc = loc, + if_tv_env = emptyOccEnv, + if_id_env = emptyOccEnv } + initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv - ; let { if_env = IfGblEnv { - if_rec_types = Just (tcg_mod tcg_env, get_type_env) } + ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) } ; get_type_env = readMutVar (tcg_type_env_var tcg_env) } ; setEnvs (if_env, ()) thing_inside } @@ -840,11 +831,10 @@ initIfaceExtCore :: IfL a -> TcRn a initIfaceExtCore thing_inside = do { tcg_env <- getGblEnv ; let { mod = tcg_mod tcg_env + ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod) ; if_env = IfGblEnv { if_rec_types = Just (mod, return (tcg_type_env tcg_env)) } - ; if_lenv = IfLclEnv { if_mod = moduleName mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + ; if_lenv = mkIfLclEnv mod doc } ; setEnvs (if_env, if_lenv) thing_inside } @@ -852,26 +842,24 @@ initIfaceCheck :: HscEnv -> IfG a -> IO a -- Used when checking the up-to-date-ness of the old Iface -- Initialise the environment with no useful info at all initIfaceCheck hsc_env do_this - = do { let { gbl_env = IfGblEnv { if_rec_types = Nothing } ; - } + = do { let gbl_env = IfGblEnv { if_rec_types = Nothing } ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceTc :: HscEnv -> ModIface - -> (TcRef TypeEnv -> IfL a) -> IO a +initIfaceTc :: ModIface + -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a -- Used when type-checking checking an up-to-date interface file -- No type envt from the current module, but we do know the module dependencies -initIfaceTc hsc_env iface do_this - = do { tc_env_var <- newIORef emptyTypeEnv +initIfaceTc iface do_this + = do { tc_env_var <- newMutVar emptyTypeEnv ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ; - ; if_lenv = IfLclEnv { if_mod = moduleName mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + ; if_lenv = mkIfLclEnv mod doc } - ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var) + ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var) } where mod = mi_module iface + doc = ptext SLIT("The interface for") <+> quotes (ppr mod) initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a -- Used when sucking in new Rules in SimplCore @@ -886,13 +874,23 @@ initIfaceRules hsc_env guts do_this ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceLcl :: ModuleName -> IfL a -> IfM lcl a -initIfaceLcl mod thing_inside - = setLclEnv (IfLclEnv { if_mod = mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv }) - thing_inside +initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a +initIfaceLcl mod loc_doc thing_inside + = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside + +getIfModule :: IfL Module +getIfModule = do { env <- getLclEnv; return (if_mod env) } +-------------------- +failIfM :: Message -> IfL a +-- The Iface monad doesn't have a place to accumulate errors, so we +-- just fall over fast if one happens; it "shouldnt happen". +-- We use IfL here so that we can get context info out of the local env +failIfM msg + = do { env <- getLclEnv + ; let full_msg = if_loc env $$ nest 2 msg + ; ioToIOEnv (printErrs (full_msg defaultErrStyle)) + ; failM } -------------------- forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)