X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=abebd14b6b4e956e03bfb8690453d37a88490d1d;hp=c46d78e14bbc47ac4e9abf8fcba56c60a6e9b200;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=2c1ea2cedb1a8034b0828e24b554a35f56bb8924 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index c46d78e..abebd14 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1,74 +1,82 @@ - -% (c) The University of Glasgow, 2000 +% +% (c) The University of Glasgow, 2006 % \section[HscTypes]{Types for the per-module compiler} \begin{code} module HscTypes ( -- * Sessions and compilation state - Session(..), HscEnv(..), hscEPS, - FinderCache, FinderCacheEntry, + Session(..), withSession, modifySession, + HscEnv(..), hscEPS, + FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, ModDetails(..), emptyModDetails, ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..), - ModSummary(..), showModMsg, isBootSummary, + ModSummary(..), ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, + hptInstances, hptRules, hptVectInfo, ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, - lookupIface, lookupIfaceByModule, emptyModIface, + lookupIfaceByModule, emptyModIface, InteractiveContext(..), emptyInteractiveContext, - icPrintUnqual, unQualInScope, + icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, + substInteractiveContext, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, - emptyIfaceDepCache, - - Deprecs(..), IfaceDeprecs, + emptyIfaceDepCache, 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, - Deprecations, DeprecTxt, lookupDeprec, plusDeprecs, + Deprecations(..), DeprecTxt, plusDeprecs, PackageInstEnv, PackageRuleBase, -- Linker stuff Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, - isObject, nameOfObject, isInterpretable, byteCodeOfObject + isObject, nameOfObject, isInterpretable, byteCodeOfObject, + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, + + -- Breakpoints + ModBreaks (..), BreakIndex, emptyModBreaks, + + -- Vectorisation information + VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, + noIfaceVectInfo ) where #include "HsVersions.h" #ifdef GHCI import ByteCodeAsm ( CompiledByteCode ) +import {-# SOURCE #-} InteractiveEval ( Resume ) #endif -import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, - LocalRdrEnv, emptyLocalRdrEnv, - GlobalRdrElt(..), mkRdrUnqual, lookupGRE_RdrName ) +import RdrName import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet @@ -76,34 +84,40 @@ 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 Type ( TyThing(..) ) - -import Class ( Class, classSelIds, classTyCon ) -import TyCon ( TyCon, tyConSelIds, tyConDataCons ) -import DataCon ( dataConImplicitIds ) +import VarEnv +import VarSet +import Var hiding ( setIdType ) +import Id +import Type + +import Class ( Class, classSelIds, classATs, classTyCon ) +import TyCon +import DataCon ( DataCon, dataConImplicitIds ) import PrelNames ( gHC_PRIM ) -import Packages ( PackageIdH, PackageId, PackageConfig, HomeModules ) +import Packages hiding ( Version(..) ) 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, expectJust ) +import Maybes ( orElse, expectJust, catMaybes, seqMaybe ) import Outputable +import BreakArray import SrcLoc ( SrcSpan, Located ) +import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString ( FastString ) - -import DATA_IOREF ( IORef, readIORef ) import StringBuffer ( StringBuffer ) -import Time ( ClockTime ) + +import System.Time ( ClockTime ) +import Data.IORef +import Data.Array ( Array, array ) +import Data.List \end{code} @@ -120,6 +134,12 @@ import Time ( ClockTime ) -- constituting the current program or library, the context for -- interactive evaluation, and various caches. newtype Session = Session (IORef HscEnv) + +withSession :: Session -> (HscEnv -> IO a) -> IO a +withSession (Session ref) f = do h <- readIORef ref; f h + +modifySession :: Session -> (HscEnv -> HscEnv) -> IO () +modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h \end{code} HscEnv is like Session, except that some of the fields are immutable. @@ -172,9 +192,11 @@ data HscEnv -- sucking in interface files. They cache the state of -- external interface files, in effect. - hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + hsc_MLC :: {-# UNPACK #-} !(IORef ModLocationCache), -- The finder's cache. This caches the location of modules, -- so we don't have to search the filesystem multiple times. + hsc_global_rdr_env :: GlobalRdrEnv, hsc_global_type_env :: TypeEnv } @@ -191,7 +213,7 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env) data Target = Target TargetId (Maybe (StringBuffer,ClockTime)) data TargetId - = TargetModule Module + = TargetModule ModuleName -- ^ A module name: search for the file | TargetFile FilePath (Maybe Phase) -- ^ A filename: preprocess & parse it to find the module name. @@ -203,19 +225,26 @@ data TargetId pprTarget :: Target -> SDoc pprTarget (Target id _) = pprTargetId id +instance Outputable Target where + ppr = pprTarget + +pprTargetId :: TargetId -> SDoc pprTargetId (TargetModule m) = ppr m pprTargetId (TargetFile f _) = text f -type FinderCache = ModuleEnv FinderCacheEntry -type FinderCacheEntry = (ModLocation, Maybe (PackageConfig,Bool)) - -- The finder's cache (see module Finder) +instance Outputable TargetId where + ppr = pprTargetId -type HomePackageTable = ModuleEnv HomeModInfo +type HomePackageTable = ModuleNameEnv HomeModInfo -- Domain = modules in the home package + -- "home" package name cached here for convenience type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported packages -emptyHomePackageTable = emptyModuleEnv +emptyHomePackageTable :: HomePackageTable +emptyHomePackageTable = emptyUFM + +emptyPackageIfaceTable :: PackageIfaceTable emptyPackageIfaceTable = emptyModuleEnv data HomeModInfo @@ -232,40 +261,49 @@ data HomeModInfo -- When re-linking a module (hscNoRecomp), we construct -- the HomModInfo by building a new ModDetails from the -- old ModIface (only). -\end{code} - -Simple lookups in the symbol table. -\begin{code} -lookupIface :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface --- We often have two IfaceTables, and want to do a lookup -lookupIface hpt pit mod - = case lookupModuleEnv hpt mod of - Just mod_info -> Just (hm_iface mod_info) - Nothing -> lookupModuleEnv pit mod - -lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface --- We often have two IfaceTables, and want to do a lookup -lookupIfaceByModule hpt pit mod - = case lookupModuleEnv hpt mod of - Just mod_info -> Just (hm_iface mod_info) - Nothing -> lookupModuleEnv pit mod +-- | Find the 'ModIface' for a 'Module' +lookupIfaceByModule + :: DynFlags + -> HomePackageTable + -> PackageIfaceTable + -> Module + -> Maybe ModIface +lookupIfaceByModule dflags hpt pit mod + | 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} \begin{code} -hptInstances :: HscEnv -> (Module -> Bool) -> [Instance] --- 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 :: HscEnv -> (ModuleName -> Bool) -> ([Instance], [FamInst]) +-- Find all the instance declarations (of classes and families) 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 - = [ ispec - | mod_info <- moduleEnvElts (hsc_HPT hsc_env) - , want_this_module (mi_module (hm_iface mod_info)) - , ispec <- md_insts (hm_details mod_info) ] + = let (insts, famInsts) = unzip + [ (md_insts details, md_fam_insts details) + | mod_info <- eltsUFM (hsc_HPT hsc_env) + , want_this_module (moduleName (mi_module (hm_iface mod_info))) + , let details = hm_details mod_info ] + in + (concat insts, concat famInsts) -hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [CoreRule] +hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] -- Get rules from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances hptRules hsc_env deps @@ -283,17 +321,70 @@ hptRules hsc_env deps -- be in the HPT, because we never compile it; it's in the EPT -- instead. ToDo: clean up, and remove this slightly bogus -- filter: - , mod /= gHC_PRIM + , mod /= moduleName gHC_PRIM -- Look it up in the HPT - , let mod_info = case lookupModuleEnv hpt mod of - Nothing -> pprPanic "hptRules" (ppr mod <+> ppr deps) - Just x -> x + , 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")] + -- This really shouldn't happen, but see Trac #962 -- And get its dfuns - , rule <- md_rules (hm_details mod_info) ] + , 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} +%************************************************************************ +%* * +\subsection{The Finder cache} +%* * +%************************************************************************ + +\begin{code} +-- | The 'FinderCache' maps home module names to the result of +-- searching for that module. It records the results of searching for +-- modules along the search path. On @:load@, we flush the entire +-- contents of this cache. +-- +-- Although the @FinderCache@ range is 'FindResult' for convenience , +-- in fact it will only ever contain 'Found' or 'NotFound' entries. +-- +type FinderCache = ModuleNameEnv FindResult + +-- | The result of searching for an imported module. +data FindResult + = Found ModLocation Module + -- the module was found + | NoPackage PackageId + -- the requested package was not found + | FoundMultiple [PackageId] + -- *error*: both in multiple packages + | PackageHidden PackageId + -- for an explicit source import: the package containing the module is + -- not exposed. + | ModuleHidden PackageId + -- for an explicit source import: the package containing the module is + -- exposed, but the module itself is hidden. + | NotFound [FilePath] (Maybe PackageId) + -- the module was not found, the specified places were searched + | NotFoundInPackage PackageId + -- the module was not found in this package + +-- | Cache that remembers where we found a particular module. Contains both +-- home modules and package modules. On @:load@, only home modules are +-- purged from this cache. +type ModLocationCache = ModuleEnv ModLocation +\end{code} %************************************************************************ %* * @@ -313,11 +404,11 @@ the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface = ModIface { - mi_package :: !PackageIdH, -- Which package the module comes from mi_module :: !Module, 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, @@ -341,7 +432,7 @@ data ModIface -- NOT STRICT! we read this field lazily from the interface file -- Deprecations - mi_deprecs :: IfaceDeprecs, + mi_deprecs :: Deprecations, -- NOT STRICT! we read this field lazily from the interface file -- Type, class and variable declarations @@ -367,35 +458,51 @@ 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 + + -- Vectorisation information + mi_vect_info :: !IfaceVectInfo, -- 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. + 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 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 + md_vect_info :: !VectInfo -- Vectorisation information } +emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, - md_exports = emptyNameSet, - md_insts = [], - md_rules = [] } + md_exports = [], + md_insts = [], + md_rules = [], + md_fam_insts = [], + 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 @@ -404,24 +511,41 @@ 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_home_mods :: !HomeModules, -- For calling isHomeModule etc. - 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 + + -- 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_hpc_info :: !HpcInfo, -- info about coverage tick boxes + mg_modBreaks :: !ModBreaks, + 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 fro + -- *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 } -- The ModGuts takes on several slightly different forms: @@ -458,8 +582,9 @@ data CgGuts -- initialisation code cg_foreign :: !ForeignStubs, - cg_home_mods :: !HomeModules, -- for calling isHomeModule etc. - cg_dep_pkgs :: ![PackageId] -- Used to generate #includes for C code gen + cg_dep_pkgs :: ![PackageId], -- Used to generate #includes for C code gen + cg_hpc_info :: !HpcInfo, -- info about coverage tick boxes + cg_modBreaks :: !ModBreaks } ----------------------------------- @@ -483,18 +608,16 @@ data ForeignStubs = NoStubs -- "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 :: PackageIdH -> Module -> ModIface -emptyModIface pkg mod - = ModIface { mi_package = pkg, - mi_module = mod, +emptyModIface :: Module -> ModIface +emptyModIface mod + = ModIface { mi_module = mod, mi_mod_vers = initialVersion, mi_orphan = False, + mi_finsts = False, mi_boot = False, mi_deps = noDependencies, mi_usages = [], @@ -502,14 +625,17 @@ emptyModIface pkg 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_vect_info = noIfaceVectInfo, mi_dep_fn = emptyIfaceDepCache, mi_fix_fn = emptyIfaceFixCache, - mi_ver_fn = emptyIfaceVerCache + mi_ver_fn = emptyIfaceVerCache, + mi_hpc = False } \end{code} @@ -532,39 +658,137 @@ data InteractiveContext ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from -- ic_toplev_scope and ic_exports - ic_rn_local_env :: LocalRdrEnv, -- Lexical context for variables bound - -- during interaction + ic_tmp_ids :: [Id], -- Names bound during interaction. + -- Later Ids shadow + -- earlier ones with the same OccName. + + ic_tyvars :: TyVarSet -- skolem type variables free in + -- ic_tmp_ids. These arise at + -- breakpoints in a polymorphic + -- context, where we have only partial + -- type information. - ic_type_env :: TypeEnv -- Ditto for types +#ifdef GHCI + , ic_resume :: [Resume] -- the stack of breakpoint contexts +#endif } + +emptyInteractiveContext :: InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], ic_exports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, - ic_rn_local_env = emptyLocalRdrEnv, - ic_type_env = emptyTypeEnv } - -icPrintUnqual :: InteractiveContext -> PrintUnqualified -icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt) + ic_tmp_ids = [], + ic_tyvars = emptyVarSet +#ifdef GHCI + , ic_resume = [] +#endif + } + +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt) + + +extendInteractiveContext + :: InteractiveContext + -> [Id] + -> TyVarSet + -> InteractiveContext +extendInteractiveContext ictxt ids tyvars + = ictxt { ic_tmp_ids = ic_tmp_ids ictxt ++ ids, + -- 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} -@unQualInScope@ returns a function that takes a @Name@ and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the @Name@'s provenance to guide whether or not to print the name qualified -in error messages. +%************************************************************************ +%* * + Building a PrintUnqualified +%* * +%************************************************************************ + +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} -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') --- --- [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 +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = (qual_name, qual_mod) + where + 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 + 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 + + | otherwise = True + where lookup = lookupModuleInAllPackages dflags (moduleName mod) \end{code} @@ -575,26 +799,72 @@ unQualInScope env mod occ %************************************************************************ \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] -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) + +-- 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 TyCon too (and its extras) - -- and the class selector Ids -implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ - extras_plus (ATyCon (classTyCon cl)) - +implicitTyThings (AClass 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) ++ + -- 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 data cons add the worker and wrapper (if any) -implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) +-- 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] -extras_plus thing = thing : implicitTyThings thing +-- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y) + + +-- | 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 extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids @@ -610,18 +880,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 @@ -637,26 +909,39 @@ extendTypeEnvList env things = foldl extendTypeEnv env things \end{code} \begin{code} -lookupType :: HomePackageTable -> PackageTypeEnv -> Name -> Maybe TyThing -lookupType hpt pte name - = case lookupModuleEnv hpt (nameModule name) of - Just details -> lookupNameEnv (md_types (hm_details details)) name - Nothing -> lookupNameEnv pte name +lookupType :: DynFlags + -> HomePackageTable + -> PackageTypeEnv + -> Name + -> Maybe TyThing + +lookupType dflags hpt pte name + -- in one-shot, we don't use the HPT + | not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg + = do hm <- lookupUFM hpt (moduleName mod) -- Maybe monad + lookupNameEnv (md_types (hm_details hm)) name + | otherwise + = lookupNameEnv pte name + where mod = nameModule name + this_pkg = thisPackage dflags \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 :: TyThing -> Id tyThingId (AnId id) = id -tyThingId other = pprPanic "tyThingId" (ppr other) +tyThingId other = pprPanic "tyThingId" (pprTyThing other) \end{code} %************************************************************************ @@ -669,52 +954,62 @@ 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 occ = Nothing +emptyIfaceVerCache :: OccName -> Maybe (OccName, Version) +emptyIfaceVerCache _occ = Nothing ------------------ Deprecations ------------------------- -data Deprecs a +data Deprecations = NoDeprecs - | DeprecAll DeprecTxt -- Whole module deprecated - | DeprecSome a -- Some specific things deprecated + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome [(OccName,DeprecTxt)] -- 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 :: Deprecations -> Name -> Maybe DeprecTxt +mkIfaceDepCache NoDeprecs = \_ -> Nothing +mkIfaceDepCache (DeprecAll t) = \_ -> Just t mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName emptyIfaceDepCache :: Name -> Maybe DeprecTxt -emptyIfaceDepCache n = Nothing - -lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt -lookupDeprec NoDeprecs name = Nothing -lookupDeprec (DeprecAll txt) name = Just txt -lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of - Just (_, txt) -> Just txt - Nothing -> Nothing +emptyIfaceDepCache _ = 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) +plusDeprecs _ (DeprecAll t) = DeprecAll t +plusDeprecs (DeprecAll t) _ = DeprecAll t +plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 ++ v2) \end{code} @@ -735,9 +1030,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 @@ -745,17 +1044,14 @@ 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 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} @@ -766,24 +1062,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} @@ -801,27 +1097,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 :: [(Module,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 :: Module, -- Name of the module + = 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) @@ -853,20 +1160,24 @@ 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 +type PackageVectInfo = VectInfo 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 + eps_is_boot :: !(ModuleNameEnv (ModuleName, 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 + -- The ModuleName 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 @@ -874,8 +1185,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 @@ -883,12 +1194,17 @@ 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_rule_base :: !PackageRuleBase, -- Ditto RuleEnv + 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_vect_info :: !PackageVectInfo, -- Ditto VectInfo + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- identifies family + -- instances of each mod eps_stats :: !EpsStats } @@ -957,19 +1273,22 @@ emptyMG = [] data ModSummary = ModSummary { - ms_mod :: Module, -- Name of the module + ms_mod :: Module, -- Identity of the module ms_hsc_src :: HscSource, -- Source is Haskell, hs-boot, external core ms_location :: ModLocation, -- Location ms_hs_date :: ClockTime, -- Timestamp of source file ms_obj_date :: Maybe ClockTime, -- Timestamp of object, maybe - ms_srcimps :: [Located Module], -- Source imports - ms_imps :: [Located Module], -- Non-source imports + ms_srcimps :: [Located ModuleName], -- Source imports + ms_imps :: [Located ModuleName], -- Non-source imports ms_hspp_file :: FilePath, -- Filename of preprocessed source. ms_hspp_opts :: DynFlags, -- Cached flags from OPTIONS, INCLUDE -- and LANGUAGE pragmas. ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe. } +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + -- 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 @@ -1004,16 +1323,105 @@ 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 + HscInterpreted | recomp -> text "interpreted" HscNothing -> text "nothing" _other -> text (msObjFilePath mod_summary), char ')']) where - mod = ms_mod mod_summary - mod_str = moduleString mod ++ hscSourceString (ms_hsc_src mod_summary) + mod = moduleName (ms_mod mod_summary) + mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) +\end{code} + + +%************************************************************************ +%* * +\subsection{Hpc Support} +%* * +%************************************************************************ + +\begin{code} +data HpcInfo + = HpcInfo + { hpcInfoTickCount :: Int + , hpcInfoHash :: Int + } + | 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 + +emptyHpcInfo :: AnyHpcUsage -> HpcInfo +emptyHpcInfo = NoHpcInfo + +isHpcUsed :: HpcInfo -> AnyHpcUsage +isHpcUsed (HpcInfo {}) = True +isHpcUsed (NoHpcInfo { hpcUsed = used }) = used \end{code} +%************************************************************************ +%* * +\subsection{Vectorisation Support} +%* * +%************************************************************************ + +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/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 { + 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 emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv + +plusVectInfo :: VectInfo -> VectInfo -> VectInfo +plusVectInfo vi1 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 [] [] [] +\end{code} %************************************************************************ %* * @@ -1051,10 +1459,10 @@ data Unlinked = DotO FilePath | DotA FilePath | DotDLL FilePath - | BCOs CompiledByteCode + | BCOs CompiledByteCode ModBreaks #ifndef GHCI -data CompiledByteCode = NoByteCode +data CompiledByteCode #endif instance Outputable Unlinked where @@ -1062,24 +1470,57 @@ 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 :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) \end{code} +%************************************************************************ +%* * +\subsection{Breakpoint Support} +%* * +%************************************************************************ +\begin{code} +type BreakIndex = Int + +-- | all the information about the breakpoints for a given module +data ModBreaks + = ModBreaks + { modBreaks_flags :: BreakArray + -- The array of flags, one per breakpoint, + -- indicating which breakpoints are enabled. + , modBreaks_locs :: !(Array BreakIndex SrcSpan) + -- An array giving the source span of each breakpoint. + , modBreaks_vars :: !(Array BreakIndex [OccName]) + -- An array giving the names of the free variables at each breakpoint. + } +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaks + { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" + -- Todo: can we avoid this? + , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] + } +\end{code}