X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=e2a83c69c95d11990fc9824a66b59268fb6ffda8;hb=4166dff80e8ec94022a040318ff2759913fbbe06;hp=e7f639d33ddb51ab6de351e634edf6d301af4b3d;hpb=2ecf1c9f639dc75f1078e88c2e551116923f742a;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index e7f639d..e2a83c6 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -7,23 +7,24 @@ module HscTypes ( ModuleLocation(..), - ModDetails(..), ModIface(..), GlobalSymbolTable, - HomeSymbolTable, PackageSymbolTable, + ModDetails(..), ModIface(..), + HomeSymbolTable, PackageTypeEnv, HomeIfaceTable, PackageIfaceTable, emptyIfaceTable, - lookupTable, lookupTableByModName, + lookupIface, lookupIfaceByModName, + emptyModIface, - IfaceDecls(..), + IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, VersionInfo(..), initialVersionInfo, - TyThing(..), groupTyThings, isTyClThing, + TyThing(..), isTyClThing, implicitTyThingIds, - TypeEnv, extendTypeEnv, lookupTypeEnv, + TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList, typeEnvClasses, typeEnvTyCons, WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, - IfaceInsts, IfaceRules, GatedDecl, + IfaceInsts, IfaceRules, GatedDecl, IsExported, OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, AvailEnv, AvailInfo, GenAvailInfo(..), PersistentCompilerState(..), @@ -33,48 +34,44 @@ module HscTypes ( InstEnv, ClsInstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, RdrAvailInfo, + GlobalRdrEnv, RdrAvailInfo, pprGlobalRdrEnv, -- Provenance - Provenance(..), ImportReason(..), PrintUnqualified, + Provenance(..), ImportReason(..), pprNameProvenance, hasBetterProv ) where #include "HsVersions.h" -import RdrName ( RdrNameEnv, emptyRdrEnv ) -import Name ( Name, NameEnv, NamedThing, - emptyNameEnv, unitNameEnv, extendNameEnv, plusNameEnv, - lookupNameEnv, emptyNameEnv, getName, nameModule, - nameSrcLoc, nameEnvElts ) -import NameSet ( NameSet ) +import RdrName ( RdrNameEnv, emptyRdrEnv, rdrEnvToList ) +import Name ( Name, NamedThing, getName, nameModule, nameSrcLoc ) +import Name -- Env import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, - extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName + lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv ) +import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) -import VarSet ( TyVarSet ) import Id ( Id ) -import Class ( Class ) -import TyCon ( TyCon ) +import Class ( Class, classSelIds ) +import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) +import DataCon ( dataConId, dataConWrapId ) import BasicTypes ( Version, initialVersion, Fixity ) -import HsSyn ( DeprecTxt ) -import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl ) +import HsSyn ( DeprecTxt, tyClDeclName, ifaceRuleDeclName ) +import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl ) import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) 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, emptyUFM ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import Util ( thenCmp ) +import Util ( thenCmp, sortLt ) import UniqSupply ( UniqSupply ) \end{code} @@ -87,9 +84,10 @@ import UniqSupply ( UniqSupply ) \begin{code} 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 @@ -123,6 +121,7 @@ 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 @@ -145,6 +144,16 @@ data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted dcl_rules :: [RenamedRuleDecl], -- Sorted dcl_insts :: [RenamedInstDecl] } -- Unsorted +mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls +mkIfaceDecls tycls rules insts + = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls, + dcl_rules = sortLt lt_rule rules, + dcl_insts = insts } + where + d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2 + r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2 + + -- typechecker should only look at this, not ModIface -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails @@ -167,9 +176,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} @@ -183,27 +198,25 @@ 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 +emptyIfaceTable = emptyModuleEnv \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 -> Name -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIface hit pit name + = lookupModuleEnv hit mod `seqMaybe` lookupModuleEnv pit mod where mod = nameModule name -lookupTableByModName :: ModuleEnv a -> ModuleEnv a -> ModuleName -> Maybe a --- We often have two Symbol- or IfaceTables, and want to do a lookup -lookupTableByModName ht pt mod - = lookupModuleEnvByName ht mod `seqMaybe` lookupModuleEnvByName pt mod +lookupIfaceByModName :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIfaceByModName hit pit mod + = lookupModuleEnvByName hit mod `seqMaybe` lookupModuleEnvByName pit mod \end{code} @@ -214,9 +227,6 @@ lookupTableByModName ht pt mod %************************************************************************ \begin{code} -type TypeEnv = NameEnv TyThing -emptyTypeEnv = emptyNameEnv - data TyThing = AnId Id | ATyCon TyCon | AClass Class @@ -231,48 +241,52 @@ instance NamedThing TyThing where getName (ATyCon tc) = getName tc getName (AClass cl) = getName cl +instance Outputable TyThing where + ppr (AnId id) = ptext SLIT("AnId") <+> ppr id + ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc + ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl + typeEnvClasses env = [cl | AClass cl <- nameEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env] +implicitTyThingIds :: [TyThing] -> [Id] +-- Add the implicit data cons and selectors etc +implicitTyThingIds things + = concat (map go things) + where + go (AnId f) = [] + go (AClass cl) = classSelIds cl + go (ATyCon tc) = tyConGenIds tc ++ + tyConSelIds tc ++ + [ n | dc <- tyConDataConsIfAvailable tc, + n <- [dataConId dc, dataConWrapId dc] ] + -- Synonyms return empty list of constructors and selectors \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 - = extendModuleEnv tbl 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 + = case lookupModuleEnv hst (nameModule name) of + Just details -> lookupNameEnv (md_types details) name + Nothing -> lookupNameEnv pte name +\end{code} %************************************************************************ %* * @@ -314,11 +328,6 @@ 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 \end{code} @@ -337,6 +346,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} @@ -381,6 +400,8 @@ data WhatsImported name = NothingAtAll -- The module is below us in the -- we imported the module without saying exactly what we imported -- We need to recompile if the module exports changes, because we might -- now have a name clash in the importing module. + +type IsExported = Name -> Bool -- True for names that are exported from this module \end{code} @@ -396,7 +417,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 @@ -416,7 +437,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; @@ -429,6 +452,7 @@ It contains: interface files but not yet sucked in, renamed, and typechecked \begin{code} +type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv @@ -471,12 +495,14 @@ 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, RdrNameTyClDecl)) +type DeclsMap = (NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl)), Int) + -- The Int says how many have been sucked in -type IfaceInsts = Bag GatedDecl -type IfaceRules = Bag GatedDecl +type IfaceInsts = GatedDecls RdrNameInstDecl +type IfaceRules = GatedDecls RdrNameRuleDecl -type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) +type GatedDecls d = (Bag (GatedDecl d), Int) -- The Int says how many have been sucked in +type GatedDecl d = ([Name], (Module, d)) \end{code} @@ -493,6 +519,12 @@ one for each module, corresponding to that module's top-level scope. type GlobalRdrEnv = RdrNameEnv [(Name,Provenance)] -- The list is because there may be name clashes -- These only get reported on lookup, -- not on construction + +pprGlobalRdrEnv env + = vcat (map pp (rdrEnvToList env)) + where + pp (rn, nps) = ppr rn <> colon <+> + vcat [ppr n <+> pprNameProvenance n p | (n,p) <- nps] \end{code} The "provenance" of something says how it came to be in scope. @@ -503,7 +535,6 @@ data Provenance | NonLocalDef -- Defined non-locally ImportReason - PrintUnqualified -- Just used for grouping error messages (in RnEnv.warnUnusedBinds) instance Eq Provenance where @@ -514,10 +545,10 @@ instance Eq ImportReason where instance Ord Provenance where compare LocalDef LocalDef = EQ - compare LocalDef (NonLocalDef _ _) = LT - compare (NonLocalDef _ _) LocalDef = GT + compare LocalDef (NonLocalDef _) = LT + compare (NonLocalDef _) LocalDef = GT - compare (NonLocalDef reason1 _) (NonLocalDef reason2 _) + compare (NonLocalDef reason1) (NonLocalDef reason2) = compare reason1 reason2 instance Ord ImportReason where @@ -541,11 +572,6 @@ data ImportReason -- This info is used when warning of unused names. | ImplicitImport -- Imported implicitly for some other reason - - -type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is - -- in scope in this module, so print it - -- unqualified in error messages \end{code} \begin{code} @@ -554,15 +580,14 @@ hasBetterProv :: Provenance -> Provenance -> Bool -- a local thing over an imported thing -- a user-imported thing over a non-user-imported thing -- an explicitly-imported thing over an implicitly imported thing -hasBetterProv LocalDef _ = True -hasBetterProv (NonLocalDef (UserImport _ _ True) _) _ = True -hasBetterProv (NonLocalDef (UserImport _ _ _ ) _) (NonLocalDef ImplicitImport _) = True -hasBetterProv _ _ = False +hasBetterProv LocalDef _ = True +hasBetterProv (NonLocalDef (UserImport _ _ _ )) (NonLocalDef ImplicitImport) = True +hasBetterProv _ _ = False pprNameProvenance :: Name -> Provenance -> SDoc -pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) -pprNameProvenance name (NonLocalDef why _) = sep [ppr_reason why, - nest 2 (parens (ppr_defn (nameSrcLoc name)))] +pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) +pprNameProvenance name (NonLocalDef why) = sep [ppr_reason why, + nest 2 (parens (ppr_defn (nameSrcLoc name)))] ppr_reason ImplicitImport = ptext SLIT("implicitly imported") ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc