X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=e7f639d33ddb51ab6de351e634edf6d301af4b3d;hb=2ecf1c9f639dc75f1078e88c2e551116923f742a;hp=3cdc200c9ba35b6c780214af2612994e0c4b58e4;hpb=fffba9e37c59f6b03bb79dcafb818b88abc0ed47;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 3cdc200..e7f639d 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -5,20 +5,21 @@ \begin{code} module HscTypes ( - Finder, ModuleLocation(..), + ModuleLocation(..), ModDetails(..), ModIface(..), GlobalSymbolTable, HomeSymbolTable, PackageSymbolTable, - HomeIfaceTable, PackageIfaceTable, + HomeIfaceTable, PackageIfaceTable, emptyIfaceTable, lookupTable, lookupTableByModName, IfaceDecls(..), VersionInfo(..), initialVersionInfo, - TyThing(..), groupTyThings, + TyThing(..), groupTyThings, isTyClThing, TypeEnv, extendTypeEnv, lookupTypeEnv, + typeEnvClasses, typeEnvTyCons, WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, @@ -30,6 +31,7 @@ module HscTypes ( Deprecations(..), lookupDeprec, InstEnv, ClsInstEnv, DFunId, + PackageInstEnv, PackageRuleBase, GlobalRdrEnv, RdrAvailInfo, @@ -45,14 +47,14 @@ import RdrName ( RdrNameEnv, emptyRdrEnv ) import Name ( Name, NameEnv, NamedThing, emptyNameEnv, unitNameEnv, extendNameEnv, plusNameEnv, lookupNameEnv, emptyNameEnv, getName, nameModule, - nameSrcLoc ) + nameSrcLoc, nameEnvElts ) import NameSet ( NameSet ) import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, - lookupModuleEnv, lookupModuleEnvByName + extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName ) +import Rules ( RuleBase ) import VarSet ( TyVarSet ) -import VarEnv ( emptyVarEnv ) import Id ( Id ) import Class ( Class ) import TyCon ( TyCon ) @@ -60,36 +62,39 @@ 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 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 - } + } + deriving Show + +instance Outputable ModuleLocation where + ppr = text . show \end{code} For a module in another package, the hs_file and obj_file @@ -124,7 +129,7 @@ data ModIface -- (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 @@ -137,7 +142,6 @@ data ModIface } data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted - dcl_sigs :: [RenamedIfaceSig], -- Sorted dcl_rules :: [RenamedRuleDecl], -- Sorted dcl_insts :: [RenamedInstDecl] } -- Unsorted @@ -148,7 +152,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} @@ -157,7 +161,7 @@ emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], - md_rules = emptyRuleEnv + md_rules = [] } emptyModIface :: Module -> ModIface @@ -181,6 +185,9 @@ 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. @@ -214,10 +221,19 @@ 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} @@ -248,7 +264,7 @@ extendTypeEnv tbl things = foldFM add tbl things where add mod type_env tbl - = panic "extendTypeEnv" --extendModuleEnv mod new_details + = extendModuleEnv tbl mod new_details where new_details = case lookupModuleEnv tbl mod of @@ -287,24 +303,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} @@ -381,14 +395,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 -- 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 @@ -411,11 +429,15 @@ It contains: interface files but not yet sucked in, renamed, and typechecked \begin{code} +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv + data PersistentRenamerState = PRS { prsOrig :: OrigNameEnv, prsDecls :: DeclsMap, prsInsts :: IfaceInsts, - prsRules :: IfaceRules + prsRules :: IfaceRules, + prsNS :: UniqSupply } \end{code} @@ -449,7 +471,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