X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=2b8f8f79d52708c5c20cd79d1dd5e2dec2371a4c;hp=6bc1197f710e863f71d1db75d7c6cfaf7f862b61;hb=7aa3f5247ae454b10b61e2f28a9431f0889a8cff;hpb=2a8cdc3aee5997374273e27365f92c161aca8453 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 6bc1197..2b8f8f7 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} @@ -36,7 +36,7 @@ module HscTypes ( FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - implicitTyThings, + implicitTyThings, isImplicitTyThing, TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, @@ -47,22 +47,24 @@ module HscTypes ( 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, noHpcInfo ) where #include "HsVersions.h" +import Breakpoints ( SiteNumber, Coord, noDbgSites ) #ifdef GHCI import ByteCodeAsm ( CompiledByteCode ) #endif @@ -81,12 +83,11 @@ 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, classATs, classTyCon ) -import TyCon ( TyCon, tyConSelIds, tyConDataCons, - newTyConCo_maybe, tyConFamilyCoercion_maybe ) +import TyCon import DataCon ( DataCon, dataConImplicitIds ) import PrelNames ( gHC_PRIM ) import Packages ( PackageId ) @@ -94,23 +95,20 @@ import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) - -import IfaceSyn ( IfaceInst, IfaceFamInst, IfaceRule, - IfaceDecl(ifName) ) - +import IfaceSyn import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) -import Maybes ( orElse, expectJust ) +import Maybes ( orElse, expectJust, catMaybes, seqMaybe ) import Outputable import SrcLoc ( SrcSpan, Located ) import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString ( FastString ) -import DATA_IOREF ( IORef, readIORef ) import StringBuffer ( StringBuffer ) -import Maybes ( catMaybes, seqMaybe ) -import Time ( ClockTime ) + +import System.Time ( ClockTime ) +import Data.IORef ( IORef, readIORef ) \end{code} @@ -212,9 +210,15 @@ data TargetId pprTarget :: Target -> SDoc pprTarget (Target id _) = pprTargetId id +instance Outputable Target where + ppr = pprTarget + pprTargetId (TargetModule m) = ppr m pprTargetId (TargetFile f _) = text f +instance Outputable TargetId where + ppr = pprTargetId + type HomePackageTable = ModuleNameEnv HomeModInfo -- Domain = modules in the home package -- "home" package name cached here for convenience @@ -298,12 +302,15 @@ hptRules hsc_env deps , mod /= moduleName gHC_PRIM -- Look it up in the HPT - , let mod_info = case lookupUFM 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 ] \end{code} %************************************************************************ @@ -370,6 +377,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, @@ -423,39 +431,40 @@ data ModIface mi_fam_insts :: [IfaceFamInst], -- Sorted mi_rules :: [IfaceRule], -- Sorted mi_rule_vers :: !Version, -- Version number for rules and - -- instances combined + -- 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, + -- The next two fields are created by the typechecker + md_exports :: [AvailInfo], md_types :: !TypeEnv, - md_fam_insts :: ![FamInst], -- Cached value extracted from md_types - md_insts :: ![Instance], -- Dfun-ids for the instances in this - -- module - - md_rules :: ![CoreRule] -- Domain may include Ids from other - -- modules - + 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_dbg_sites :: ![(SiteNumber, Coord)] -- Breakpoint sites inserted by the renamer } emptyModDetails = ModDetails { md_types = emptyTypeEnv, - md_exports = emptyNameSet, + md_exports = [], md_insts = [], md_rules = [], - md_fam_insts = [] } + md_fam_insts = [], + md_dbg_sites = noDbgSites} -- 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 @@ -466,7 +475,7 @@ data ModGuts = ModGuts { mg_module :: !Module, mg_boot :: IsBootInterface, -- Whether it's an hs-boot module - mg_exports :: !NameSet, -- What it exports + 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 @@ -476,14 +485,20 @@ data ModGuts 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_fam_inst_env :: FamInstEnv, -- Type-family instance enviroment + -- for *home-package* modules (including + -- this one). c.f. tcg_fam_inst_env 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_foreign :: !ForeignStubs, + mg_deprecs :: !Deprecations, -- Deprecations declared in the module + mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes + mg_dbg_sites :: ![(SiteNumber, Coord)] -- Bkpts inserted by the renamer } -- The ModGuts takes on several slightly different forms: @@ -520,7 +535,8 @@ data CgGuts -- initialisation code cg_foreign :: !ForeignStubs, - 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 } ----------------------------------- @@ -555,6 +571,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 = [], @@ -667,6 +684,16 @@ implicitTyThings (AClass cl) = map AnId (classSelIds 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, @@ -758,14 +785,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 ------------------------- @@ -791,13 +823,6 @@ 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 - plusDeprecs :: Deprecations -> Deprecations -> Deprecations plusDeprecs d NoDeprecs = d plusDeprecs NoDeprecs d = d @@ -824,9 +849,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 @@ -840,11 +869,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} @@ -890,27 +916,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) @@ -983,6 +1020,9 @@ data ExternalPackageState eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- identifies family + -- instances of each mod + eps_stats :: !EpsStats } @@ -1111,6 +1151,19 @@ showModMsg target recomp mod_summary %************************************************************************ %* * +\subsection{Hpc Support} +%* * +%************************************************************************ + +\begin{code} +type HpcInfo = Int -- just the number of ticks in a module + +noHpcInfo :: HpcInfo +noHpcInfo = 0 -- default = 0 +\end{code} + +%************************************************************************ +%* * \subsection{Linkable stuff} %* * %************************************************************************