X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=374c9ccb6f77b21ea932a173764375b88c4dc478;hb=1dfb756e01201c62ddde93010b3384d4d9644ad6;hp=86af49a59d4b2339fb31eff3c05baf786cea8999;hpb=f23d940ee5d97f4395bf4f4c87a5b4a6a30af9d8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 86af49a..374c9cc 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -10,30 +10,29 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all +import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, Dependencies(..), TypeEnv, emptyTypeEnv, + TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, ExternalPackageState(..), HomePackageTable, - ModDetails(..), HomeModInfo(..), - Deprecs(..), FixityEnv, FixItem, + Deprecs(..), FixityEnv, FixItem, GhciMode, lookupType, unQualInScope ) -import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv, emptyModuleEnv ) +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 ) +import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, - mkErrMsg, mkWarnMsg, printErrorsAndWarnings, + mkWarnMsg, printErrorsAndWarnings, mkLocMessage, mkLongErrMsg ) -import SrcLoc ( mkGeneralSrcSpan, SrcSpan, Located(..) ) +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 ) @@ -63,48 +62,54 @@ 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 ; 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_binds = emptyBag, + tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], tcg_fords = [], - tcg_keep = emptyNameSet + tcg_keep = keep_var } ; lcl_env = TcLclEnv { tcl_errs = errs_var, - tcl_loc = mkGeneralSrcSpan FSLIT("Top level of module"), + tcl_loc = mkGeneralSrcSpan FSLIT("Top level"), 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 + tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE + tcl_gadt = emptyVarEnv } ; } ; @@ -125,32 +130,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 @@ -254,24 +249,36 @@ getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } getEps :: TcRnIf gbl lcl ExternalPackageState getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } -setEps :: ExternalPackageState -> TcRnIf gbl lcl () -setEps eps = do { env <- getTopEnv; writeMutVar (hsc_EPS env) eps } +-- Updating the EPS. This should be an atomic operation. +-- Note the delicate 'seq' which forces the EPS before putting it in the +-- variable. Otherwise what happens is that we get +-- write eps_var (....(unsafeRead eps_var)....) +-- and if the .... is strict, that's obviously bottom. By forcing it beforehand +-- we make the unsafeRead happen before we update the variable. updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) -> TcRnIf gbl lcl a -updateEps upd_fn = do { eps_var <- getEpsVar +updateEps upd_fn = do { traceIf (text "updating EPS") + ; eps_var <- getEpsVar ; eps <- readMutVar eps_var ; let { (eps', val) = upd_fn eps } - ; writeMutVar eps_var eps' + ; seq eps' (writeMutVar eps_var eps') ; return val } updateEps_ :: (ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl () -updateEps_ upd_fn = do { eps_var <- getEpsVar - ; updMutVar eps_var upd_fn } +updateEps_ upd_fn = do { traceIf (text "updating EPS_") + ; eps_var <- getEpsVar + ; eps <- readMutVar eps_var + ; let { eps' = upd_fn eps } + ; seq eps' (writeMutVar eps_var eps') } getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } + +getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) +getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) + ; return (eps, hsc_HPT env) } \end{code} %************************************************************************ @@ -342,6 +349,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) } @@ -371,24 +381,26 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) } -addSrcSpan :: SrcSpan -> TcRn a -> TcRn a -addSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) +setSrcSpan :: SrcSpan -> TcRn a -> TcRn a +setSrcSpan loc thing_inside + | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside + | otherwise = thing_inside -- Don't overwrite useful info with useless addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = addSrcSpan loc $ fn a +addLocM fn (L loc a) = setSrcSpan loc $ fn a wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = addSrcSpan loc $ do b <- fn a; return (L loc b) +wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b) wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) wrapLocFstM fn (L loc a) = - addSrcSpan loc $ do + setSrcSpan loc $ do (b,c) <- fn a return (L loc b, c) wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c) wrapLocSndM fn (L loc a) = - addSrcSpan loc $ do + setSrcSpan loc $ do (b,c) <- fn a return (b, L loc c) \end{code} @@ -579,25 +591,31 @@ failIfErrsM = ifErrsM failM (return ()) %************************************************************************ \begin{code} -setErrCtxtM, addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a -setErrCtxtM msg = updCtxt (\ msgs -> [msg]) -addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) +getErrCtxt :: TcM ErrCtxt +getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } -setErrCtxt, addErrCtxt :: Message -> TcM a -> TcM a -setErrCtxt msg = setErrCtxtM (\env -> returnM (env, msg)) -addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) +setErrCtxt :: ErrCtxt -> TcM a -> TcM a +setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms }) +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a +addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) -getErrCtxt :: TcM ErrCtxt -getErrCtxt = do { env <- getLclEnv ; return (tcl_ctxt env) } +addErrCtxt :: Message -> TcM a -> TcM a +addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) -- Helper function for the above updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) +-- Conditionally add an error context +maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a +maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside +maybeAddErrCtxt Nothing thing_inside = thing_inside + +popErrCtxt :: TcM a -> TcM a +popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms }) + getInstLoc :: InstOrigin -> TcM InstLoc getInstLoc origin = do { loc <- getSrcSpanM ; env <- getLclEnv ; @@ -607,7 +625,7 @@ addInstCtxt :: InstLoc -> TcM a -> TcM a -- Add the SrcSpan and context from the first Inst in the list -- (they all have similar locations) addInstCtxt (InstLoc _ src_loc ctxt) thing_inside - = addSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) + = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) \end{code} The addErrTc functions add an error message, but do not cause failure. @@ -677,7 +695,18 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt | otherwise = take 3 ctxt \end{code} -%************************************************************************ +debugTc is useful for monadi debugging code + +\begin{code} +debugTc :: TcM () -> TcM () +#ifdef DEBUG +debugTc thing = thing +#else +debugTc thing = return () +#endif +\end{code} + + %************************************************************************ %* * Type constraints (the so-called LIE) %* * @@ -733,6 +762,17 @@ setLclTypeEnv lcl_env thing_inside %************************************************************************ \begin{code} +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) } @@ -754,7 +794,7 @@ popArrowBinders 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} + ArrCtxt {proc_level = curr_lvl + 1, proc_banned = curr_lvl : banned} getBannedProcLevels :: TcM [ProcLevel] = do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) } @@ -790,12 +830,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), - if_is_boot = imp_dep_mods (tcg_imports tcg_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 } @@ -803,12 +847,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_is_boot = imp_dep_mods (tcg_imports tcg_env) } - ; if_lenv = IfLclEnv { if_mod = moduleName mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + if_rec_types = Just (mod, return (tcg_type_env tcg_env)) } + ; if_lenv = mkIfLclEnv mod doc } ; setEnvs (if_env, if_lenv) thing_inside } @@ -816,9 +858,7 @@ 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_is_boot = emptyModuleEnv, - if_rec_types = Nothing } ; - } + = do { let gbl_env = IfGblEnv { if_rec_types = Nothing } ; initTcRnIf 'i' hsc_env gbl_env () do_this } @@ -828,42 +868,45 @@ initIfaceTc :: HscEnv -> ModIface -- 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 - ; let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)), - if_rec_types = Just (mod, readMutVar tc_env_var) } ; - ; if_lenv = IfLclEnv { if_mod = moduleName mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ; + ; if_lenv = mkIfLclEnv mod doc } ; initTcRnIf 'i' hsc_env 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 -- We have available the type envt of the module being compiled, and we must use it initIfaceRules hsc_env guts do_this = do { let { - is_boot = mkModDeps (dep_mods (mg_deps guts)) - -- Urgh! But we do somehow need to get the info - -- on whether (for this particular compilation) we should - -- import a hi-boot file or not. - ; type_info = (mg_module guts, return (mg_types guts)) - ; gbl_env = IfGblEnv { if_is_boot = is_boot, - if_rec_types = Just type_info } ; + type_info = (mg_module guts, return (mg_types guts)) + ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ; } -- Run the thing; any exceptions just bubble out from here ; 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) @@ -904,3 +947,17 @@ forkM doc thing_inside Nothing -> pprPanic "forkM" doc Just r -> r) } \end{code} + +%************************************************************************ +%* * + Stuff for GADTs +%* * +%************************************************************************ + +\begin{code} +getTypeRefinement :: TcM GadtRefinement +getTypeRefinement = do { lcl_env <- getLclEnv; return (tcl_gadt lcl_env) } + +setTypeRefinement :: GadtRefinement -> TcM a -> TcM a +setTypeRefinement gadt = updLclEnv (\env -> env { tcl_gadt = gadt }) +\end{code}