X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=c5483b90e197d605d196dafdc8bd10ea4ef938b0;hp=a200bf99ca31c01dc883d79d262be71803d7e00f;hb=4287edeb7f329529149d8c95597d5e418388265f;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index a200bf9..c5483b9 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1,5 +1,5 @@ - -% (c) The University of Glasgow, 2000 +% +% (c) The University of Glasgow, 2006 % \section[HscTypes]{Types for the per-module compiler} @@ -30,23 +30,24 @@ module HscTypes ( icPrintUnqual, mkPrintUnqualified, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, - emptyIfaceDepCache, + emptyIfaceDepCache, Deprecs(..), IfaceDeprecs, FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - implicitTyThings, + implicitTyThings, isImplicitTyThing, TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, + typeEnvDataCons, WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, NameCache(..), OrigNameCache, OrigIParamCache, - Avails, availsToNameSet, availName, availNames, + Avails, availsToNameSet, availsToNameEnv, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, IfaceExport, @@ -77,23 +78,22 @@ import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, extendOccEnv ) import Module import InstEnv ( InstEnv, Instance ) +import FamInstEnv ( FamInstEnv, FamInst ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) -import Id ( Id ) +import Id ( Id, isImplicitId ) import Type ( TyThing(..) ) -import Class ( Class, classSelIds, classTyCon ) -import TyCon ( TyCon, tyConSelIds, tyConDataCons ) -import DataCon ( dataConImplicitIds ) +import Class ( Class, classSelIds, classATs, classTyCon ) +import TyCon +import DataCon ( DataCon, dataConImplicitIds ) import PrelNames ( gHC_PRIM ) import Packages ( PackageId ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) - -import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) - +import IfaceSyn import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) import Maybes ( orElse, expectJust ) @@ -103,9 +103,11 @@ import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString ( FastString ) -import DATA_IOREF ( IORef, readIORef ) import StringBuffer ( StringBuffer ) -import Time ( ClockTime ) +import Maybes ( catMaybes, seqMaybe ) + +import System.Time ( ClockTime ) +import Data.IORef ( IORef, readIORef ) \end{code} @@ -242,12 +244,21 @@ lookupIfaceByModule -> Module -> Maybe ModIface lookupIfaceByModule dflags hpt pit mod - -- in one-shot, we don't use the HPT - | not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg - = fmap hm_iface (lookupUFM hpt (moduleName mod)) - | otherwise - = lookupModuleEnv pit mod - where this_pkg = thisPackage dflags + | modulePackageId mod == thisPackage dflags + = -- The module comes from the home package, so look first + -- in the HPT. If it's not from the home package it's wrong to look + -- in the HPT, because the HPT is indexed by *ModuleName* not Module + fmap hm_iface (lookupUFM hpt (moduleName mod)) + `seqMaybe` lookupModuleEnv pit mod + + | otherwise = lookupModuleEnv pit mod -- Look in PIT only + +-- If the module does come from the home package, why do we look in the PIT as well? +-- (a) In OneShot mode, even home-package modules accumulate in the PIT +-- (b) Even in Batch (--make) mode, there is *one* case where a home-package +-- module is in the PIT, namely GHC.Prim when compiling the base package. +-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a packake +-- of its own, but it doesn't seem worth the bother. \end{code} @@ -323,8 +334,8 @@ data FindResult | ModuleHidden PackageId -- for an explicit source import: the package containing the module is -- exposed, but the module itself is hidden. - | NotFound [FilePath] - -- the module was not found, the specified places were searched. + | NotFound [FilePath] (Maybe PackageId) + -- the module was not found, the specified places were searched | NotFoundInPackage PackageId -- the module was not found in this package @@ -356,6 +367,7 @@ data ModIface mi_mod_vers :: !Version, -- Module version: changes when anything changes mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans + mi_finsts :: !WhetherHasFamInst, -- Whether module has family insts mi_boot :: !IsBootInterface, -- Read from an hi-boot file? mi_deps :: Dependencies, @@ -405,35 +417,42 @@ data ModIface -- HomeModInfo, but that leads to more plumbing. -- Instance declarations and rules - mi_insts :: [IfaceInst], -- Sorted - mi_rules :: [IfaceRule], -- Sorted - mi_rule_vers :: !Version, -- Version number for rules and instances combined + mi_insts :: [IfaceInst], -- Sorted + mi_fam_insts :: [IfaceFamInst], -- Sorted + mi_rules :: [IfaceRule], -- Sorted + mi_rule_vers :: !Version, -- Version number for rules and + -- instances (for classes and families) + -- combined -- Cached environments for easy lookup -- These are computed (lazily) from other fields -- and are not put into the interface file mi_dep_fn :: Name -> Maybe DeprecTxt, -- Cached lookup for mi_deprecs mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities - mi_ver_fn :: OccName -> Maybe Version -- Cached lookup for mi_decls + mi_ver_fn :: OccName -> Maybe (OccName, Version) + -- Cached lookup for mi_decls -- The Nothing in mi_ver_fn means that the thing -- isn't in decls. It's useful to know that when -- seeing if we are up to date wrt the old interface + -- The 'OccName' is the parent of the name, if it has one. } -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails = ModDetails { - -- The next three fields are created by the typechecker - md_exports :: NameSet, - md_types :: !TypeEnv, - md_insts :: ![Instance], -- Dfun-ids for the instances in this module - md_rules :: ![CoreRule] -- Domain may include Ids from other modules + -- The next two fields are created by the typechecker + md_exports :: [AvailInfo], + md_types :: !TypeEnv, + md_insts :: ![Instance], -- Dfun-ids for the instances in this module + md_fam_insts :: ![FamInst], + md_rules :: ![CoreRule] -- Domain may include Ids from other modules } emptyModDetails = ModDetails { md_types = emptyTypeEnv, - md_exports = emptyNameSet, - md_insts = [], - md_rules = [] } + md_exports = [], + md_insts = [], + md_rules = [], + md_fam_insts = [] } -- A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module @@ -442,23 +461,26 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, data ModGuts = ModGuts { - mg_module :: !Module, - 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 - mg_usages :: ![Usage], -- Version info for what it needed - - mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment - mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module - mg_deprecs :: !Deprecations, -- Deprecations declared in the module - - mg_types :: !TypeEnv, - mg_insts :: ![Instance], -- Instances - mg_rules :: ![CoreRule], -- Rules from this module - mg_binds :: ![CoreBind], -- Bindings for this module - mg_foreign :: !ForeignStubs + mg_module :: !Module, + mg_boot :: IsBootInterface, -- Whether it's an hs-boot module + mg_exports :: ![AvailInfo], -- 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 + mg_usages :: ![Usage], -- Version info for what it needed + + mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment + mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in + -- this module + mg_deprecs :: !Deprecations, -- Deprecations declared in the module + + mg_types :: !TypeEnv, + mg_insts :: ![Instance], -- Instances + mg_fam_insts :: ![FamInst], -- Instances + mg_rules :: ![CoreRule], -- Rules from this module + mg_binds :: ![CoreBind], -- Bindings for this module + mg_foreign :: !ForeignStubs } -- The ModGuts takes on several slightly different forms: @@ -530,6 +552,7 @@ emptyModIface mod = ModIface { mi_module = mod, mi_mod_vers = initialVersion, mi_orphan = False, + mi_finsts = False, mi_boot = False, mi_deps = noDependencies, mi_usages = [], @@ -537,10 +560,11 @@ emptyModIface mod mi_exp_vers = initialVersion, mi_fixities = [], mi_deprecs = NoDeprecs, - mi_insts = [], - mi_rules = [], - mi_decls = [], - mi_globals = Nothing, + mi_insts = [], + mi_fam_insts = [], + mi_rules = [], + mi_decls = [], + mi_globals = Nothing, mi_rule_vers = initialVersion, mi_dep_fn = emptyIfaceDepCache, mi_fix_fn = emptyIfaceFixCache, @@ -618,24 +642,44 @@ mkPrintUnqualified env = (qual_name, qual_mod) \begin{code} implicitTyThings :: TyThing -> [TyThing] +-- If you change this, make sure you change LoadIface.ifaceDeclSubBndrs in sync + implicitTyThings (AnId id) = [] -- For type constructors, add the data cons (and their extras), -- and the selectors and generic-programming Ids too -- -- Newtypes don't have a worker Id, so don't generate that? -implicitTyThings (ATyCon tc) = map AnId (tyConSelIds tc) ++ - concatMap (extras_plus . ADataCon) (tyConDataCons tc) +implicitTyThings (ATyCon tc) = implicitCoTyCon tc ++ + map AnId (tyConSelIds tc) ++ + concatMap (extras_plus . ADataCon) + (tyConDataCons tc) -- For classes, add the class TyCon too (and its extras) - -- and the class selector Ids + -- and the class selector Ids and the associated types (they don't + -- have extras as these are only the family decls) implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ + map ATyCon (classATs cl) ++ extras_plus (ATyCon (classTyCon cl)) - -- For data cons add the worker and wrapper (if any) implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) +-- | returns 'True' if there should be no interface-file declaration +-- for this thing on its own: either it is built-in, or it is part +-- of some other declaration, or it is generated implicitly by some +-- other declaration. +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (ADataCon _) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (AClass _) = False +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc + + -- For newtypes and indexed data types, add the implicit coercion tycon +implicitCoTyCon tc + = map ATyCon . catMaybes $ [newTyConCo_maybe tc, + tyConFamilyCoercion_maybe tc] + extras_plus thing = thing : implicitTyThings thing extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv @@ -652,18 +696,20 @@ extendTypeEnvWithIds env ids \begin{code} type TypeEnv = NameEnv TyThing -emptyTypeEnv :: TypeEnv -typeEnvElts :: TypeEnv -> [TyThing] -typeEnvClasses :: TypeEnv -> [Class] -typeEnvTyCons :: TypeEnv -> [TyCon] -typeEnvIds :: TypeEnv -> [Id] -lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing - -emptyTypeEnv = emptyNameEnv -typeEnvElts env = nameEnvElts env -typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] -typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] -typeEnvIds env = [id | AnId id <- typeEnvElts env] +emptyTypeEnv :: TypeEnv +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvClasses :: TypeEnv -> [Class] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvIds :: TypeEnv -> [Id] +typeEnvDataCons :: TypeEnv -> [DataCon] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing + +emptyTypeEnv = emptyNameEnv +typeEnvElts env = nameEnvElts env +typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] +typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] mkTypeEnv :: [TyThing] -> TypeEnv mkTypeEnv things = extendTypeEnvList emptyTypeEnv things @@ -696,7 +742,6 @@ lookupType dflags hpt pte name this_pkg = thisPackage dflags \end{code} - \begin{code} tyThingTyCon (ATyCon tc) = tc tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) @@ -721,14 +766,19 @@ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere \begin{code} -mkIfaceVerCache :: [(Version,IfaceDecl)] -> OccName -> Maybe Version +mkIfaceVerCache :: [(Version,IfaceDecl)] + -> (OccName -> Maybe (OccName, Version)) mkIfaceVerCache pairs = \occ -> lookupOccEnv env occ where - env = foldl add emptyOccEnv pairs - add env (v,d) = extendOccEnv env (ifName d) v + env = foldr add_decl emptyOccEnv pairs + add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d) + where + decl_name = ifName d + env1 = extendOccEnv env0 decl_name (decl_name, v) + add_imp bndr env = extendOccEnv env bndr (decl_name, v) -emptyIfaceVerCache :: OccName -> Maybe Version +emptyIfaceVerCache :: OccName -> Maybe (OccName, Version) emptyIfaceVerCache occ = Nothing ------------------ Deprecations ------------------------- @@ -787,9 +837,13 @@ data GenAvailInfo name = Avail name -- An ordinary identifier type IfaceExport = (Module, [GenAvailInfo OccName]) availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldl add emptyNameSet avails - where - add set avail = addListToNameSet set (availNames avail) +availsToNameSet avails = foldr add emptyNameSet avails + where add avail set = addListToNameSet set (availNames avail) + +availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo +availsToNameEnv avails = foldr add emptyNameEnv avails + where add avail env = extendNameEnvList env + (zip (availNames avail) (repeat avail)) availName :: GenAvailInfo name -> name availName (Avail n) = n @@ -803,11 +857,8 @@ 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 +pprAvail (Avail n) = ppr n +pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns))) \end{code} \begin{code} @@ -853,27 +904,38 @@ type WhetherHasOrphans = Bool -- * a transformation rule in a module other than the one defining -- the function in the head of the rule. +type WhetherHasFamInst = Bool -- This module defines family instances? + type IsBootInterface = Bool -- Dependency info about modules and packages below this one -- in the import hierarchy. See TcRnTypes.ImportAvails for details. +-- The orphan modules in `dep_orphs' do *not* include family instance orphans, +-- as they are anyway included in `dep_finsts'. -- -- 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 :: [PackageId], -- External package dependencies - dep_orphs :: [Module] } -- Orphan modules (whether home or external pkg) + = Deps { dep_mods :: [(ModuleName, -- Home-package module dependencies + IsBootInterface)] + , dep_pkgs :: [PackageId] -- External package dependencies + , dep_orphs :: [Module] -- Orphan modules (whether home or + -- external pkg) + , dep_finsts :: [Module] -- Modules that contain family + -- instances (whether home or + -- external pkg) + } deriving( Eq ) -- Equality used only for old/new comparison in MkIface.addVersionInfo noDependencies :: Dependencies -noDependencies = Deps [] [] [] +noDependencies = Deps [] [] [] [] data Usage = Usage { usg_name :: ModuleName, -- Name of the module usg_mod :: Version, -- Module version usg_entities :: [(OccName,Version)], -- Sorted by occurrence name + -- NB. usages are for parent names only, eg. tycon but not constructors. usg_exports :: Maybe Version, -- Export-list version, if we depend on it usg_rules :: Version -- Orphan-rules version (for non-orphan -- modules this will always be initialVersion) @@ -905,9 +967,10 @@ data Usage %************************************************************************ \begin{code} -type PackageTypeEnv = TypeEnv -type PackageRuleBase = RuleBase -type PackageInstEnv = InstEnv +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv +type PackageFamInstEnv = FamInstEnv data ExternalPackageState = EPS { @@ -928,8 +991,8 @@ data ExternalPackageState -- The ModuleIFaces for modules in external packages -- whose interfaces we have opened -- The declarations in these interface files are held in - -- eps_decls, eps_inst_env, eps_rules (below), not in the - -- mi_decls fields of the iPIT. + -- eps_decls, eps_inst_env, eps_fam_inst_env, eps_rules + -- (below), not in the mi_decls fields of the iPIT. -- What _is_ in the iPIT is: -- * The Module -- * Version info @@ -937,11 +1000,16 @@ data ExternalPackageState -- * Fixities -- * Deprecations - eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules + eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules + + eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated + -- from all the external-package + -- modules + eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv + eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv - eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated from - -- all the external-package modules - eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- identifies family + -- instances of each mod eps_stats :: !EpsStats } @@ -1064,7 +1132,7 @@ showModMsg target recomp mod_summary _other -> text (msObjFilePath mod_summary), char ')']) where - mod = ms_mod mod_summary + mod = moduleName (ms_mod mod_summary) mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) \end{code}