X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=444a4f62efbb6f7070ed6d22ab9ae33ea6e1a069;hb=2ffefc1bfca0c8924825cd15750e7ced457f3c81;hp=1b34ec0c4366e568f54aac696bf7b394789afcb2;hpb=99073d876ea762016683fb0b22b9d343ff864eb4;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 1b34ec0..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, + 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, @@ -30,6 +32,7 @@ module HscTypes ( Deprecations(..), lookupDeprec, InstEnv, ClsInstEnv, DFunId, + PackageInstEnv, PackageRuleBase, GlobalRdrEnv, RdrAvailInfo, @@ -42,16 +45,16 @@ 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, - lookupModuleEnv ) + lookupModuleEnv, lookupModuleEnvByName + ) +import Rules ( RuleBase ) import VarSet ( TyVarSet ) -import VarEnv ( emptyVarEnv ) import Id ( Id ) import Class ( Class ) import TyCon ( TyCon ) @@ -59,36 +62,40 @@ import TyCon ( TyCon ) import BasicTypes ( Version, initialVersion, Fixity ) import HsSyn ( DeprecTxt ) -import RdrHsSyn ( RdrNameHsDecl ) -import RnHsSyn ( RenamedTyClDecl, RenamedIfaceSig, RenamedRuleDecl, RenamedInstDecl ) +import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl ) +import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) -import CoreSyn ( CoreRule ) +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 ) +import UniqSupply ( UniqSupply ) \end{code} %************************************************************************ %* * -\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 @@ -117,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 @@ -136,7 +144,6 @@ data ModIface } data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted - dcl_sigs :: [RenamedIfaceSig], -- Sorted dcl_rules :: [RenamedRuleDecl], -- Sorted dcl_insts :: [RenamedInstDecl] } -- Unsorted @@ -147,7 +154,7 @@ data ModDetails -- The next three fields are created by the typechecker md_types :: TypeEnv, md_insts :: [DFunId], -- Dfun-ids for the instances in this module - md_rules :: RuleEnv -- Domain may include Ids from other modules + md_rules :: [IdCoreRule] -- Domain may include Ids from other modules } \end{code} @@ -156,15 +163,21 @@ emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], - md_rules = emptyRuleEnv + md_rules = [] } 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} @@ -178,19 +191,28 @@ 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 + +lookupIfaceByModName :: ModuleEnv a -> ModuleEnv a -> ModuleName -> Maybe a +-- We often have two Symbol- or IfaceTables, and want to do a lookup +lookupIfaceByModName ht pt mod + = lookupModuleEnvByName ht mod `seqMaybe` lookupModuleEnvByName pt mod \end{code} @@ -201,56 +223,50 @@ lookupTable ht pt name %************************************************************************ \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} %************************************************************************ %* * @@ -281,24 +297,22 @@ 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 + type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class type DFunId = Id - -type RuleEnv = NameEnv [CoreRule] - -emptyRuleEnv = emptyVarEnv \end{code} @@ -317,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} @@ -375,14 +399,18 @@ data PersistentCompilerState = PCS { 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 :: InstEnv, -- The total InstEnv accumulated from all + + pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all -- the non-home-package modules - pcs_rules :: RuleEnv, -- Ditto RuleEnv + + pcs_rules :: PackageRuleBase, -- Ditto RuleEnv pcs_PRS :: PersistentRenamerState } + \end{code} The @PersistentRenamerState@ persists across successive calls to the @@ -392,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; @@ -405,11 +435,16 @@ It contains: interface files but not yet sucked in, renamed, and typechecked \begin{code} +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv + data PersistentRenamerState = PRS { prsOrig :: OrigNameEnv, prsDecls :: DeclsMap, prsInsts :: IfaceInsts, - prsRules :: IfaceRules + prsRules :: IfaceRules, + prsNS :: UniqSupply } \end{code} @@ -443,7 +478,7 @@ including the constructors of a type decl etc. The Bool is True just for the 'main' Name. \begin{code} -type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameHsDecl)) +type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl)) type IfaceInsts = Bag GatedDecl type IfaceRules = Bag GatedDecl