X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnTypes.lhs;h=f61115a208aea011f86935ce188b063f9a3f9b7f;hb=8a86866e9e382c1d4d06cad722ddbe965d09997c;hp=beff457041fed8807e253a0fce27ab0a6465c233;hpb=0abcbf0f5afda9cc067ddcf2c28b463d59d24a1e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index beff457..f61115a 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -11,7 +11,7 @@ module TcRnTypes( -- Non-standard operations runTcRn, fixM, tryM, ioToTcRn, newMutVar, readMutVar, writeMutVar, - getEnv, setEnv, updEnv, unsafeInterleaveM, + getEnv, setEnv, updEnv, unsafeInterleaveM, zapEnv, -- The environment types Env(..), TopEnv(..), TcGblEnv(..), @@ -23,7 +23,7 @@ module TcRnTypes( ImportAvails(..), emptyImportAvails, plusImportAvails, plusAvail, pruneAvails, AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv, - mkAvailEnv, lookupAvailEnv, availEnvElts, addAvail, + mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail, WhereFrom(..), -- Typechecker types @@ -34,7 +34,7 @@ module TcRnTypes( Level, impLevel, topLevel, -- Insts - Inst(..), InstOrigin(..), InstLoc, pprInstLoc, + Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc, LIE, emptyLIE, unitLIE, plusLIE, consLIE, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, @@ -46,13 +46,14 @@ module TcRnTypes( import HsSyn ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl ) import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo ) -import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, NameCache, - GlobalRdrEnv, LocalRdrEnv, FixityEnv, TypeEnv, TyThing, - Avails, GenAvailInfo(..), AvailInfo, availName, - IsBootInterface, Deprecations, WhetherHasOrphans ) +import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, + NameCache, GlobalRdrEnv, LocalRdrEnv, FixityEnv, + TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo, + availName, IsBootInterface, Deprecations, + ExternalPackageState(..), emptyExternalPackageState ) import Packages ( PackageName ) -import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind, - tcCmpPred, tcCmpType, tcCmpTypes ) +import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, + TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) import InstEnv ( DFunId, InstEnv ) import Name ( Name ) import NameEnv @@ -74,10 +75,11 @@ import Outputable import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) import UNSAFE_IO ( unsafeInterleaveIO ) import FIX_IO ( fixIO ) -import EXCEPTION ( Exception ) +import EXCEPTION ( Exception(..) ) +import IO ( isUserError ) import Maybe ( mapMaybe ) -import List ( nub ) -import Panic ( tryMost ) +import ListSetOps ( unionLists ) +import Panic ( tryJust ) \end{code} @@ -157,7 +159,15 @@ Error recovery \begin{code} tryM :: TcRn m r -> TcRn m (Either Exception r) -- Reflect exception into TcRn monad -tryM (TcRn thing) = TcRn (\ env -> tryMost (thing env)) +tryM (TcRn thing) = TcRn (\ env -> tryJust tc_errors (thing env)) + where +#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500 + tc_errors e@(IOException ioe) | isUserError ioe = Just e +#else + tc_errors e | isUserError e = Just e +#endif + tc_errors _other = Nothing + -- type checker failures show up as UserErrors only \end{code} Lazy interleave @@ -201,6 +211,47 @@ updEnv :: (Env m -> Env n) -> TcRn n a -> TcRn m a updEnv upd (TcRn m) = TcRn (\ env -> m (upd env)) \end{code} +\begin{code} +zapEnv :: TcRn m a -> TcRn m a +zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } -> + case top of { + TopEnv{ + top_mode = mode, + top_dflags = dflags, + top_hpt = hpt, + top_eps = eps, + top_us = us + } -> do + + eps_snap <- readIORef eps + ref <- newIORef $! emptyExternalPackageState{ eps_PTE = eps_PTE eps_snap } + + let + top' = TopEnv { + top_mode = mode, + top_dflags = dflags, + top_hpt = hpt, + top_eps = ref, + top_us = us + } + + type_env = tcg_type_env gbl + mod = tcg_mod gbl + gbl' = TcGblEnv { + tcg_mod = mod, + tcg_type_env = type_env + } + + env' = Env { + env_top = top', + env_gbl = gbl', + env_lcl = lcl + -- leave the rest empty + } + + case act of { TcRn f -> f env' } + } +\end{code} %************************************************************************ %* * @@ -235,6 +286,7 @@ data TopEnv -- Built once at top level then does not change -- PIT, ImportedModuleInfo -- DeclsMap, IfaceRules, IfaceInsts, InstGates -- TypeEnv, InstEnv, RuleBase + -- Mutable, because we demand-load declarations that extend the state top_hpt :: HomePackageTable, -- The home package table that we've accumulated while @@ -273,15 +325,20 @@ data TcGblEnv -- (Ids defined in this module start in the local envt, -- though they move to the global envt during zonking) - -- Cached things - tcg_ist :: Name -> Maybe TyThing, -- Imported symbol table - -- Global type env: a combination of tcg_eps, tcg_hpt - -- (but *not* tcg_type_env; no deep reason) - -- When the PCS changes this must be refreshed, - -- notably after running some compile-time code - - tcg_inst_env :: InstEnv, -- Global instance env: a combination of + tcg_inst_env :: TcRef InstEnv, -- Global instance env: a combination of -- tc_pcs, tc_hpt, *and* tc_insts + -- This field is mutable so that it can be updated inside a + -- Template Haskell splice, which might suck in some new + -- instance declarations. This is a slightly different strategy + -- than for the type envt, where we look up first in tcg_type_env + -- and then in the mutable EPS, because the InstEnv for this module + -- is constructed (in principle at least) only from the modules + -- 'below' this one, so it's this-module-specific + -- + -- On the other hand, a declaration quote [d| ... |] may introduce + -- some new instance declarations that we *don't* want to persist + -- outside the quote, so we tiresomely need to revert the InstEnv + -- after finishing the quote (see TcSplice.tcBracket) -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. @@ -291,7 +348,10 @@ data TcGblEnv tcg_imports :: ImportAvails, -- Information about what was imported -- from where, including things bound -- in this module - -- The next fields are always fully zonked + + -- The next fields accumulate the payload of the module + -- The binds, rules and foreign-decl fiels are collected + -- initially in un-zonked form and are finally zonked in tcRnSrcDecls tcg_binds :: MonoBinds Id, -- Value bindings in this module tcg_deprecs :: Deprecations, -- ...Deprecations tcg_insts :: [DFunId], -- ...Instances @@ -355,7 +415,7 @@ topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level spli impLevel, topLevel :: Level -topLevel = 1 -- Things dedined at top level of this module +topLevel = 1 -- Things defined at top level of this module impLevel = 0 -- Imported things; they can be used inside a top level splice -- -- For example: @@ -374,6 +434,12 @@ data TcTyThing -- 2. Then we kind-check the (T a Int) part. -- 3. Then we zonk the kind variable. -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment + +instance Outputable TcTyThing where -- Debugging only + ppr (AGlobal g) = text "AGlobal" <+> ppr g + ppr (ATcId g l) = text "ATcId" <+> ppr g <+> ppr l + ppr (ATyVar t) = text "ATyVar" <+> ppr t + ppr (AThing k) = text "AThing" <+> ppr k \end{code} \begin{code} @@ -449,10 +515,11 @@ emptyUsages = emptyNameSet ImportAvails summarises what was imported from where, irrespective of whether the imported htings are actually used or not -It is used * when porcessing the export list +It is used * when processing the export list * when constructing usage info for the inteface file * to identify the list of directly imported modules for initialisation purposes + * when figuring out what things are really unused \begin{code} data ImportAvails @@ -463,10 +530,18 @@ data ImportAvails -- i.e. *excluding* class ops and constructors -- (which appear inside their parent AvailTC) - imp_unqual :: ModuleEnv AvailEnv, + imp_qual :: ModuleEnv AvailEnv, -- Used to figure out "module M" export specifiers - -- Domain is only modules with *unqualified* imports - -- (see 1.4 Report Section 5.1.1) + -- (see 1.4 Report Section 5.1.1). Ultimately, we want to find + -- everything that is unambiguously in scope as 'M.x' + -- and where plain 'x' is (perhaps ambiguously) in scope. + -- So the starting point is all things that are in scope as 'M.x', + -- which is what this field tells us. + -- + -- Domain is the *module qualifier* for imports. + -- e.g. import List as Foo + -- would add a binding Foo |-> ...stuff from List... + -- to imp_qual. -- We keep the stuff as an AvailEnv so that it's easy to -- combine stuff coming from different (unqualified) -- imports of the same module @@ -483,11 +558,8 @@ data ImportAvails -- need to recompile if the module version changes -- (b) to specify what child modules to initialise - dep_mods :: ModuleEnv (ModuleName, WhetherHasOrphans, IsBootInterface), - -- For a given import or set of imports, - -- there's an entry here for - -- (a) modules below the one being compiled, in the current package - -- (b) orphan modules below the one being compiled, regardless of package + imp_dep_mods :: ModuleEnv (ModuleName, IsBootInterface), + -- Home-package modules needed by the module being compiled -- -- It doesn't matter whether any of these dependencies are actually -- *used* when compiling the module; they are listed if they are below @@ -495,40 +567,40 @@ data ImportAvails -- compiling M might not need to consult X.hi, but X is still listed -- in M's dependencies. - dep_pkgs :: [PackageName] + imp_dep_pkgs :: [PackageName], -- Packages needed by the module being compiled, whether -- directly, or via other modules in this package, or via -- modules imported from other packages. + + imp_orphs :: [ModuleName] + -- Orphan modules below us in the import tree } emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, - imp_unqual = emptyModuleEnv, - imp_mods = emptyModuleEnv, - dep_mods = emptyModuleEnv, - dep_pkgs = [] } +emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, + imp_qual = emptyModuleEnv, + imp_mods = emptyModuleEnv, + imp_dep_mods = emptyModuleEnv, + imp_dep_pkgs = [], + imp_orphs = [] } plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails - (ImportAvails { imp_env = env1, imp_unqual = unqual1, imp_mods = mods1, - dep_mods = dmods1, dep_pkgs = dpkgs1 }) - (ImportAvails { imp_env = env2, imp_unqual = unqual2, imp_mods = mods2, - dep_mods = dmods2, dep_pkgs = dpkgs2 }) - = ImportAvails { imp_env = env1 `plusAvailEnv` env2, - imp_unqual = plusModuleEnv_C plusAvailEnv unqual1 unqual2, - imp_mods = mods1 `plusModuleEnv` mods2, - dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2, - dep_pkgs = nub (dpkgs1 ++ dpkgs2) } + (ImportAvails { imp_env = env1, imp_qual = unqual1, imp_mods = mods1, + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 }) + (ImportAvails { imp_env = env2, imp_qual = unqual2, imp_mods = mods2, + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2 }) + = ImportAvails { imp_env = env1 `plusAvailEnv` env2, + imp_qual = plusModuleEnv_C plusAvailEnv unqual1 unqual2, + imp_mods = mods1 `plusModuleEnv` mods2, + imp_dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, + imp_orphs = orphs1 `unionLists` orphs2 } where - plus_mod_dep (m1, orphan1, boot1) (m2, orphan2, boot2) - = WARN( not (m1 == m2 && (boot1 || boot2 || orphan1 == orphan2)), - (ppr m1 <+> ppr m2) $$ (ppr orphan1 <+> ppr orphan2) $$ (ppr boot1 <+> ppr boot2) ) - -- Check mod-names match, and orphan-hood matches; but a boot interface - -- might not know about orphan hood, so only check the orphan match - -- if both are non-boot interfaces - (m1, orphan1 || orphan2, boot1 && boot2) - -- If either side can "see" a non-hi-boot interface, use that - -- Similarly orphan-hood (see note about about why orphan1 and 2 might differ) + plus_mod_dep (m1, boot1) (m2, boot2) + = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) + -- Check mod-names match + (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that \end{code} %************************************************************************ @@ -539,7 +611,7 @@ v%************************************************************************ \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2)) +plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (ns1 `unionLists` ns2) -- Added SOF 4/97 #ifdef DEBUG plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) @@ -577,7 +649,13 @@ unitAvailEnv a = unitNameEnv (availName a) a plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv plusAvailEnv = plusNameEnv_C plusAvail -lookupAvailEnv = lookupNameEnv +lookupAvailEnv_maybe :: AvailEnv -> Name -> Maybe AvailInfo +lookupAvailEnv_maybe = lookupNameEnv + +lookupAvailEnv :: AvailEnv -> Name -> AvailInfo +lookupAvailEnv env n = case lookupNameEnv env n of + Just avail -> avail + Nothing -> pprPanic "lookupAvailEnv" (ppr n) availEnvElts = nameEnvElts @@ -656,13 +734,19 @@ data Inst TcThetaType -- The (types of the) dictionaries to which the function -- must be applied to get the method - TcTauType -- The type of the method + TcTauType -- The tau-type of the method InstLoc - -- INVARIANT: in (Method u f tys theta tau loc) + -- INVARIANT 1: in (Method u f tys theta tau loc) -- type of (f tys dicts(from theta)) = tau + -- INVARIANT 2: tau must not be of form (Pred -> Tau) + -- Reason: two methods are considerd equal if the + -- base Id matches, and the instantiating types + -- match. The TcThetaType should then match too. + -- This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind + | LitInst Id HsOverLit -- The literal from the occurrence site @@ -734,7 +818,10 @@ It appears in TcMonad because there are a couple of error-message-generation functions that deal with it. \begin{code} -type InstLoc = (InstOrigin, SrcLoc, ErrCtxt) +data InstLoc = InstLoc InstOrigin SrcLoc ErrCtxt + +instLocSrcLoc :: InstLoc -> SrcLoc +instLocSrcLoc (InstLoc _ src_loc _) = src_loc data InstOrigin = OccurrenceOf Name -- Occurrence of an overloaded identifier @@ -789,7 +876,7 @@ data InstOrigin \begin{code} pprInstLoc :: InstLoc -> SDoc -pprInstLoc (orig, locn, ctxt) +pprInstLoc (InstLoc orig locn ctxt) = hsep [text "arising from", pp_orig orig, text "at", ppr locn] where pp_orig (OccurrenceOf name)