X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=444a4f62efbb6f7070ed6d22ab9ae33ea6e1a069;hb=2ffefc1bfca0c8924825cd15750e7ced457f3c81;hp=65669d81d61d573bcf8d093bc00c7b7680038f6e;hpb=90fa6b84fdc99ba99c0b7df9691ca69d50b62530;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 65669d8..444a4f6 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -5,20 +5,22 @@ \begin{code} module HscTypes ( - Finder, ModuleLocation(..), + ModuleLocation(..), - ModDetails(..), ModIface(..), GlobalSymbolTable, - HomeSymbolTable, PackageSymbolTable, - HomeIfaceTable, PackageIfaceTable, - lookupTable, lookupTableByModName, + ModDetails(..), ModIface(..), + HomeSymbolTable, PackageTypeEnv, + HomeIfaceTable, PackageIfaceTable, emptyIfaceTable, + lookupIface, lookupIfaceByModName, + emptyModIface, IfaceDecls(..), VersionInfo(..), initialVersionInfo, - TyThing(..), groupTyThings, + TyThing(..), isTyClThing, - TypeEnv, extendTypeEnv, lookupTypeEnv, + TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList, + typeEnvClasses, typeEnvTyCons, WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, @@ -43,10 +45,9 @@ module HscTypes ( #include "HsVersions.h" import RdrName ( RdrNameEnv, emptyRdrEnv ) -import Name ( Name, NameEnv, NamedThing, - emptyNameEnv, unitNameEnv, extendNameEnv, plusNameEnv, - lookupNameEnv, emptyNameEnv, getName, nameModule, - nameSrcLoc ) +import Name ( Name, NamedThing, isLocallyDefined, + getName, nameModule, nameSrcLoc ) +import Name -- Env import NameSet ( NameSet ) import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, @@ -64,13 +65,13 @@ import HsSyn ( DeprecTxt ) import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl ) import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) -import CoreSyn ( CoreRule, IdCoreRule ) +import CoreSyn ( IdCoreRule ) import Type ( Type ) -import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM ) +import FiniteMap ( FiniteMap ) import Bag ( Bag ) import Maybes ( seqMaybe ) -import UniqFM ( UniqFM ) +import UniqFM ( UniqFM, emptyUFM ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) import Util ( thenCmp ) @@ -79,19 +80,22 @@ import UniqSupply ( UniqSupply ) %************************************************************************ %* * -\subsection{The Finder type} +\subsection{Module locations} %* * %************************************************************************ \begin{code} -type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation)) - data ModuleLocation = ModuleLocation { - hs_file :: FilePath, - hi_file :: FilePath, - obj_file :: FilePath - } + ml_hs_file :: Maybe FilePath, + ml_hspp_file :: Maybe FilePath, -- path of preprocessed source + ml_hi_file :: Maybe FilePath, + ml_obj_file :: Maybe FilePath + } + deriving Show + +instance Outputable ModuleLocation where + ppr = text . show \end{code} For a module in another package, the hs_file and obj_file @@ -120,13 +124,14 @@ data ModIface mi_module :: Module, -- Complete with package info mi_version :: VersionInfo, -- Module version number mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans + mi_boot :: IsBootInterface, -- Whether this interface was read from an hi-boot file mi_usages :: [ImportVersion Name], -- Usages; kept sorted so that it's easy -- to decide whether to write a new iface file -- (changing usages doesn't affect the version of -- this module) - mi_exports :: Avails, -- What it exports + mi_exports :: [(ModuleName,Avails)], -- What it exports -- Kept sorted by (mod,occ), -- to make version comparisons easier @@ -164,9 +169,15 @@ emptyModDetails emptyModIface :: Module -> ModIface emptyModIface mod = ModIface { mi_module = mod, + mi_version = initialVersionInfo, + mi_usages = [], + mi_orphan = False, + mi_boot = False, mi_exports = [], + mi_fixities = emptyNameEnv, mi_globals = emptyRdrEnv, - mi_deprecs = NoDeprecs + mi_deprecs = NoDeprecs, + mi_decls = panic "emptyModIface: decls" } \end{code} @@ -180,23 +191,27 @@ type HomeIfaceTable = IfaceTable type PackageIfaceTable = IfaceTable type HomeSymbolTable = SymbolTable -- Domain = modules in the home package -type PackageSymbolTable = SymbolTable -- Domain = modules in the some other package -type GlobalSymbolTable = SymbolTable -- Domain = all modules + +emptyIfaceTable :: IfaceTable +emptyIfaceTable = emptyUFM \end{code} Simple lookups in the symbol table. \begin{code} -lookupTable :: ModuleEnv a -> ModuleEnv a -> Name -> Maybe a --- We often have two Symbol- or IfaceTables, and want to do a lookup -lookupTable ht pt name - = lookupModuleEnv ht mod `seqMaybe` lookupModuleEnv pt mod +lookupIface :: HomeIfaceTable -> PackageIfaceTable + -> Module -> Name -- The module is to use for locally-defined names + -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIface hit pit this_mod name + | isLocallyDefined name = lookupModuleEnv hit this_mod + | otherwise = lookupModuleEnv hit mod `seqMaybe` lookupModuleEnv pit mod where mod = nameModule name -lookupTableByModName :: ModuleEnv a -> ModuleEnv a -> ModuleName -> Maybe a +lookupIfaceByModName :: ModuleEnv a -> ModuleEnv a -> ModuleName -> Maybe a -- We often have two Symbol- or IfaceTables, and want to do a lookup -lookupTableByModName ht pt mod +lookupIfaceByModName ht pt mod = lookupModuleEnvByName ht mod `seqMaybe` lookupModuleEnvByName pt mod \end{code} @@ -208,56 +223,50 @@ lookupTableByModName ht pt mod %************************************************************************ \begin{code} -type TypeEnv = NameEnv TyThing -emptyTypeEnv = emptyNameEnv - data TyThing = AnId Id | ATyCon TyCon | AClass Class +isTyClThing :: TyThing -> Bool +isTyClThing (ATyCon _) = True +isTyClThing (AClass _) = True +isTyClThing (AnId _) = False + instance NamedThing TyThing where getName (AnId id) = getName id getName (ATyCon tc) = getName tc getName (AClass cl) = getName cl + +typeEnvClasses env = [cl | AClass cl <- nameEnvElts env] +typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env] + \end{code} \begin{code} -lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing -lookupTypeEnv tbl name - = case lookupModuleEnv tbl (nameModule name) of - Just details -> lookupNameEnv (md_types details) name - Nothing -> Nothing +type TypeEnv = NameEnv TyThing +emptyTypeEnv = emptyNameEnv -groupTyThings :: [TyThing] -> FiniteMap Module TypeEnv - -- Finite map because we want the range too -groupTyThings things - = foldl add emptyFM things - where - add :: FiniteMap Module TypeEnv -> TyThing -> FiniteMap Module TypeEnv - add tbl thing = addToFM tbl mod new_env - where - name = getName thing - mod = nameModule name - new_env = case lookupFM tbl mod of - Nothing -> unitNameEnv name thing - Just env -> extendNameEnv env name thing +mkTypeEnv :: [TyThing] -> TypeEnv +mkTypeEnv things = extendTypeEnvList emptyTypeEnv things -extendTypeEnv :: SymbolTable -> FiniteMap Module TypeEnv -> SymbolTable -extendTypeEnv tbl things - = foldFM add tbl things +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things + = foldl add_thing env things where - add mod type_env tbl - = panic "extendTypeEnv" --extendModuleEnv mod new_details - where - new_details - = case lookupModuleEnv tbl mod of - Nothing -> emptyModDetails {md_types = type_env} - Just details -> details {md_types = md_types details - `plusNameEnv` type_env} + add_thing :: TypeEnv -> TyThing -> TypeEnv + add_thing env thing = extendNameEnv env (getName thing) thing \end{code} +\begin{code} +lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing +lookupType hst pte name + = ASSERT2( not (isLocallyDefined name), ppr name ) + case lookupModuleEnv hst (nameModule name) of + Just details -> lookupNameEnv (md_types details) name + Nothing -> lookupNameEnv pte name +\end{code} %************************************************************************ %* * @@ -288,16 +297,17 @@ initialVersionInfo = VersionInfo { vers_module = initialVersion, vers_decls = emptyNameEnv } data Deprecations = NoDeprecs - | DeprecAll DeprecTxt -- Whole module deprecated - | DeprecSome (NameEnv DeprecTxt) -- Some things deprecated - -- Just "big" names - -lookupDeprec :: ModIface -> Name -> Maybe DeprecTxt -lookupDeprec iface name - = case mi_deprecs iface of - NoDeprecs -> Nothing - DeprecAll txt -> Just txt - DeprecSome env -> lookupNameEnv env name + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome (NameEnv (Name,DeprecTxt)) -- Some things deprecated + -- Just "big" names + -- We keep the Name in the range, so we can print them out + +lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt +lookupDeprec NoDeprecs name = Nothing +lookupDeprec (DeprecAll txt) name = Just txt +lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of + Just (_, txt) -> Just txt + Nothing -> Nothing type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class @@ -321,6 +331,16 @@ data GenAvailInfo name = Avail name -- An ordinary identifier -- Equality used when deciding if the interface has changed type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it + +instance Outputable n => Outputable (GenAvailInfo n) where + ppr = pprAvail + +pprAvail :: Outputable n => GenAvailInfo n -> SDoc +pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of + [] -> empty + ns' -> braces (hsep (punctuate comma (map ppr ns'))) + +pprAvail (Avail n) = ppr n \end{code} @@ -380,7 +400,7 @@ data PersistentCompilerState pcs_PIT :: PackageIfaceTable, -- Domain = non-home-package modules -- the mi_decls component is empty - pcs_PST :: PackageSymbolTable, -- Domain = non-home-package modules + pcs_PTE :: PackageTypeEnv, -- Domain = non-home-package modules -- except that the InstEnv components is empty pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all @@ -400,7 +420,9 @@ It contains: * A name supply, which deals with allocating unique names to (Module,OccName) original names, - * An accumulated InstEnv from all the modules in pcs_PST + * An accumulated TypeEnv from all the modules in imported packages + + * An accumulated InstEnv from all the modules in imported packages The point is that we don't want to keep recreating it whenever we compile a new module. The InstEnv component of pcPST is empty. (This means we might "see" instances that we shouldn't "really" see; @@ -413,6 +435,7 @@ It contains: interface files but not yet sucked in, renamed, and typechecked \begin{code} +type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv