X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=e6d75e3a6509740f84e327d0e4926cbaac9a4818;hp=f515334830c14985ea90c328563d64bc82c4d01f;hb=49c98d143c382a1341e1046f5ca00819a25691ba;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index f515334..e6d75e3 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1,3 +1,7 @@ +% +% (c) The University of Glasgow 2006 +% + \begin{code} module TcRnMonad( module TcRnMonad, @@ -11,53 +15,48 @@ import TcRnTypes -- Re-export all import IOEnv -- Re-export all #if defined(GHCI) && defined(BREAKPOINT) -import TypeRep ( Type(..), liftedTypeKind ) -import Var ( mkTyVar, mkGlobalId ) -import IdInfo ( GlobalIdDetails(..), vanillaIdInfo ) -import OccName ( mkOccName, tvName ) -import SrcLoc ( noSrcLoc ) -import TysWiredIn ( intTy, stringTy, mkListTy, unitTy, boolTy ) -import PrelNames ( breakpointJumpName, breakpointCondJumpName ) -import NameEnv ( mkNameEnv ) +import TypeRep +import Var +import IdInfo +import OccName +import SrcLoc +import TysWiredIn +import PrelNames +import NameEnv +import TcEnv #endif -import HsSyn ( emptyLHsBinds ) -import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, - ExternalPackageState(..), HomePackageTable, - Deprecs(..), FixityEnv, FixItem, - mkPrintUnqualified ) -import Module ( Module, moduleName ) -import RdrName ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, 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 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 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 UniqFM ( unitUFM ) -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 UniqFM +import Unique +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} @@ -100,9 +99,10 @@ initTc hsc_env hsc_src mod do_this 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_exports = [], tcg_imports = init_imports, tcg_dus = emptyDUs, tcg_rn_imports = Nothing, @@ -111,10 +111,13 @@ initTc hsc_env hsc_src mod do_this 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 } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -131,33 +134,8 @@ 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; - basicType extra = (FunTy intTy - (FunTy (mkListTy unitTy) - (FunTy stringTy - (ForAllTy tyvar - (extra - (FunTy (TyVarTy tyvar) - (TyVarTy tyvar))))))); - breakpointJumpType - = mkGlobalId VanillaGlobal breakpointJumpName - (basicType id) vanillaIdInfo; - breakpointCondJumpType - = mkGlobalId VanillaGlobal breakpointCondJumpName - (basicType (FunTy boolTy)) vanillaIdInfo; - new_env = mkNameEnv [(breakpointJumpName - , ATcId breakpointJumpType topLevel False) - ,(breakpointCondJumpName - , ATcId breakpointCondJumpType topLevel False)]; - }; - r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this) -#else - r <- tryM do_this -#endif + addBreakpointBindings $ + do { r <- tryM do_this ; case r of Right res -> return (Just res) Left _ -> return Nothing } ; @@ -172,8 +150,7 @@ initTc hsc_env hsc_src mod do_this return (msgs, final_res) } where - init_imports = emptyImportAvails {imp_env = - unitUFM (moduleName mod) emptyNameSet} + init_imports = emptyImportAvails {imp_env = unitUFM (moduleName mod) []} -- 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 @@ -190,6 +167,32 @@ initTcPrintErrors env mod todo = do return res \end{code} +\begin{code} +addBreakpointBindings :: TcM a -> TcM a +addBreakpointBindings thing_inside +#if defined(GHCI) && defined(BREAKPOINT) + = do { unique <- newUnique + ; let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc; + tyvar = mkTyVar var liftedTypeKind; + basicType extra = (FunTy intTy + (FunTy (mkListTy unitTy) + (FunTy stringTy + (ForAllTy tyvar + (extra + (FunTy (TyVarTy tyvar) + (TyVarTy tyvar))))))); + breakpointJumpId + = mkGlobalId VanillaGlobal breakpointJumpName + (basicType id) vanillaIdInfo; + breakpointCondJumpId + = mkGlobalId VanillaGlobal breakpointCondJumpName + (basicType (FunTy boolTy)) vanillaIdInfo + } + ; tcExtendIdEnv [breakpointJumpId, breakpointCondJumpId] thing_inside} +#else + = thing_inside +#endif +\end{code} %************************************************************************ %* * @@ -268,6 +271,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 () } @@ -323,22 +330,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) (getSrcLoc name)) } + +newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- newUniqueSupply + ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } \end{code}