X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=3c76b600ad7ae9b2249dfc3c78206dc4e84ae785;hb=31285afea6a7b553380fd0a01e0a8ce0d7e50878;hp=c60c575216e893d9cca51d00866b37543430358e;hpb=c271b64780a6504e7ccd4cc422dfc90678ea966f;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index c60c575..3c76b60 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -5,28 +5,34 @@ \begin{code} module HscTypes ( + GhciMode(..), + ModuleLocation(..), ModDetails(..), ModIface(..), - HomeSymbolTable, PackageTypeEnv, + HomeSymbolTable, emptySymbolTable, + PackageTypeEnv, HomeIfaceTable, PackageIfaceTable, emptyIfaceTable, lookupIface, lookupIfaceByModName, emptyModIface, + InteractiveContext(..), + IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - VersionInfo(..), initialVersionInfo, + VersionInfo(..), initialVersionInfo, lookupVersion, TyThing(..), isTyClThing, implicitTyThingIds, - TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList, - typeEnvClasses, typeEnvTyCons, + TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, + extendTypeEnvList, extendTypeEnvWithIds, + typeEnvClasses, typeEnvTyCons, typeEnvIds, - WhetherHasOrphans, ImportVersion, WhatsImported(..), - PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, - IfaceInsts, IfaceRules, GatedDecl, IsExported, - OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, - AvailEnv, AvailInfo, GenAvailInfo(..), + ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..), + PersistentRenamerState(..), IsBootInterface, DeclsMap, + IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, IsExported, + NameSupply(..), OrigNameCache, OrigIParamCache, + Avails, AvailEnv, GenAvailInfo(..), AvailInfo, RdrAvailInfo, PersistentCompilerState(..), Deprecations(..), lookupDeprec, @@ -34,7 +40,9 @@ module HscTypes ( InstEnv, ClsInstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, RdrAvailInfo, pprGlobalRdrEnv, + GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv, + LocalRdrEnv, extendLocalRdrEnv, + -- Provenance Provenance(..), ImportReason(..), @@ -44,15 +52,16 @@ module HscTypes ( #include "HsVersions.h" -import RdrName ( RdrNameEnv, emptyRdrEnv, rdrEnvToList ) -import Name ( Name, NamedThing, getName, nameModule, nameSrcLoc ) -import Name -- Env +import RdrName ( RdrNameEnv, addListToRdrEnv, emptyRdrEnv, mkRdrUnqual, rdrEnvToList ) +import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) +import NameEnv import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv ) import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) +import CoreSyn ( CoreBind ) import Id ( Id ) import Class ( Class, classSelIds ) import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) @@ -68,7 +77,7 @@ import CoreSyn ( IdCoreRule ) import FiniteMap ( FiniteMap ) import Bag ( Bag ) -import Maybes ( seqMaybe ) +import Maybes ( seqMaybe, orElse ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) import Util ( thenCmp, sortLt ) @@ -77,6 +86,18 @@ import UniqSupply ( UniqSupply ) %************************************************************************ %* * +\subsection{Which mode we're in +%* * +%************************************************************************ + +\begin{code} +data GhciMode = Batch | Interactive | OneShot + deriving Eq +\end{code} + + +%************************************************************************ +%* * \subsection{Module locations} %* * %************************************************************************ @@ -86,7 +107,7 @@ data ModuleLocation = ModuleLocation { ml_hs_file :: Maybe FilePath, ml_hspp_file :: Maybe FilePath, -- path of preprocessed source - ml_hi_file :: Maybe FilePath, + ml_hi_file :: FilePath, ml_obj_file :: Maybe FilePath } deriving Show @@ -150,24 +171,8 @@ mkIfaceDecls tycls rules insts dcl_rules = sortLt lt_rule rules, dcl_insts = insts } where - d1 `lt_tycl` d2 = nameOccName (tyClDeclName d1) < nameOccName (tyClDeclName d2) - r1 `lt_rule` r2 = nameOccName (ifaceRuleDeclName r1) < nameOccName (ifaceRuleDeclName r2) - - -- I wanted to sort just by the Name, but there's a problem: we are comparing - -- the old version of an interface with the new version. The latter will use - -- local names like 'lvl23' that were constructed not by the renamer but by - -- the simplifier. So the unqiues aren't going to line up. - -- - -- It's ok to compare by OccName because this comparison only drives the - -- computation of new version numbers. - -- - -- Better solutions: Compare in a way that is insensitive to the name used - -- for local things. This would decrease the wobbles due - -- to 'lvl23' changing to 'lvl24'. - -- - -- NB: there's a related comparision on MkIface.diffDecls! - - + d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2 + r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2 -- typechecker should only look at this, not ModIface @@ -177,18 +182,45 @@ 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 :: [IdCoreRule] -- Domain may include Ids from other modules + md_rules :: [IdCoreRule], -- Domain may include Ids from other modules + md_binds :: [CoreBind] } + +-- The ModDetails takes on several slightly different forms: +-- +-- After typecheck + desugar +-- md_types Contains TyCons, Classes, and hasNoBinding Ids +-- md_insts All instances from this module (incl derived ones) +-- md_rules All rules from this module +-- md_binds Desugared bindings +-- +-- After simplification +-- md_types Same as after typecheck +-- md_insts Ditto +-- md_rules Orphan rules only (local ones now attached to binds) +-- md_binds With rules attached +-- +-- After CoreTidy +-- md_types Now contains Ids as well, replete with final IdInfo +-- The Ids are only the ones that are visible from +-- importing modules. Without -O that means only +-- exported Ids, but with -O importing modules may +-- see ids mentioned in unfoldings of exported Ids +-- +-- md_insts Same DFunIds as before, but with final IdInfo, +-- and the unique might have changed; remember that +-- CoreTidy links up the uniques of old and new versions +-- +-- md_rules All rules for exported things, substituted with final Ids +-- +-- md_binds Tidied +-- +-- Passed back to compilation manager +-- Just as after CoreTidy, but with md_binds nuked + \end{code} \begin{code} -emptyModDetails :: ModDetails -emptyModDetails - = ModDetails { md_types = emptyTypeEnv, - md_insts = [], - md_rules = [] - } - emptyModIface :: Module -> ModIface emptyModIface mod = ModIface { mi_module = mod, @@ -215,6 +247,9 @@ type PackageIfaceTable = IfaceTable type HomeSymbolTable = SymbolTable -- Domain = modules in the home package +emptySymbolTable :: SymbolTable +emptySymbolTable = emptyModuleEnv + emptyIfaceTable :: IfaceTable emptyIfaceTable = emptyModuleEnv \end{code} @@ -238,6 +273,26 @@ lookupIfaceByModName hit pit mod %************************************************************************ %* * +\subsection{The interactive context} +%* * +%************************************************************************ + +\begin{code} +data InteractiveContext + = InteractiveContext { + ic_module :: Module, -- The current module in which + -- the user is sitting + + ic_rn_env :: LocalRdrEnv, -- Lexical context for variables bound + -- during interaction + + ic_type_env :: TypeEnv -- Ditto for types + } +\end{code} + + +%************************************************************************ +%* * \subsection{Type environment stuff} %* * %************************************************************************ @@ -257,8 +312,14 @@ 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] +typeEnvIds env = [id | AnId id <- nameEnvElts env] implicitTyThingIds :: [TyThing] -> [Id] -- Add the implicit data cons and selectors etc @@ -285,10 +346,11 @@ mkTypeEnv things = extendTypeEnvList emptyTypeEnv things extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv extendTypeEnvList env things - = foldl add_thing env things - where - add_thing :: TypeEnv -> TyThing -> TypeEnv - add_thing env thing = extendNameEnv env (getName thing) thing + = extendNameEnvList env [(getName thing, thing) | thing <- things] + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] \end{code} \begin{code} @@ -319,13 +381,19 @@ data VersionInfo -- The version of an Id changes if its fixity changes -- Ditto data constructors, class operations, except that the version of -- the parent class/tycon changes + -- + -- If a name isn't in the map, it means 'initialVersion' } initialVersionInfo :: VersionInfo initialVersionInfo = VersionInfo { vers_module = initialVersion, vers_exports = initialVersion, vers_rules = initialVersion, - vers_decls = emptyNameEnv } + vers_decls = emptyNameEnv + } + +lookupVersion :: NameEnv Version -> Name -> Version +lookupVersion env name = lookupNameEnv env name `orElse` initialVersion data Deprecations = NoDeprecs | DeprecAll DeprecTxt -- Whole module deprecated @@ -339,6 +407,13 @@ lookupDeprec (DeprecAll txt) name = Just txt lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of Just (_, txt) -> Just txt Nothing -> Nothing + +instance Eq Deprecations where + -- Used when checking whether we need write a new interface + NoDeprecs == NoDeprecs = True + (DeprecAll t1) == (DeprecAll t2) = t1 == t2 + (DeprecSome e1) == (DeprecSome e2) = nameEnvElts e1 == nameEnvElts e2 + d1 == d2 = False \end{code} @@ -438,7 +513,6 @@ data PersistentCompilerState pcs_PRS :: PersistentRenamerState } - \end{code} The @PersistentRenamerState@ persists across successive calls to the @@ -468,15 +542,15 @@ type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv data PersistentRenamerState - = PRS { prsOrig :: OrigNameEnv, - prsDecls :: DeclsMap, - prsInsts :: IfaceInsts, - prsRules :: IfaceRules, - prsNS :: UniqSupply + = PRS { prsOrig :: NameSupply, + prsImpMods :: ImportedModuleInfo, + prsDecls :: DeclsMap, + prsInsts :: IfaceInsts, + prsRules :: IfaceRules } \end{code} -The OrigNameEnv makes sure that there is just one Unique assigned for +The NameSupply 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 @@ -489,17 +563,29 @@ 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 :: OrigNameNameEnv, +data NameSupply + = NameSupply { nsUniqs :: UniqSupply, + -- Supply of uniques + nsNames :: OrigNameCache, -- Ensures that one original name gets one unique - origIParam :: OrigNameIParamEnv + nsIPs :: OrigIParamCache -- Ensures that one implicit parameter name gets one unique } -type OrigNameNameEnv = FiniteMap (ModuleName,OccName) Name -type OrigNameIParamEnv = FiniteMap OccName Name +type OrigNameCache = FiniteMap (ModuleName,OccName) Name +type OrigIParamCache = FiniteMap OccName Name \end{code} +@ImportedModuleInfo@ contains info ONLY about modules that have not yet +been loaded into the iPIT. These modules are mentioned in interfaces we've +already read, so we know a tiny bit about them, but we havn't yet looked +at the interface file for the module itself. It needs to persist across +invocations of the renamer, at least from Rename.checkOldIface to Rename.renameSource. +And there's no harm in it persisting across multiple compilations. + +\begin{code} +type ImportedModuleInfo = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface) +\end{code} A DeclsMap contains a binding for each Name in the declaration including the constructors of a type decl etc. The Bool is True just @@ -513,7 +599,13 @@ type IfaceInsts = GatedDecls RdrNameInstDecl type IfaceRules = GatedDecls RdrNameRuleDecl type GatedDecls d = (Bag (GatedDecl d), Int) -- The Int says how many have been sucked in -type GatedDecl d = ([Name], (Module, d)) +type GatedDecl d = (GateFn, (Module, d)) +type GateFn = (Name -> Bool) -> Bool -- Returns True <=> gate is open + -- The (Name -> Bool) fn returns True for visible Names + -- For example, suppose this is in an interface file + -- instance C T where ... + -- We want to slurp this decl if both C and T are "visible" in + -- the importing module. See "The gating story" in RnIfaces for details. \end{code} @@ -523,19 +615,32 @@ type GatedDecl d = ([Name], (Module, d)) %* * %************************************************************************ +A LocalRdrEnv is used for local bindings (let, where, lambda, case) + +\begin{code} +type LocalRdrEnv = RdrNameEnv Name + +extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnv env names + = addListToRdrEnv env [(mkRdrUnqual (nameOccName n), n) | n <- names] +\end{code} + 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 +type GlobalRdrEnv = RdrNameEnv [GlobalRdrElt] + -- The list is because there may be name clashes + -- These only get reported on lookup, not on construction + +data GlobalRdrElt = GRE Name Provenance (Maybe DeprecTxt) + -- The Maybe DeprecTxt tells whether this name is deprecated pprGlobalRdrEnv env = vcat (map pp (rdrEnvToList env)) where pp (rn, nps) = ppr rn <> colon <+> - vcat [ppr n <+> pprNameProvenance n p | (n,p) <- nps] + vcat [ppr n <+> pprNameProvenance n p | (GRE n p _) <- nps] \end{code} The "provenance" of something says how it came to be in scope. @@ -598,11 +703,11 @@ 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)))] + nest 2 (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 +ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("at") <+> ppr loc) | otherwise = empty \end{code}