X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=f118f47ab523785dca713f1e3f78457a5da264e9;hp=4fa3d8de680e955952f582a5e2881df0d4c1a67d;hb=3f1b316d7035c55cd712cd39a9981339bcef2e8c;hpb=2c1ea2cedb1a8034b0828e24b554a35f56bb8924 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 4fa3d8d..f118f47 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1,4 +1,15 @@ +% +% (c) The University of Glasgow 2006 +% + \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcRnMonad( module TcRnMonad, module TcRnTypes, @@ -10,56 +21,38 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all -#if defined(GHCI) && defined(BREAKPOINT) -import TypeRep ( Type(..), liftedTypeKind, TyThing(..) ) -import Var ( mkTyVar, mkGlobalId ) -import IdInfo ( GlobalIdDetails(..), vanillaIdInfo ) -import OccName ( mkOccName, tvName ) -import SrcLoc ( noSrcLoc ) -import TysWiredIn ( intTy, stringTy, mkListTy, unitTy ) -import PrelNames ( breakpointJumpName ) -import NameEnv ( mkNameEnv ) -#endif - -import HsSyn ( emptyLHsBinds ) -import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, TypeEnv, emptyTypeEnv, HscSource(..), - isHsBoot, ModSummary(..), - ExternalPackageState(..), HomePackageTable, - Deprecs(..), FixityEnv, FixItem, - lookupType, unQualInScope ) -import Module ( Module, unitModuleEnv ) -import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, - LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc ) -import Type ( Type ) -import TcType ( tcIsTyVarTy, tcGetTyVar ) -import NameEnv ( extendNameEnvList, nameEnvElts ) -import InstEnv ( emptyInstEnv ) - -import Var ( setTyVarName ) -import VarSet ( emptyVarSet ) -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 ) -import OccName ( emptyOccEnv, tidyOccName ) -import Bag ( emptyBag ) +import HsSyn hiding (LIE) +import HscTypes +import Module +import RdrName +import Name +import TcType +import InstEnv +import FamInstEnv + +import Coercion +import Var +import Id +import VarSet +import VarEnv +import ErrUtils +import SrcLoc +import NameEnv +import NameSet +import OccName +import Bag import Outputable -import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) -import Unique ( Unique ) -import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode ) -import StaticFlags ( opt_PprStyle_Debug ) -import Bag ( snocBag, unionBags ) -import Panic ( showException ) +import UniqSupply +import Unique +import UniqFM +import DynFlags +import StaticFlags +import FastString +import Panic -import IO ( stderr ) -import DATA_IOREF ( newIORef, readIORef ) -import EXCEPTION ( Exception ) +import System.IO +import Data.IORef +import Control.Exception \end{code} @@ -76,15 +69,17 @@ ioToTcRn = ioToIOEnv \end{code} \begin{code} + initTc :: HscEnv -> HscSource + -> Bool -- True <=> retain renamed syntax trees -> Module -> TcM r -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) -initTc hsc_env hsc_src mod do_this +initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; tvs_var <- newIORef emptyVarSet ; type_env_var <- newIORef emptyNameEnv ; @@ -93,31 +88,42 @@ initTc hsc_env hsc_src mod do_this th_var <- newIORef False ; dfun_n_var <- newIORef 1 ; let { + maybe_rn_syntax empty_val + | keep_rn_syntax = Just empty_val + | otherwise = Nothing ; + gbl_env = TcGblEnv { - tcg_mod = mod, - tcg_src = hsc_src, - tcg_rdr_env = hsc_global_rdr_env hsc_env, - tcg_fix_env = emptyNameEnv, - tcg_default = Nothing, - tcg_type_env = hsc_global_type_env hsc_env, + tcg_mod = mod, + tcg_src = hsc_src, + tcg_rdr_env = hsc_global_rdr_env hsc_env, + tcg_fix_env = emptyNameEnv, + tcg_field_env = emptyNameEnv, + tcg_default = Nothing, + tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, tcg_inst_uses = dfuns_var, tcg_th_used = th_var, - tcg_exports = emptyNameSet, - tcg_imports = init_imports, - tcg_home_mods = home_mods, + tcg_exports = [], + tcg_imports = emptyImportAvails, tcg_dus = emptyDUs, - tcg_rn_imports = Nothing, - tcg_rn_exports = Nothing, - tcg_rn_decls = Nothing, + + tcg_rn_imports = maybe_rn_syntax [], + tcg_rn_exports = maybe_rn_syntax [], + tcg_rn_decls = maybe_rn_syntax emptyRnGroup, + tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], + tcg_fam_insts= [], tcg_rules = [], tcg_fords = [], tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var + tcg_keep = keep_var, + tcg_doc = Nothing, + tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing, + tcg_hpc = False } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -134,27 +140,7 @@ initTc hsc_env hsc_src mod do_this -- OK, here's the business end! maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - do { -#if defined(GHCI) && defined(BREAKPOINT) - unique <- newUnique ; - let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc; - tyvar = mkTyVar var liftedTypeKind; - breakpointJumpType = mkGlobalId - (VanillaGlobal) - (breakpointJumpName) - (FunTy intTy - (FunTy (mkListTy unitTy) - (FunTy stringTy - (ForAllTy tyvar - (FunTy (TyVarTy tyvar) - (TyVarTy tyvar)))))) - (vanillaIdInfo); - new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))]; - }; - r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this) -#else - r <- tryM do_this -#endif + do { r <- tryM do_this ; case r of Right res -> return (Just res) Left _ -> return Nothing } ; @@ -168,22 +154,6 @@ 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} - -- 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 -- Used from the interactive loop only :: HscEnv @@ -191,21 +161,11 @@ initTcPrintErrors -- Used from the interactive loop only -> TcM r -> IO (Maybe r) initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env HsSrcFile mod todo + (msgs, res) <- initTc env HsSrcFile False 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} - %************************************************************************ %* * Initialisation @@ -226,7 +186,7 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside ; let { env = Env { env_top = hsc_env, env_us = us_var, env_gbl = gbl_env, - env_lcl = lcl_env } } + env_lcl = lcl_env} } ; runIOEnv env thing_inside } @@ -283,6 +243,10 @@ setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} ) +unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) + ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } @@ -338,22 +302,38 @@ 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 - = newUnique `thenM` \ uniq -> - returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name)) + = do { uniq <- newUnique + ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) } + +newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- newUniqueSupply + ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } \end{code} @@ -390,7 +370,8 @@ traceOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } + dflags <- getDOpts ; + ioToTcRn (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } dumpOptTcRn :: DynFlag -> SDoc -> TcRn () dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) @@ -427,8 +408,16 @@ extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) -getDefaultTys :: TcRn (Maybe [Type]) -getDefaultTys = do { env <- getGblEnv; return (tcg_default env) } +getRecFieldEnv :: TcRn RecFieldEnv +getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } + +extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a +extendRecFieldEnv new_bit + = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) -> + env {tcg_field_env = old_env `plusNameEnv` new_bit}) + +getDeclaredDefaultTys :: TcRn (Maybe [Type]) +getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} %************************************************************************ @@ -488,7 +477,8 @@ 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 } ; + dflags <- getDOpts ; + let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } @@ -504,7 +494,8 @@ addReportAt :: SrcSpan -> Message -> TcRn () addReportAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ; + dflags <- getDOpts ; + let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } @@ -749,11 +740,14 @@ checkTc False err = failWithTc err \begin{code} addWarnTc :: Message -> TcM () -addWarnTc msg +addWarnTc msg = do { env0 <- tcInitTidyEnv + ; addWarnTcM (env0, msg) } + +addWarnTcM :: (TidyEnv, Message) -> TcM () +addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; - env0 <- tcInitTidyEnv ; ctxt_msgs <- do_ctxt env0 ctxt ; - addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) } + addReport (vcat (ptext SLIT("Warning:") <+> msg : ctxt_to_use ctxt_msgs)) } warnTc :: Bool -> Message -> TcM () warnTc warn_if_true warn_msg @@ -881,9 +875,11 @@ 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) } +keepAliveTc :: Id -> TcM () -- Record the name in the keep-alive set +keepAliveTc id + | isLocalId id = do { env <- getGblEnv; + ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) } + | otherwise = return () keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set keepAliveSetTc ns = do { env <- getGblEnv; @@ -923,8 +919,8 @@ setLocalRdrEnv rdr_env thing_inside mkIfLclEnv :: Module -> SDoc -> IfLclEnv mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, if_loc = loc, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + if_tv_env = emptyUFM, + if_id_env = emptyUFM } initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside @@ -1011,8 +1007,10 @@ forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) 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 { @@ -1038,5 +1036,3 @@ forkM doc thing_inside -- pprPanic "forkM" doc Just r -> r) } \end{code} - -