X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=2c6d426099e300f489f378d3e0a17c6a36b35259;hp=eeea9d9f7317a71cf45e0b64ab82ab5a948183f8;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hpb=74da1264ba27c992e331b821c27b5d048c8d33cb diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index eeea9d9..2c6d426 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -13,7 +13,8 @@ module HscTypes ( ModuleGraph, emptyMG, ModDetails(..), emptyModDetails, - ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..), + ModGuts(..), CoreModule(..), CgGuts(..), ModImports(..), ForeignStubs(..), + ImportedMods, ModSummary(..), ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, @@ -21,7 +22,7 @@ module HscTypes ( HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, + hptInstances, hptRules, hptVectInfo, ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -29,11 +30,10 @@ module HscTypes ( InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, + substInteractiveContext, - ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, - emptyIfaceDepCache, - - Deprecs(..), IfaceDeprecs, + ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, + emptyIfaceWarnCache, FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, @@ -52,7 +52,7 @@ module HscTypes ( GenAvailInfo(..), AvailInfo, RdrAvailInfo, IfaceExport, - Deprecations, DeprecTxt, plusDeprecs, + Warnings(..), WarningTxt(..), plusWarns, PackageInstEnv, PackageRuleBase, @@ -60,7 +60,7 @@ module HscTypes ( Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, - HpcInfo(..), noHpcInfo, + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, -- Breakpoints ModBreaks (..), BreakIndex, emptyModBreaks, @@ -77,9 +77,7 @@ import ByteCodeAsm ( CompiledByteCode ) import {-# SOURCE #-} InteractiveEval ( Resume ) #endif -import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..), - unQualOK, ImpDeclSpec(..), Provenance(..), - ImportSpec(..), lookupGlobalRdrEnv ) +import RdrName import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet @@ -90,35 +88,40 @@ import InstEnv ( InstEnv, Instance ) import FamInstEnv ( FamInstEnv, FamInst ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) +import VarEnv import VarSet +import Var import Id -import Type ( TyThing(..) ) +import Type import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon -import DataCon ( DataCon, dataConImplicitIds ) +import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) -import Packages ( PackageId ) +import Packages hiding ( Version(..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) -import BasicTypes ( Version, initialVersion, IPName, - Fixity, defaultFixity, DeprecTxt ) +import BasicTypes ( IPName, Fixity, defaultFixity, WarningTxt(..) ) +import OptimizationFuel ( OptFuelState ) import IfaceSyn import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) -import Maybes ( orElse, expectJust, catMaybes, seqMaybe ) +import Maybes ( orElse, expectJust, catMaybes ) import Outputable import BreakArray import SrcLoc ( SrcSpan, Located ) -import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) +import LazyUniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) -import FastString ( FastString ) - +import FastString import StringBuffer ( StringBuffer ) +import Fingerprint +import System.FilePath import System.Time ( ClockTime ) import Data.IORef import Data.Array ( Array, array ) +import Data.List +import Control.Monad ( mplus ) \end{code} @@ -198,6 +201,15 @@ data HscEnv -- The finder's cache. This caches the location of modules, -- so we don't have to search the filesystem multiple times. + hsc_OptFuel :: OptFuelState, + -- Settings to control the use of optimization fuel: + -- by limiting the number of transformations, + -- we can use binary search to help find compiler bugs. + + hsc_type_env_var :: Maybe (Module, IORef TypeEnv), + -- Used for one-shot compilation only, to initialise + -- the IfGblEnv. See TcRnTypes.TcGblEnv.tcg_type_env_var + hsc_global_rdr_env :: GlobalRdrEnv, hsc_global_type_env :: TypeEnv } @@ -229,6 +241,7 @@ pprTarget (Target id _) = pprTargetId id instance Outputable Target where ppr = pprTarget +pprTargetId :: TargetId -> SDoc pprTargetId (TargetModule m) = ppr m pprTargetId (TargetFile f _) = text f @@ -241,7 +254,10 @@ type HomePackageTable = ModuleNameEnv HomeModInfo type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported packages +emptyHomePackageTable :: HomePackageTable emptyHomePackageTable = emptyUFM + +emptyPackageIfaceTable :: PackageIfaceTable emptyPackageIfaceTable = emptyModuleEnv data HomeModInfo @@ -272,7 +288,7 @@ lookupIfaceByModule dflags hpt pit mod -- 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 + `mplus` lookupModuleEnv pit mod | otherwise = lookupModuleEnv pit mod -- Look in PIT only @@ -280,7 +296,7 @@ lookupIfaceByModule dflags hpt pit mod -- (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 +-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. \end{code} @@ -324,12 +340,21 @@ hptRules hsc_env deps , let rules = case lookupUFM hpt mod of Just info -> md_rules (hm_details info) Nothing -> pprTrace "WARNING in hptRules" msg [] - msg = vcat [ptext SLIT("missing module") <+> ppr mod, - ptext SLIT("Probable cause: out-of-date interface files")] + msg = vcat [ptext (sLit "missing module") <+> ppr mod, + ptext (sLit "Probable cause: out-of-date interface files")] -- This really shouldn't happen, but see Trac #962 -- And get its dfuns , rule <- rules ] + +hptVectInfo :: HscEnv -> VectInfo +-- Get the combined VectInfo of all modules in the home package table. In +-- contrast to instances and rules, we don't care whether the modules are +-- "below" or us. The VectInfo of those modules not "below" us does not +-- affect the compilation of the current module. +hptVectInfo hsc_env + = foldr plusVectInfo noVectInfo [ md_vect_info (hm_details mod_info) + | mod_info <- eltsUFM (hsc_HPT hsc_env)] \end{code} %************************************************************************ @@ -356,7 +381,7 @@ data FindResult | NoPackage PackageId -- the requested package was not found | FoundMultiple [PackageId] - -- *error*: both in multiple packages + -- _error_: both in multiple packages | PackageHidden PackageId -- for an explicit source import: the package containing the module is -- not exposed. @@ -393,7 +418,8 @@ the declarations into a single indexed map in the @PersistentRenamerState@. data ModIface = ModIface { mi_module :: !Module, - mi_mod_vers :: !Version, -- Module version: changes when anything changes + mi_iface_hash :: !Fingerprint, -- Hash of the whole interface + mi_mod_hash :: !Fingerprint, -- Hash of the ABI only mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans mi_finsts :: !WhetherHasFamInst, -- Whether module has family insts @@ -405,7 +431,7 @@ data ModIface -- Usages; kept sorted so that it's easy to decide -- whether to write a new iface file (changing usages - -- doesn't affect the version of this module) + -- doesn't affect the hash of this module) mi_usages :: [Usage], -- NOT STRICT! we read this field lazily from the interface file -- It is *only* consulted by the recompilation checker @@ -413,22 +439,22 @@ data ModIface -- Exports -- Kept sorted by (mod,occ), to make version comparisons easier mi_exports :: ![IfaceExport], - mi_exp_vers :: !Version, -- Version number of export list + mi_exp_hash :: !Fingerprint, -- Hash of export list -- Fixities mi_fixities :: [(OccName,Fixity)], -- NOT STRICT! we read this field lazily from the interface file - -- Deprecations - mi_deprecs :: IfaceDeprecs, + -- Warnings + mi_warns :: Warnings, -- NOT STRICT! we read this field lazily from the interface file -- Type, class and variable declarations - -- The version of an Id changes if its fixity or deprecations change + -- The hash of an Id changes if its fixity or deprecations change -- (as well as its type of course) -- Ditto data constructors, class operations, except that - -- the version of the parent class/tycon changes - mi_decls :: [(Version,IfaceDecl)], -- Sorted + -- the hash of the parent class/tycon changes + mi_decls :: [(Fingerprint,IfaceDecl)], -- Sorted mi_globals :: !(Maybe GlobalRdrEnv), -- Binds all the things defined at the top level in @@ -449,7 +475,7 @@ data ModIface mi_insts :: [IfaceInst], -- Sorted mi_fam_insts :: [IfaceFamInst], -- Sorted mi_rules :: [IfaceRule], -- Sorted - mi_rule_vers :: !Version, -- Version number for rules and + mi_orphan_hash :: !Fingerprint, -- Hash for orphan rules and -- instances (for classes and families) -- combined @@ -459,14 +485,16 @@ data ModIface -- 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_warn_fn :: Name -> Maybe WarningTxt, -- Cached lookup for mi_warns mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities - mi_ver_fn :: OccName -> Maybe (OccName, Version) + mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint), -- Cached lookup for mi_decls - -- The Nothing in mi_ver_fn means that the thing + -- The Nothing in mi_hash_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. + mi_hpc :: !AnyHpcUsage + -- True if this program uses Hpc at any point in the program. } -- Should be able to construct ModDetails from mi_decls in ModIface @@ -475,24 +503,28 @@ data ModDetails -- 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_insts :: ![Instance], -- Dfun-ids for the instances in this module md_fam_insts :: ![FamInst], - md_rules :: ![CoreRule], -- Domain may include Ids from other modules - md_modBreaks :: !ModBreaks -- breakpoint information for this module + md_rules :: ![CoreRule], -- Domain may include Ids from other modules + md_vect_info :: !VectInfo -- Vectorisation information } +emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_exports = [], md_insts = [], md_rules = [], md_fam_insts = [], - md_modBreaks = emptyModBreaks } + md_vect_info = noVectInfo + } -- 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 -- being compiled right now. Once it is compiled, a ModIface and -- ModDetails are extracted and the ModGuts is dicarded. +type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)] + data ModGuts = ModGuts { mg_module :: !Module, @@ -500,30 +532,56 @@ data ModGuts 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 + mg_dir_imps :: !ImportedMods, -- Directly-imported modules; used to -- generate initialisation code - mg_usages :: ![Usage], -- Version info for what it needed + mg_used_names:: !NameSet, -- What it needed (used in mkIface) mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment - mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in - -- this module - - mg_fam_inst_env :: FamInstEnv, -- Type-family instance enviroment - -- for *home-package* modules (including - -- this one). c.f. tcg_fam_inst_env + -- These fields all describe the things **declared in this module** + mg_fix_env :: !FixityEnv, -- Fixities 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, - mg_deprecs :: !Deprecations, -- Deprecations declared in the module + mg_warns :: !Warnings, -- Warnings declared in the module mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes mg_modBreaks :: !ModBreaks, - mg_vect_info :: !VectInfo -- Pool of vectorised declarations + mg_vect_info :: !VectInfo, -- Pool of vectorised declarations + + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + mg_inst_env :: InstEnv, + -- ^ Class instance enviroment from /home-package/ modules (including + -- this one); c.f. tcg_inst_env + mg_fam_inst_env :: FamInstEnv + -- ^ Type-family instance enviroment for /home-package/ modules + -- (including this one); c.f. tcg_fam_inst_env + } + +-- A CoreModule consists of just the fields of a ModGuts that are needed for +-- the compileToCoreModule interface. +data CoreModule + = CoreModule { + -- Module name + cm_module :: !Module, + -- Type environment for types declared in this module + cm_types :: !TypeEnv, + -- Declarations + cm_binds :: [CoreBind], + -- Imports + cm_imports :: ![Module] } +instance Outputable CoreModule where + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = + text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) + -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly: @@ -559,7 +617,8 @@ data CgGuts cg_foreign :: !ForeignStubs, cg_dep_pkgs :: ![PackageId], -- Used to generate #includes for C code gen - cg_hpc_info :: !HpcInfo -- info about coverage tick boxes + cg_hpc_info :: !HpcInfo, -- info about coverage tick boxes + cg_modBreaks :: !ModBreaks } ----------------------------------- @@ -581,37 +640,34 @@ data ForeignStubs = NoStubs -- "foreign exported" functions SDoc -- C stubs to use when calling -- "foreign exported" functions - [FastString] -- Headers that need to be included - -- into C code generated for this module - [Id] -- Foreign-exported binders - -- we have to generate code to register these - \end{code} \begin{code} emptyModIface :: Module -> ModIface emptyModIface mod = ModIface { mi_module = mod, - mi_mod_vers = initialVersion, + mi_iface_hash = fingerprint0, + mi_mod_hash = fingerprint0, mi_orphan = False, mi_finsts = False, mi_boot = False, mi_deps = noDependencies, mi_usages = [], mi_exports = [], - mi_exp_vers = initialVersion, + mi_exp_hash = fingerprint0, mi_fixities = [], - mi_deprecs = NoDeprecs, + mi_warns = NoWarnings, mi_insts = [], mi_fam_insts = [], mi_rules = [], mi_decls = [], mi_globals = Nothing, - mi_rule_vers = initialVersion, + mi_orphan_hash = fingerprint0, mi_vect_info = noIfaceVectInfo, - mi_dep_fn = emptyIfaceDepCache, - mi_fix_fn = emptyIfaceFixCache, - mi_ver_fn = emptyIfaceVerCache + mi_warn_fn = emptyIfaceWarnCache, + mi_fix_fn = emptyIfaceFixCache, + mi_hash_fn = emptyIfaceHashCache, + mi_hpc = False } \end{code} @@ -650,6 +706,7 @@ data InteractiveContext } +emptyInteractiveContext :: InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], ic_exports = [], @@ -661,8 +718,8 @@ emptyInteractiveContext #endif } -icPrintUnqual :: InteractiveContext -> PrintUnqualified -icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt) +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt) extendInteractiveContext @@ -675,6 +732,22 @@ extendInteractiveContext ictxt ids tyvars -- NB. must be this way around, because we want -- new ids to shadow existing bindings. ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars } + + +substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext +substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt +substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst = + let ids' = map (\id -> id `setIdType` substTy subst (idType id)) ids + subst_dom= varEnvKeys$ getTvSubstEnv subst + subst_ran= varEnvElts$ getTvSubstEnv subst + new_tvs = [ tv | Just tv <- map getTyVar_maybe subst_ran] + ic_tyvars'= (`delVarSetListByKey` subst_dom) + . (`extendVarSetList` new_tvs) + $ ic_tyvars ictxt + in ictxt { ic_tmp_ids = ids' + , ic_tyvars = ic_tyvars' } + + where delVarSetListByKey = foldl' delVarSetByKey \end{code} %************************************************************************ @@ -683,23 +756,71 @@ extendInteractiveContext ictxt ids tyvars %* * %************************************************************************ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" + 2. there is an X for which X.T uniquely maps to P:M.T ---> "X.T" + 3. there is no binding for "M.T" ---> "M.T" + 4. otherwise ---> "P:M.T" + +3 and 4 apply when P:M.T is not in scope. In these cases we want to +refer to the name as "M.T", but "M.T" might mean something else in the +current scope (e.g. if there's an "import X as M"), so to avoid +confusion we avoid using "M.T" if there's already a binding for it. + +There's one further subtlety: if the module M cannot be imported +because it is not exposed by any package, then we must refer to it as +"P:M". This is handled by the qual_mod component of PrintUnqualified. + \begin{code} -mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified env = (qual_name, qual_mod) +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = (qual_name, qual_mod) where - qual_name mod occ - | null gres = Just (moduleName mod) - -- it isn't in scope at all, this probably shouldn't happen, - -- but we'll qualify it by the original module anyway. - | any unQualOK gres = Nothing - | (Imported is : _) <- map gre_prov gres, (idecl : _) <- is - = Just (is_as (is_decl idecl)) - | otherwise = panic "mkPrintUnqualified" + qual_name mod occ -- The (mod,occ) pair is the original name of the thing + | [gre] <- unqual_gres, right_name gre = NameUnqual + -- If there's a unique entity that's in scope unqualified with 'occ' + -- AND that entity is the right one, then we can use the unqualified name + + | [gre] <- qual_gres = NameQual (get_qual_mod (gre_prov gre)) + + | null qual_gres = + if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 + + | otherwise = panic "mkPrintUnqualified" where - gres = [ gre | gre <- lookupGlobalRdrEnv env occ, - nameModule (gre_name gre) == mod ] + right_name gre = nameModule (gre_name gre) == mod + + unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env + qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + + get_qual_mod LocalDef = moduleName mod + get_qual_mod (Imported is) = ASSERT( not (null is) ) is_as (is_decl (head is)) + + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + + qual_mod mod + | modulePackageId mod == thisPackage dflags = False + + | [pkgconfig] <- [pkg | (pkg,exposed_module) <- lookup, + exposed pkg && exposed_module], + packageConfigId pkgconfig == modulePackageId mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False - qual_mod mod = Nothing -- For now... + | otherwise = True + where lookup = lookupModuleInAllPackages dflags (moduleName mod) \end{code} @@ -710,31 +831,62 @@ mkPrintUnqualified env = (qual_name, qual_mod) %************************************************************************ \begin{code} +-- N.B. the set of TyThings returned here *must* match the set of +-- names returned by LoadIface.ifaceDeclSubBndrs, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. 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) = implicitCoTyCon tc ++ - map AnId (tyConSelIds tc) ++ - concatMap (extras_plus . ADataCon) - (tyConDataCons tc) + +-- For data and newtype declarations: +implicitTyThings (ATyCon tc) = + -- fields (names of selectors) + map AnId (tyConSelIds tc) ++ + -- (possibly) implicit coercion and family coercion + -- depending on whether it's a newtype or a family instance or both + implicitCoTyCon tc ++ + -- for each data constructor in order, + -- the contructor, worker, and (possibly) wrapper + concatMap (extras_plus . ADataCon) (tyConDataCons tc) - -- For classes, add the class selector Ids, and assoicated TyCons - -- and the class TyCon too (and its extras) implicitTyThings (AClass cl) - = map AnId (classSelIds cl) ++ + = -- dictionary datatype: + -- [extras_plus:] + -- type constructor + -- [recursive call:] + -- (possibly) newtype coercion; definitely no family coercion here + -- data constructor + -- worker + -- (no wrapper by invariant) + extras_plus (ATyCon (classTyCon cl)) ++ + -- associated types + -- No extras_plus (recursive call) for the classATs, because they + -- are only the family decls; they have no implicit things map ATyCon (classATs cl) ++ - -- No extras_plus for the classATs, because they - -- are only the family decls; they have no implicit things - extras_plus (ATyCon (classTyCon cl)) + -- superclass and operation selectors + map AnId (classSelIds cl) + +implicitTyThings (ADataCon dc) = + -- For data cons add the worker and (possibly) wrapper + map AnId (dataConImplicitIds dc) + +implicitTyThings (AnId _) = [] + +-- add a thing and recursive call +extras_plus :: TyThing -> [TyThing] +extras_plus thing = thing : implicitTyThings thing + +-- For newtypes and indexed data types (and both), +-- add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] +implicitCoTyCon tc + = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not + newTyConCo_maybe tc, + -- Just if family instance, Nothing if not + tyConFamilyCoercion_maybe tc] + +-- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y) - -- 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 @@ -746,13 +898,6 @@ 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 extendTypeEnvWithIds env ids = extendNameEnvList env [(getName id, AnId id) | id <- ids] @@ -814,32 +959,28 @@ lookupType dflags hpt pte name \end{code} \begin{code} +tyThingTyCon :: TyThing -> TyCon tyThingTyCon (ATyCon tc) = tc -tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) +tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other) +tyThingClass :: TyThing -> Class tyThingClass (AClass cls) = cls -tyThingClass other = pprPanic "tyThingClass" (ppr other) +tyThingClass other = pprPanic "tyThingClass" (pprTyThing other) +tyThingDataCon :: TyThing -> DataCon tyThingDataCon (ADataCon dc) = dc -tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) +tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other) -tyThingId (AnId id) = id -tyThingId other = pprPanic "tyThingId" (ppr other) +tyThingId :: TyThing -> Id +tyThingId (AnId id) = id +tyThingId (ADataCon dc) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (pprTyThing other) \end{code} -%************************************************************************ -%* * -\subsection{Auxiliary types} -%* * -%************************************************************************ - -These types are defined here because they are mentioned in ModDetails, -but they are mostly elaborated elsewhere - \begin{code} -mkIfaceVerCache :: [(Version,IfaceDecl)] - -> (OccName -> Maybe (OccName, Version)) -mkIfaceVerCache pairs +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs = \occ -> lookupOccEnv env occ where env = foldr add_decl emptyOccEnv pairs @@ -849,38 +990,61 @@ mkIfaceVerCache pairs env1 = extendOccEnv env0 decl_name (decl_name, v) add_imp bndr env = extendOccEnv env bndr (decl_name, v) -emptyIfaceVerCache :: OccName -> Maybe (OccName, Version) -emptyIfaceVerCache occ = Nothing +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing +\end{code} ------------------- Deprecations ------------------------- -data Deprecs a - = NoDeprecs - | DeprecAll DeprecTxt -- Whole module deprecated - | DeprecSome a -- Some specific things deprecated +%************************************************************************ +%* * +\subsection{Auxiliary types} +%* * +%************************************************************************ + +These types are defined here because they are mentioned in ModDetails, +but they are mostly elaborated elsewhere + +\begin{code} +------------------ Warnings ------------------------- +data Warnings + = NoWarnings + | WarnAll WarningTxt -- Whole module deprecated + | WarnSome [(OccName,WarningTxt)] -- Some specific things deprecated + -- Only an OccName is needed because + -- (1) a deprecation always applies to a binding + -- defined in the module in which the deprecation appears. + -- (2) deprecations are only reported outside the defining module. + -- this is important because, otherwise, if we saw something like + -- + -- {-# DEPRECATED f "" #-} + -- f = ... + -- h = f + -- g = let f = undefined in f + -- + -- we'd need more information than an OccName to know to say something + -- about the use of f in h but not the use of the locally bound f in g + -- + -- however, because we only report about deprecations from the outside, + -- and a module can only export one value called f, + -- an OccName suffices. + -- + -- this is in contrast with fixity declarations, where we need to map + -- a Name to its fixity declaration. deriving( Eq ) -type IfaceDeprecs = Deprecs [(OccName,DeprecTxt)] -type Deprecations = Deprecs (NameEnv (OccName,DeprecTxt)) - -- Keep the OccName so we can flatten the NameEnv to - -- get an IfaceDeprecs from a Deprecations - -- Only an OccName is needed, because a deprecation always - -- applies to things defined in the module in which the - -- deprecation appears. - -mkIfaceDepCache:: IfaceDeprecs -> Name -> Maybe DeprecTxt -mkIfaceDepCache NoDeprecs = \n -> Nothing -mkIfaceDepCache (DeprecAll t) = \n -> Just t -mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName - -emptyIfaceDepCache :: Name -> Maybe DeprecTxt -emptyIfaceDepCache n = Nothing - -plusDeprecs :: Deprecations -> Deprecations -> Deprecations -plusDeprecs d NoDeprecs = d -plusDeprecs NoDeprecs d = d -plusDeprecs d (DeprecAll t) = DeprecAll t -plusDeprecs (DeprecAll t) d = DeprecAll t -plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) +mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt +mkIfaceWarnCache NoWarnings = \_ -> Nothing +mkIfaceWarnCache (WarnAll t) = \_ -> Just t +mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName + +emptyIfaceWarnCache :: Name -> Maybe WarningTxt +emptyIfaceWarnCache _ = Nothing + +plusWarns :: Warnings -> Warnings -> Warnings +plusWarns d NoWarnings = d +plusWarns NoWarnings d = d +plusWarns _ (WarnAll t) = WarnAll t +plusWarns (WarnAll t) _ = WarnAll t +plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) \end{code} @@ -915,7 +1079,7 @@ availName (AvailTC n _) = n availNames :: GenAvailInfo name -> [name] availNames (Avail n) = [n] -availNames (AvailTC n ns) = ns +availNames (AvailTC _ ns) = ns instance Outputable n => Outputable (GenAvailInfo n) where ppr = pprAvail @@ -933,24 +1097,24 @@ mkIfaceFixCache pairs env = mkOccEnv pairs emptyIfaceFixCache :: OccName -> Fixity -emptyIfaceFixCache n = defaultFixity +emptyIfaceFixCache _ = defaultFixity -- This fixity environment is for source code only 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 SrcSpan +data FixItem = FixItem OccName Fixity instance Outputable FixItem where - ppr (FixItem occ fix loc) = ppr fix <+> ppr occ <+> parens (ppr loc) + ppr (FixItem occ fix) = ppr fix <+> ppr occ emptyFixityEnv :: FixityEnv emptyFixityEnv = emptyNameEnv lookupFixity :: FixityEnv -> Name -> Fixity lookupFixity env n = case lookupNameEnv env n of - Just (FixItem _ fix _) -> fix - Nothing -> defaultFixity + Just (FixItem _ fix) -> fix + Nothing -> defaultFixity \end{code} @@ -996,26 +1160,29 @@ noDependencies :: Dependencies 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) - } deriving( Eq ) - -- This type doesn't let you say "I imported f but none of the rules in - -- the module". If you use anything in the module you get its rule version - -- So if the rules change, you'll recompile, even if you don't use them. - -- 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 - + = UsagePackageModule { + usg_mod :: Module, + usg_mod_hash :: Fingerprint + } + | UsageHomeModule { + usg_mod_name :: ModuleName, -- Name of the module + usg_mod_hash :: Fingerprint, -- Module fingerprint + -- (optimisation only) + usg_entities :: [(OccName,Fingerprint)], + -- Sorted by occurrence name. + -- NB. usages are for parent names only, + -- eg. tycon but not constructors. + usg_exports :: Maybe Fingerprint + -- Export-list fingerprint, if we depend on it + } + deriving( Eq ) -- The export list field is (Just v) if we depend on the export list: -- i.e. we imported the module directly, whether or not we - -- enumerated the things we imported, or just imported everything + -- enumerated the things we imported, or just imported + -- everything -- We need to recompile if M's exports change, because - -- if the import was import M, we might now have a name clash in the - -- importing module. + -- if the import was import M, we might now have a name clash + -- in the importing module. -- if the import was import M(x) M might no longer export x -- The only way we don't depend on the export list is if we have -- import M() @@ -1060,10 +1227,10 @@ data ExternalPackageState -- (below), not in the mi_decls fields of the iPIT. -- What _is_ in the iPIT is: -- * The Module - -- * Version info + -- * Fingerprint info -- * Its exports -- * Fixities - -- * Deprecations + -- * Warnings eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules @@ -1191,14 +1358,15 @@ instance Outputable ModSummary where showModMsg :: HscTarget -> Bool -> ModSummary -> String showModMsg target recomp mod_summary - = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), - char '(', text (msHsFilePath mod_summary) <> comma, - case target of - HscInterpreted | recomp - -> text "interpreted" - HscNothing -> text "nothing" - _other -> text (msObjFilePath mod_summary), - char ')']) + = showSDoc $ + hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), + char '(', text (normalise $ msHsFilePath mod_summary) <> comma, + case target of + HscInterpreted | recomp + -> text "interpreted" + HscNothing -> text "nothing" + _ -> text (normalise $ msObjFilePath mod_summary), + char ')'] where mod = moduleName (ms_mod mod_summary) mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) @@ -1212,14 +1380,26 @@ showModMsg target recomp mod_summary %************************************************************************ \begin{code} -data HpcInfo = HpcInfo +data HpcInfo + = HpcInfo { hpcInfoTickCount :: Int , hpcInfoHash :: Int } - | NoHpcInfo + | NoHpcInfo + { hpcUsed :: AnyHpcUsage -- is hpc used anywhere on the module tree? + } + +-- This is used to mean there is no module-local hpc usage, +-- but one of my imports used hpc instrumentation. + +type AnyHpcUsage = Bool -noHpcInfo :: HpcInfo -noHpcInfo = NoHpcInfo +emptyHpcInfo :: AnyHpcUsage -> HpcInfo +emptyHpcInfo = NoHpcInfo + +isHpcUsed :: HpcInfo -> AnyHpcUsage +isHpcUsed (HpcInfo {}) = True +isHpcUsed (NoHpcInfo { hpcUsed = used }) = used \end{code} %************************************************************************ @@ -1232,26 +1412,54 @@ The following information is generated and consumed by the vectorisation subsystem. It communicates the vectorisation status of declarations from one module to another. +Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo +below? We need to know `f' when converting to IfaceVectInfo. However, during +vectorisation, we need to know `f_v', whose `Var' we cannot lookup based +on just the OccName easily in a Core pass. + \begin{code} --- ModGuts version -data VectInfo = VectInfo { - vectInfoCCVar :: NameSet - } +-- ModGuts/ModDetails/EPS version +data VectInfo + = VectInfo { + vectInfoVar :: VarEnv (Var , Var ), -- (f, f_v) keyed on f + vectInfoTyCon :: NameEnv (TyCon , TyCon), -- (T, T_v) keyed on T + vectInfoDataCon :: NameEnv (DataCon, DataCon), -- (C, C_v) keyed on C + vectInfoPADFun :: NameEnv (TyCon , Var), -- (T_v, paT) keyed on T_v + vectInfoIso :: NameEnv (TyCon , Var) -- (T, isoT) keyed on T + } + -- all of this is always tidy, even in ModGuts -- ModIface version -data IfaceVectInfo = IfaceVectInfo { - ifaceVectInfoCCVar :: [Name] - } +data IfaceVectInfo + = IfaceVectInfo { + ifaceVectInfoVar :: [Name], + -- all variables in here have a vectorised variant; + -- the name of the vectorised variant is determined by `mkCloVect' + ifaceVectInfoTyCon :: [Name], + -- all tycons in here have a vectorised variant; + -- the name of the vectorised variant and those of its + -- data constructors are determined by `mkVectTyConOcc' + -- and `mkVectDataConOcc'; the names of + -- the isomorphisms is determined by `mkVectIsoOcc' + ifaceVectInfoTyConReuse :: [Name] + -- the vectorised form of all the tycons in here coincids with + -- the unconverted from; the names of the isomorphisms is determined + -- by `mkVectIsoOcc' + } noVectInfo :: VectInfo -noVectInfo = VectInfo emptyNameSet +noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv plusVectInfo :: VectInfo -> VectInfo -> VectInfo plusVectInfo vi1 vi2 = - VectInfo (vectInfoCCVar vi1 `unionNameSets` vectInfoCCVar vi2) + VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2) + (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2) + (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2) + (vectInfoPADFun vi1 `plusNameEnv` vectInfoPADFun vi2) + (vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2) noIfaceVectInfo :: IfaceVectInfo -noIfaceVectInfo = IfaceVectInfo [] +noIfaceVectInfo = IfaceVectInfo [] [] [] \end{code} %************************************************************************ @@ -1290,10 +1498,12 @@ data Unlinked = DotO FilePath | DotA FilePath | DotDLL FilePath - | BCOs CompiledByteCode + | BCOs CompiledByteCode ModBreaks #ifndef GHCI -data CompiledByteCode = NoByteCode +data CompiledByteCode = CompiledByteCodeUndefined +_unused :: CompiledByteCode +_unused = CompiledByteCodeUndefined #endif instance Outputable Unlinked where @@ -1301,25 +1511,29 @@ instance Outputable Unlinked where ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path #ifdef GHCI - ppr (BCOs bcos) = text "BCOs" <+> ppr bcos + ppr (BCOs bcos _) = text "BCOs" <+> ppr bcos #else - ppr (BCOs bcos) = text "No byte code" + ppr (BCOs _ _) = text "No byte code" #endif +isObject :: Unlinked -> Bool isObject (DotO _) = True isObject (DotA _) = True isObject (DotDLL _) = True isObject _ = False +isInterpretable :: Unlinked -> Bool isInterpretable = not . isObject +nameOfObject :: Unlinked -> FilePath nameOfObject (DotO fn) = fn nameOfObject (DotA fn) = fn nameOfObject (DotDLL fn) = fn nameOfObject other = pprPanic "nameOfObject" (ppr other) -byteCodeOfObject (BCOs bc) = bc -byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) +byteCodeOfObject :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) \end{code} %************************************************************************