X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=26267c0ef6c9066e4f8477733e071aded4b84c57;hb=c5baccd2b0fc8b987f6c9145a68f06f1d73036bb;hp=7cb86bfb42be033fbb0e930febac267a98f57222;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 7cb86bf..26267c0 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -6,40 +6,44 @@ \begin{code} module HscTypes ( HscEnv(..), hscEPS, - GhciMode(..), + GhciMode(..), isOneShot, ModDetails(..), ModGuts(..), ModImports(..), ForeignStubs(..), + ModSummary(..), showModMsg, + msHsFilePath, msHiFilePath, msObjFilePath, + + HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + hptInstances, hptRules, - ExternalPackageState(..), + ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, - lookupIface, lookupIfaceByModName, moduleNameToModule, - emptyModIface, + lookupIface, lookupIfaceByModule, emptyModIface, InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, unQualInScope, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, - emptyIfaceDepCache, + emptyIfaceDepCache, Deprecs(..), IfaceDeprecs, FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - implicitTyThings, isImplicitTyThing, + implicitTyThings, TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, - extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, + extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - Pool(..), emptyPool, DeclPool, InstPool, - Gated, - RulePool, addRuleToPool, + InstPool, Gated, addInstsToPool, + RulePool, addRulesToPool, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, @@ -64,25 +68,25 @@ import ByteCodeAsm ( CompiledByteCode ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv, - GlobalRdrElt(..), unQualOK ) + GlobalRdrElt(..), mkRdrUnqual, lookupGRE_RdrName ) import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, - extendOccEnv, foldOccEnv ) + extendOccEnv ) import Module import InstEnv ( InstEnv, DFunId ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) -import Id ( Id, isImplicitId ) +import Id ( Id ) import Type ( TyThing(..) ) import Class ( Class, classSelIds, classTyCon ) -import TyCon ( TyCon, isClassTyCon, tyConSelIds, tyConDataCons ) +import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) -import Packages ( PackageName ) +import Packages ( PackageIdH, PackageId ) import CmdLineOpts ( DynFlags ) - +import DriverPhases ( HscSource(..), isHsBoot, hscSourceString ) import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) @@ -90,15 +94,14 @@ import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) import FiniteMap ( FiniteMap ) import CoreSyn ( IdCoreRule ) -import PrelNames ( isBuiltInSyntaxName ) -import Maybes ( orElse ) +import Maybes ( orElse, fromJust, expectJust ) import Outputable -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcSpan ) import UniqSupply ( UniqSupply ) -import Maybe ( fromJust ) import FastString ( FastString ) import DATA_IOREF ( IORef, readIORef ) +import StringBuffer ( StringBuffer ) import Time ( ClockTime ) \end{code} @@ -122,10 +125,17 @@ data HscEnv -- are compiling right now. -- (In one-shot mode the current module is the only -- home-package module, so hsc_HPT is empty. All other - -- modules count as "external-package" modules.) + -- modules count as "external-package" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loadeded into the external-package table.) + -- -- hsc_HPT is not mutable because we only demand-load -- external packages; the home package is eagerly - -- loaded by the compilation manager. + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by --make + -- but not actually below the current module in the dependency + -- graph. (This changes a previous invariant: changed Jan 05.) -- The next two are side-effected by compiling -- to reflect sucking in interface files @@ -139,8 +149,15 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env) The GhciMode is self-explanatory: \begin{code} -data GhciMode = Batch | Interactive | OneShot +data GhciMode = Batch -- ghc --make Main + | Interactive -- ghc --interactive + | OneShot -- ghc Foo.hs + | IDE -- Visual Studio etc deriving Eq + +isOneShot :: GhciMode -> Bool +isOneShot OneShot = True +isOneShot _other = False \end{code} \begin{code} @@ -152,8 +169,6 @@ emptyPackageIfaceTable = emptyModuleEnv data HomeModInfo = HomeModInfo { hm_iface :: ModIface, - hm_globals :: Maybe GlobalRdrEnv, -- Its top level environment - -- Nothing <-> compiled module hm_details :: ModDetails, hm_linkable :: Linkable } \end{code} @@ -168,21 +183,46 @@ lookupIface hpt pit mod Just mod_info -> Just (hm_iface mod_info) Nothing -> lookupModuleEnv pit mod -lookupIfaceByModName :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface +lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface -- We often have two IfaceTables, and want to do a lookup -lookupIfaceByModName hpt pit mod - = case lookupModuleEnvByName hpt mod of +lookupIfaceByModule hpt pit mod + = case lookupModuleEnv hpt mod of Just mod_info -> Just (hm_iface mod_info) - Nothing -> lookupModuleEnvByName pit mod + Nothing -> lookupModuleEnv pit mod \end{code} + \begin{code} --- Use instead of Finder.findModule if possible: this way doesn't --- require filesystem operations, and it is guaranteed not to fail --- when the IfaceTables are properly populated (i.e. after the renamer). -moduleNameToModule :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Module -moduleNameToModule hpt pit mod - = mi_module (fromJust (lookupIfaceByModName hpt pit mod)) +hptInstances :: HscEnv -> (Module -> Bool) -> [DFunId] +-- Find all the instance declarations that are in modules imported +-- by this one, directly or indirectly, and are in the Home Package Table +-- This ensures that we don't see instances from modules --make compiled +-- before this one, but which are not below this one +hptInstances hsc_env want_this_module + = [ dfun + | mod_info <- moduleEnvElts (hsc_HPT hsc_env) + , want_this_module (mi_module (hm_iface mod_info)) + , dfun <- md_insts (hm_details mod_info) ] + +hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [IdCoreRule] +-- Get rules from modules "below" this one (in the dependency sense) +-- C.f Inst.hptInstances +hptRules hsc_env deps + | isOneShot (hsc_mode hsc_env) = [] + | otherwise + = let + hpt = hsc_HPT hsc_env + in + [ rule + | -- Find each non-hi-boot module below me + (mod, False) <- deps + + -- Look it up in the HPT + , let mod_info = ASSERT( mod `elemModuleEnv` hpt ) + fromJust (lookupModuleEnv hpt mod) + + -- And get its dfuns + , rule <- md_rules (hm_details mod_info) ] \end{code} @@ -204,7 +244,7 @@ the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface = ModIface { - mi_package :: !PackageName, -- Which package the module comes from + mi_package :: !PackageIdH, -- Which package the module comes from mi_module :: !Module, mi_mod_vers :: !Version, -- Module version: changes when anything changes @@ -232,7 +272,7 @@ data ModIface -- NOT STRICT! we read this field lazily from the interface file -- Deprecations - mi_deprecs :: Deprecs [(OccName,DeprecTxt)], + mi_deprecs :: IfaceDeprecs, -- NOT STRICT! we read this field lazily from the interface file -- Type, class and variable declarations @@ -242,6 +282,11 @@ data ModIface -- the version of the parent class/tycon changes mi_decls :: [(Version,IfaceDecl)], -- Sorted + mi_globals :: !(Maybe GlobalRdrEnv), + -- Its top level environment or Nothing if we read this + -- interface from an interface file. (We need the source + -- file to figure out the top-level environment.) + -- Instance declarations and rules mi_insts :: [IfaceInst], -- Sorted mi_rules :: [IfaceRule], -- Sorted @@ -275,7 +320,8 @@ data ModDetails data ModGuts = ModGuts { mg_module :: !Module, - mg_exports :: !Avails, -- What it exports + mg_boot :: IsBootInterface, -- Whether it's an hs-boot module + mg_exports :: !NameSet, -- What it exports mg_deps :: !Dependencies, -- What is below it, directly or otherwise mg_dir_imps :: ![Module], -- Directly-imported modules; used to -- generate initialisation code @@ -340,10 +386,10 @@ data ForeignStubs = NoStubs \end{code} \begin{code} -emptyModIface :: PackageName -> ModuleName -> ModIface +emptyModIface :: PackageIdH -> Module -> ModIface emptyModIface pkg mod = ModIface { mi_package = pkg, - mi_module = mkModule pkg mod, + mi_module = mod, mi_mod_vers = initialVersion, mi_orphan = False, mi_boot = False, @@ -356,6 +402,7 @@ emptyModIface pkg mod mi_insts = [], mi_rules = [], mi_decls = [], + mi_globals = Nothing, mi_rule_vers = initialVersion, mi_dep_fn = emptyIfaceDepCache, mi_fix_fn = emptyIfaceFixCache, @@ -405,22 +452,16 @@ the @Name@'s provenance to guide whether or not to print the name qualified in error messages. \begin{code} -unQualInScope :: GlobalRdrEnv -> Name -> Bool +unQualInScope :: GlobalRdrEnv -> PrintUnqualified -- True if 'f' is in scope, and has only one binding, -- and the thing it is bound to is the name we are looking for -- (i.e. false if A.f and B.f are both in scope as unqualified 'f') -- --- Also checks for built-in syntax, which is always 'in scope' --- --- This fn is only efficient if the shared --- partial application is used a lot. -unQualInScope env - = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n - where - unqual_names :: NameSet - unqual_names = foldOccEnv add emptyNameSet env - add [gre] unquals | unQualOK gre = addOneToNameSet unquals (gre_name gre) - add _ unquals = unquals +-- [Out of date] Also checks for built-in syntax, which is always 'in scope' +unQualInScope env mod occ + = case lookupGRE_RdrName (mkRdrUnqual occ) env of + [gre] -> nameModule (gre_name gre) == mod + other -> False \end{code} @@ -431,12 +472,6 @@ unQualInScope env %************************************************************************ \begin{code} -isImplicitTyThing :: TyThing -> Bool -isImplicitTyThing (ADataCon dc) = True -isImplicitTyThing (AnId id) = isImplicitId id -isImplicitTyThing (ATyCon tc) = isClassTyCon tc -isImplicitTyThing other = False - implicitTyThings :: TyThing -> [TyThing] implicitTyThings (AnId id) = [] @@ -490,12 +525,12 @@ mkTypeEnv things = extendTypeEnvList emptyTypeEnv things lookupTypeEnv = lookupNameEnv -extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv -- Extend the type environment -extendTypeEnvList env things - = foldl extend env things - where - extend env thing = extendNameEnv env (getName thing) thing +extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv +extendTypeEnv env thing = extendNameEnv env (getName thing) thing + +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things = foldl extendTypeEnv env things \end{code} \begin{code} @@ -589,7 +624,7 @@ data GenAvailInfo name = Avail name -- An ordinary identifier deriving( Eq ) -- Equality used when deciding if the interface has changed -type IfaceExport = (ModuleName, [GenAvailInfo OccName]) +type IfaceExport = (Module, [GenAvailInfo OccName]) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl add emptyNameSet avails @@ -629,7 +664,7 @@ emptyIfaceFixCache n = defaultFixity type FixityEnv = NameEnv FixItem -- We keep the OccName in the range so that we can generate an interface from it -data FixItem = FixItem OccName Fixity SrcLoc +data FixItem = FixItem OccName Fixity SrcSpan instance Outputable FixItem where ppr (FixItem occ fix loc) = ppr fix <+> ppr occ <+> parens (ppr loc) @@ -664,16 +699,19 @@ type IsBootInterface = Bool -- in the import hierarchy. See TcRnTypes.ImportAvails for details. -- -- Invariant: the dependencies of a module M never includes M +-- Invariant: the lists are unordered, with no duplicates data Dependencies - = Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies - dep_pkgs :: [PackageName], -- External package dependencies - dep_orphs :: [ModuleName] } -- Orphan modules (whether home or external pkg) + = Deps { dep_mods :: [(Module,IsBootInterface)], -- Home-package module dependencies + dep_pkgs :: [PackageId], -- External package dependencies + dep_orphs :: [Module] } -- Orphan modules (whether home or external pkg) + deriving( Eq ) + -- Equality used only for old/new comparison in MkIface.addVersionInfo noDependencies :: Dependencies noDependencies = Deps [] [] [] data Usage - = Usage { usg_name :: ModuleName, -- Name of the module + = Usage { usg_name :: Module, -- Name of the module usg_mod :: Version, -- Module version usg_entities :: [(OccName,Version)], -- Sorted by occurrence name usg_exports :: Maybe Version, -- Export-list version, if we depend on it @@ -706,6 +744,17 @@ type PackageInstEnv = InstEnv data ExternalPackageState = EPS { + eps_is_boot :: !(ModuleEnv (Module, IsBootInterface)), + -- In OneShot mode (only), home-package modules accumulate in the + -- external package state, and are sucked in lazily. + -- For these home-pkg modules (only) we need to record which are + -- boot modules. We set this field after loading all the + -- explicitly-imported interfaces, but before doing anything else + -- + -- The Module part is not necessary, but it's useful for + -- debug prints, and it's convenient because this field comes + -- direct from TcRnTypes.ImportAvails.imp_dep_mods + eps_PIT :: !PackageIfaceTable, -- The ModuleIFaces for modules in external packages -- whose interfaces we have opened @@ -728,26 +777,24 @@ data ExternalPackageState -- Holding pens for stuff that has been read in from file, -- but not yet slurped into the renamer - eps_decls :: !DeclPool, - -- A single, global map of Names to unslurped decls - -- Decls move from here to eps_PTE - eps_insts :: !InstPool, -- The as-yet un-slurped instance decls -- Decls move from here to eps_inst_env -- Each instance is 'gated' by the names that must be -- available before this instance decl is needed. - eps_rules :: !RulePool - -- Rules move from here to eps_rule_base when - -- all their LHS free vars are in the eps_PTE - -- To maintain this invariant, we need to check the pool - -- a) when adding to the rule pool by loading an interface - -- (some of the new rules may alrady have all their - -- gates in the eps_PTE) - -- b) when extending the eps_PTE when we load a decl - -- from the eps_decls pool + eps_rules :: !RulePool, + -- The as-yet un-slurped rules + + eps_stats :: !EpsStats } + +-- "In" means read from iface files +-- "Out" means actually sucked in and type-checked +data EpsStats = EpsStats { n_ifaces_in + , n_decls_in, n_decls_out + , n_rules_in, n_rules_out + , n_insts_in, n_insts_out :: !Int } \end{code} The NameCache makes sure that there is just one Unique assigned for @@ -777,42 +824,111 @@ type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) \end{code} \begin{code} -data Pool p = Pool (NameEnv p) -- The pool itself, indexed by some primary key - Int -- Number of decls slurped into the map - Int -- Number of decls slurped out of the map +type Gated d = ([Name], (Module, SDoc, d)) + -- The [Name] 'gate' the declaration; always non-empty + -- Module records which module this decl belongs to + -- SDoc records the pathname of the file, or similar err-ctxt info -emptyPool = Pool emptyNameEnv 0 0 +type RulePool = [Gated IfaceRule] -instance Outputable p => Outputable (Pool p) where - ppr (Pool p n_in n_out) -- Debug printing only - = vcat [ptext SLIT("Pool") <+> int n_in <+> int n_out, - nest 2 (ppr p)] - -type DeclPool = Pool IfaceDecl +addRulesToPool :: RulePool + -> [Gated IfaceRule] + -> RulePool +addRulesToPool rules new_rules = new_rules ++ rules ------------------------- -type Gated d = ([Name], (ModuleName, d)) -- The [Name] 'gate' the declaration - -- ModuleName records which iface file this - -- decl came from - -type RulePool = Pool [Gated IfaceRule] - -addRuleToPool :: NameEnv [Gated IfaceRule] - -> (ModuleName, IfaceRule) - -> [Name] -- Free vars of rule; always non-empty - -> NameEnv [Gated IfaceRule] -addRuleToPool rules rule (fv:fvs) = extendNameEnv_C combine rules fv [(fvs,rule)] - where - combine old _ = (fvs,rule) : old +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } ------------------------- -type InstPool = Pool [Gated IfaceInst] +type InstPool = NameEnv [Gated IfaceInst] -- The key of the Pool is the Class -- The Names are the TyCons in the instance head -- 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. + + +addInstsToPool :: InstPool -> [(Name, Gated IfaceInst)] -> InstPool +addInstsToPool insts new_insts + = foldr add insts new_insts + where + add :: (Name, Gated IfaceInst) -> NameEnv [Gated IfaceInst] -> NameEnv [Gated IfaceInst] + add (cls,new_inst) insts = extendNameEnv_C combine insts cls [new_inst] + where + combine old_insts _ = new_inst : old_insts +\end{code} + + +%************************************************************************ +%* * + The ModSummary type + A ModSummary is a node in the compilation manager's + dependency graph, and it's also passed to hscMain +%* * +%************************************************************************ + +The nodes of the module graph are + EITHER a regular Haskell source module + OR a hi-boot source module + +\begin{code} +data ModSummary + = ModSummary { + ms_mod :: Module, -- Name of the module + ms_hsc_src :: HscSource, -- Source is Haskell, hs-boot, external core + ms_location :: ModLocation, -- Location + ms_hs_date :: ClockTime, -- Timestamp of summarised file + ms_srcimps :: [Module], -- Source imports + ms_imps :: [Module], -- Non-source imports + ms_hspp_file :: Maybe FilePath, -- Filename of preprocessed source, + -- once we have preprocessed it. + ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe. + } + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_date and imports can, of course, change + +msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) + + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +showModMsg :: Bool -> ModSummary -> String +showModMsg use_object mod_summary + = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), + char '(', text (msHsFilePath mod_summary) <> comma, + if use_object then text (msObjFilePath mod_summary) + else text "interpreted", + char ')']) + where + mod = ms_mod mod_summary + mod_str = moduleUserString mod ++ hscSourceString (ms_hsc_src mod_summary) \end{code} @@ -830,7 +946,7 @@ data Linkable = LM { linkableTime :: ClockTime, -- Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files) - linkableModName :: ModuleName, -- Should be Module, but see below + linkableModule :: Module, -- Should be Module, but see below linkableUnlinked :: [Unlinked] }