X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=bddcc22d92906fa968c8a697492f2b23c6edbe06;hb=5cbfe81e433d1ca3aed41d5b5522bc1377e6af94;hp=b457bff3806fe7a634e5678e8c9f2949f79965f9;hpb=435b542fea3ccda11376b0422a5ee564ddeba5c7;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index b457bff..bddcc22 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -4,23 +4,46 @@ \section[HscTypes]{Types for the per-module compiler} \begin{code} -module HscTypes ( ) -where +module HscTypes ( + ModDetails(..), GlobalSymbolTable, + HomeSymbolTable, PackageSymbolTable, + + TyThing(..), lookupTypeEnv, + + WhetherHasOrphans, ImportVersion, ExportItem, + PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, + IfaceInsts, IfaceRules, DeprecationEnv, OrigNameEnv, + AvailEnv, AvailInfo, GenAvailInfo(..), + PersistentCompilerState(..), + + InstEnv, ClsInstEnv, DFunId, + + GlobalRdrEnv, RdrAvailInfo, + + -- Provenance + Provenance(..), ImportReason(..), PrintUnqualified, + pprNameProvenance, hasBetterProv + + ) where #include "HsVersions.h" -import Name ( Name, NameEnv ) -import Module ( Module, ModuleName ) +import Name ( Name, NameEnv, NamedThing, + unitNameEnv, extendNameEnv, plusNameEnv, + lookupNameEnv, emptyNameEnv, getName, nameModule, + nameSrcLoc ) +import Module ( Module, ModuleName, + extendModuleEnv, lookupModuleEnv ) import Class ( Class ) import OccName ( OccName ) -import RdrName ( RdrNameEnv ) +import RdrName ( RdrNameEnv, emptyRdrEnv ) import Outputable ( SDoc ) import UniqFM ( UniqFM ) -import FiniteMap ( FiniteMap ) +import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM ) import Bag ( Bag ) import Id ( Id ) -import VarEnv ( IdEnv ) -import BasicTypes ( Version, Fixity ) +import VarEnv ( IdEnv, emptyVarEnv ) +import BasicTypes ( Version, Fixity, defaultFixity ) import TyCon ( TyCon ) import ErrUtils ( ErrMsg, WarnMsg ) import CmLink ( Linkable ) @@ -29,9 +52,12 @@ import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameHsDecl, import UniqSupply ( UniqSupply ) import HsDecls ( DeprecTxt ) import CoreSyn ( CoreRule ) -import RnMonad ( ImportVersion, ExportItem, WhetherHasOrphans ) import NameSet ( NameSet ) - +import Type ( Type ) +import VarSet ( TyVarSet ) +import Panic ( panic ) +import Outputable +import SrcLoc ( SrcLoc, isGoodSrcLoc ) \end{code} %************************************************************************ @@ -45,29 +71,30 @@ A @ModDetails@ summarises everything we know about a compiled module. \begin{code} data ModDetails = ModDetails { - moduleId :: Module, - moduleExports :: Avails, -- What it exports - moduleEnv :: GlobalRdrEnv, -- Its top level environment + md_id :: Module, + md_exports :: Avails, -- What it exports + md_version :: VersionInfo, + md_globals :: GlobalRdrEnv, -- Its top level environment - fixityEnv :: NameEnv Fixity, - deprecEnv :: NameEnv DeprecTxt, - typeEnv :: TypeEnv, + md_fixities :: NameEnv Fixity, + md_deprecs :: NameEnv DeprecTxt, + md_types :: TypeEnv, - instEnv :: InstEnv, - ruleEnv :: RuleEnv -- Domain may include Id from other modules + md_insts :: [DFunId], -- Dfun-ids for the instances in this module + md_rules :: RuleEnv -- Domain may include Id from other modules } -emptyModDetails :: Module -> ModuleDetails +emptyModDetails :: Module -> ModDetails emptyModDetails mod - = ModDetails { moduleId = mod, - moduleExports = [], - moduleEnv = emptyRdrEnv, - fixityEnv = emptyNameEnv, - deptecEnv = emptyNameEnv, - typeEnv = emptyNameEnv, - instEnv = emptyInstEnv, - } ruleEnv = emptyRuleEnv - + = ModDetails { md_id = mod, + md_exports = [], + md_globals = emptyRdrEnv, + md_fixities = emptyNameEnv, + md_deprecs = emptyNameEnv, + md_types = emptyNameEnv, + md_insts = [], + md_rules = emptyRuleEnv + } \end{code} Symbol tables map modules to ModDetails: @@ -82,14 +109,12 @@ type GlobalSymbolTable = SymbolTable -- Domain = all modules Simple lookups in the symbol table. \begin{code} -lookupFixityEnv :: SymbolTable -> Name -> Fixity +lookupFixityEnv :: SymbolTable -> Name -> Maybe Fixity -- Returns defaultFixity if there isn't an explicit fixity lookupFixityEnv tbl name = case lookupModuleEnv tbl (nameModule name) of - Nothing -> defaultFixity - Just details -> case lookupNameEnv (fixityEnv details) name of - Just fixity -> fixity - Nothing -> defaultFixity + Nothing -> Nothing + Just details -> lookupNameEnv (md_fixities details) name \end{code} @@ -117,13 +142,14 @@ instance NamedThing TyThing where lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing lookupTypeEnv tbl name = case lookupModuleEnv tbl (nameModule name) of - Just details -> lookupNameEnv (typeEnv details) name + Just details -> lookupNameEnv (md_types details) name Nothing -> Nothing -groupTyThings :: [TyThing] -> [(Module, TypeEnv)] +groupTyThings :: [TyThing] -> FiniteMap Module TypeEnv + -- Finite map because we want the range too groupTyThings things - = fmToList (foldl add emptyFM things) + = foldl add emptyFM things where add :: FiniteMap Module TypeEnv -> TyThing -> FiniteMap Module TypeEnv add tbl thing = addToFM tbl mod new_env @@ -134,16 +160,18 @@ groupTyThings things Nothing -> unitNameEnv name thing Just env -> extendNameEnv env name thing -extendTypeEnv :: SymbolTable -> [TyThing] -> SymbolTable +extendTypeEnv :: SymbolTable -> FiniteMap Module TypeEnv -> SymbolTable extendTypeEnv tbl things - = foldl add tbl (groupTyThings things) + = foldFM add tbl things where - add tbl (mod,type_env) - = extendModuleEnv mod new_details + add mod type_env tbl + = panic "extendTypeEnv" --extendModuleEnv mod new_details where - new_details = case lookupModuleEnv tbl mod of - Nothing -> emptyModDetails mod {typeEnv = type_env} - Just details -> details {typeEnv = typeEnv details `plusNameEnv` type_env}) + new_details + = case lookupModuleEnv tbl mod of + Nothing -> (emptyModDetails mod) {md_types = type_env} + Just details -> details {md_types = md_types details + `plusNameEnv` type_env} \end{code} @@ -157,16 +185,23 @@ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere \begin{code} -type DeprecationEnv = NameEnv DeprecTxt -- Give reason for deprecation +data VersionInfo + = VersionInfo { + modVers :: Version, + fixVers :: Version, + ruleVers :: Version, + declVers :: NameEnv Version + } -type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes - -- These only get reported on lookup, - -- not on construction +type DeprecationEnv = NameEnv DeprecTxt -- Give reason for deprecation type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class -type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class +type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class +type DFunId = Id type RuleEnv = IdEnv [CoreRule] + +emptyRuleEnv = emptyVarEnv \end{code} @@ -211,6 +246,43 @@ data ModIFace mi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version mi_deprecs :: [RdrNameDeprecation] -- Deprecations } + +type ExportItem = (ModuleName, [RdrAvailInfo]) + +type ImportVersion name = (ModuleName, WhetherHasOrphans, IsBootInterface, WhatsImported name) + +type ModVersionInfo = (Version, -- Version of the whole module + Version, -- Version number for all fixity decls together + Version) -- ...ditto all rules together + +type WhetherHasOrphans = Bool + -- An "orphan" is + -- * an instance decl in a module other than the defn module for + -- one of the tycons or classes in the instance head + -- * a transformation rule in a module other than the one defining + -- the function in the head of the rule. + +type IsBootInterface = Bool + +data WhatsImported name = NothingAtAll -- The module is below us in the + -- hierarchy, but we import nothing + + | Everything Version -- The module version + + | Specifically Version -- Module version + Version -- Fixity version + Version -- Rules version + [(name,Version)] -- List guaranteed non-empty + deriving( Eq ) + -- 'Specifically' doesn't let you say "I imported f but none of the fixities in + -- the module". If you use anything in the module you get its fixity and rule version + -- So if the fixities or rules change, you'll recompile, even if you don't use either. + -- This is easy to implement, and it's safer: you might not have used the rules last + -- time round, but if someone has added a new rule you might need it this time + + -- 'Everything' means there was a "module M" in + -- this module's export list, so we just have to go by M's version, + -- not the list of (name,version) pairs \end{code} @@ -223,13 +295,13 @@ data ModIFace \begin{code} data PersistentCompilerState = PCS { - pcsPST :: PackageSymbolTable, -- Domain = non-home-package modules - -- except that the InstEnv components is empty - pcsInsts :: InstEnv -- The total InstEnv accumulated from all - -- the non-home-package modules - pcsRules :: RuleEnv -- Ditto RuleEnv + pcs_PST :: PackageSymbolTable, -- Domain = non-home-package modules + -- except that the InstEnv components is empty + pcs_insts :: InstEnv, -- The total InstEnv accumulated from all + -- the non-home-package modules + pcs_rules :: RuleEnv, -- Ditto RuleEnv - pcsPRS :: PersistentRenamerState + pcs_PRS :: PersistentRenamerState } \end{code} @@ -240,7 +312,7 @@ It contains: * A name supply, which deals with allocating unique names to (Module,OccName) original names, - * An accumulated InstEnv from all the modules in pcsPST + * An accumulated InstEnv from all the modules in pcs_PST 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; @@ -259,23 +331,34 @@ data PersistentRenamerState prsInsts :: IfaceInsts, prsRules :: IfaceRules } +\end{code} -<<<<<<< HscTypes.lhs -data NameSupply - = NS { nsUniqs :: UniqSupply, - nsNames :: FiniteMap (Module,OccName) Name, -- Ensures that one original name gets one unique - nsIParam :: FiniteMap OccName Name -- Ensures that one implicit parameter name gets one unique -======= +The OrigNameEnv makes sure that there is just one Unique assigned for +each original name; i.e. (module-name, occ-name) pair. The Name is +always stored as a Global, and has the SrcLoc of its binding location. +Actually that's not quite right. When we first encounter the original +name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find +its binding site, we fix it up. + +Exactly the same is true of the Module stored in the Name. When we first +encounter the occurrence, we may not know the details of the module, so +we just store junk. Then when we find the binding site, we fix it up. + +\begin{code} data OrigNameEnv - = Orig { origNames :: FiniteMap (Module,OccName) Name -- Ensures that one original name gets one unique - origIParam :: FiniteMap OccName Name -- Ensures that one implicit parameter name gets one unique ->>>>>>> 1.6 + = Orig { origNames :: FiniteMap (ModuleName,OccName) Name, -- Ensures that one original name gets one unique + origIParam :: FiniteMap OccName Name -- Ensures that one implicit parameter name gets one unique } +\end{code} + -type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl)) - -- A DeclsMap contains a binding for each Name in the declaration - -- including the constructors of a type decl etc. - -- The Bool is True just for the 'main' Name. +A DeclsMap contains a binding for each Name in the declaration +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 IfaceInsts = Bag GatedDecl type IfaceRules = Bag GatedDecl @@ -311,16 +394,16 @@ data CompResult -- generate Linkables. data HscResult - = HscOK ModDetails -- new details (HomeSymbolTable additions) - Maybe ModIFace -- new iface (if any compilation was done) - Maybe String -- generated stub_h - Maybe String -- generated stub_c - PersistentCompilerState -- updated PCS - [SDoc] -- warnings + = HscOK ModDetails -- new details (HomeSymbolTable additions) + (Maybe ModIFace) -- new iface (if any compilation was done) + (Maybe String) -- generated stub_h filename (in /tmp) + (Maybe String) -- generated stub_c filename (in /tmp) + PersistentCompilerState -- updated PCS + [SDoc] -- warnings - | HscErrs PersistentCompilerState -- updated PCS - [SDoc] -- errors - [SDoc] -- warnings + | HscErrs PersistentCompilerState -- updated PCS + [SDoc] -- errors + [SDoc] -- warnings -- These two are only here to avoid recursion between CmCompile and @@ -332,3 +415,80 @@ type HomeInterfaceTable = ModuleEnv ModIFace \end{code} +%************************************************************************ +%* * +\subsection{Provenance and export info} +%* * +%************************************************************************ + +The GlobalRdrEnv gives maps RdrNames to Names. There is a separate +one for each module, corresponding to that module's top-level scope. + +\begin{code} +type GlobalRdrEnv = RdrNameEnv [(Name,Provenance)] -- The list is because there may be name clashes + -- These only get reported on lookup, + -- not on construction +\end{code} + +The "provenance" of something says how it came to be in scope. + +\begin{code} +data Provenance + = LocalDef -- Defined locally + + | NonLocalDef -- Defined non-locally + ImportReason + PrintUnqualified + +{- +Moved here from Name. +pp_prov (LocalDef _ Exported) = char 'x' +pp_prov (LocalDef _ NotExported) = char 'l' +pp_prov (NonLocalDef ImplicitImport _) = char 'j' +pp_prov (NonLocalDef (UserImport _ _ True ) _) = char 'I' -- Imported by name +pp_prov (NonLocalDef (UserImport _ _ False) _) = char 'i' -- Imported by .. +pp_prov SystemProv = char 's' +-} + +data ImportReason + = UserImport Module SrcLoc Bool -- Imported from module M on line L + -- Note the M may well not be the defining module + -- for this thing! + -- The Bool is true iff the thing was named *explicitly* in the import spec, + -- rather than being imported as part of a group; e.g. + -- import B + -- import C( T(..) ) + -- Here, everything imported by B, and the constructors of T + -- are not named explicitly; only T is named explicitly. + -- 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} +hasBetterProv :: Provenance -> Provenance -> Bool +-- Choose +-- 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 + +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)))] + +ppr_reason ImplicitImport = ptext SLIT("implicitly imported") +ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc + +ppr_defn loc | isGoodSrcLoc loc = ptext SLIT("at") <+> ppr loc + | otherwise = empty +\end{code}