X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=07c75684970a93380f64b97c3738bbed0a4e7941;hp=d0c2f1332e52711c55637c379af1a96b864ae6f9;hb=d51f42f602bf9a6d1b356c41228a534c88723f65;hpb=b78e736684ec530ee363ac44f88b328820592481 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index d0c2f13..07c7568 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, @@ -34,8 +35,6 @@ module HscTypes ( ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, emptyIfaceDepCache, - Deprecs(..), IfaceDeprecs, - FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, implicitTyThings, isImplicitTyThing, @@ -53,7 +52,7 @@ module HscTypes ( GenAvailInfo(..), AvailInfo, RdrAvailInfo, IfaceExport, - Deprecations, DeprecTxt, plusDeprecs, + Deprecations(..), DeprecTxt, plusDeprecs, PackageInstEnv, PackageRuleBase, @@ -97,7 +96,7 @@ 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 hiding ( Version(..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) @@ -107,19 +106,21 @@ import BasicTypes ( Version, initialVersion, IPName, 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 StringBuffer ( StringBuffer ) +import System.FilePath import System.Time ( ClockTime ) import Data.IORef import Data.Array ( Array, array ) import Data.List +import Control.Monad ( mplus ) \end{code} @@ -277,7 +278,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 @@ -285,7 +286,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} @@ -434,7 +435,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 @@ -511,6 +512,8 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, -- being compiled right now. Once it is compiled, a ModIface and -- ModDetails are extracted and the ModGuts is dicarded. +type ImportedMods = ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)]) + data ModGuts = ModGuts { mg_module :: !Module, @@ -518,9 +521,9 @@ 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 @@ -550,6 +553,24 @@ data ModGuts -- 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: @@ -801,31 +822,62 @@ mkPrintUnqualified dflags 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 _) = [] - -- 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 @@ -837,15 +889,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 :: TyCon -> [TyThing] -implicitCoTyCon tc - = map ATyCon . catMaybes $ [newTyConCo_maybe tc, - tyConFamilyCoercion_maybe tc] - -extras_plus :: TyThing -> [TyThing] -extras_plus thing = thing : implicitTyThings thing - extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids = extendNameEnvList env [(getName id, AnId id) | id <- ids] @@ -920,8 +963,9 @@ tyThingDataCon (ADataCon dc) = dc tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other) tyThingId :: TyThing -> Id -tyThingId (AnId id) = id -tyThingId other = pprPanic "tyThingId" (pprTyThing other) +tyThingId (AnId id) = id +tyThingId (ADataCon dc) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (pprTyThing other) \end{code} %************************************************************************ @@ -950,21 +994,33 @@ 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 :: Deprecations -> Name -> Maybe DeprecTxt mkIfaceDepCache NoDeprecs = \_ -> Nothing mkIfaceDepCache (DeprecAll t) = \_ -> Just t mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName @@ -977,7 +1033,7 @@ plusDeprecs d NoDeprecs = d plusDeprecs NoDeprecs d = d plusDeprecs _ (DeprecAll t) = DeprecAll t plusDeprecs (DeprecAll t) _ = DeprecAll t -plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) +plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 ++ v2) \end{code} @@ -1036,18 +1092,18 @@ emptyIfaceFixCache _ = defaultFixity type FixityEnv = NameEnv FixItem -- We keep the OccName in the range so that we can generate an interface from it -data FixItem = FixItem OccName Fixity 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} @@ -1288,14 +1344,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) @@ -1430,7 +1487,9 @@ data Unlinked | BCOs CompiledByteCode ModBreaks #ifndef GHCI -data CompiledByteCode +data CompiledByteCode = CompiledByteCodeUndefined +_unused :: CompiledByteCode +_unused = CompiledByteCodeUndefined #endif instance Outputable Unlinked where