X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnTypes.lhs;h=a42cbc85992938f4adab580a8bf417377cd9345f;hb=42b63073fb5e71fcd539ab80289cf6cf2a5b9641;hp=17c3e0a2ff8a10e41c81d51691173014c445132b;hpb=e0445ffa5a89632b542e7d7bc2ad46d944716453;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 17c3e0a..a42cbc8 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -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, @@ -49,7 +49,7 @@ import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo ) import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, NameCache, GlobalRdrEnv, LocalRdrEnv, FixityEnv, TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo, availName, - IsBootInterface, Deprecations, WhetherHasOrphans ) + IsBootInterface, Deprecations ) import Packages ( PackageName ) import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) @@ -76,7 +76,7 @@ import UNSAFE_IO ( unsafeInterleaveIO ) import FIX_IO ( fixIO ) import EXCEPTION ( Exception ) import Maybe ( mapMaybe ) -import List ( nub ) +import ListSetOps ( unionLists ) import Panic ( tryMost ) \end{code} @@ -235,6 +235,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 +274,15 @@ 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 differen 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 -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. @@ -355,7 +356,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 +375,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} @@ -463,10 +470,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 +498,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,35 +507,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) - = ASSERT( m1 == m2 && orphan1 == orphan2 ) - (m1, orphan1, boot1 && boot2) - -- If either side can "see" a non-hi-boot interface, use that + 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} %************************************************************************ @@ -534,7 +551,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]) @@ -651,13 +668,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 @@ -729,7 +752,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 @@ -784,7 +810,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)