X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=0d4d163ad9fd8859ab8cd4500625ec12d37c2180;hb=c8bee21ecc0952200e43ce353e6a660334a6f756;hp=e99e8bf03853b126f418d74b6bf06056fdeaa6c2;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30;p=ghc-hetmet.git diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index e99e8bf..0d4d163 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % @@ -175,80 +176,45 @@ compiled with -O. I think this is the case.] \begin{code} #include "HsVersions.h" -import IfaceSyn -- All of it +import IfaceSyn import IfaceType -import LoadIface ( readIface, loadInterface, pprModIface ) -import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) -import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), - arityInfo, cafInfo, newStrictnessInfo, - workerInfo, unfoldingInfo, inlinePragInfo ) -import NewDemand ( isTopSig ) +import LoadIface +import Id +import IdInfo +import NewDemand import CoreSyn -import Class ( classExtraBigSig, classTyCon ) -import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..), - isRecursiveTyCon, isForeignTyCon, - isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, - isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, - tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon, - tyConArity, tyConTyVars, algTyConRhs, tyConExtName, - tyConFamInst_maybe ) -import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks, - dataConTyCon, dataConIsInfix, dataConUnivTyVars, - dataConExTyVars, dataConEqSpec, dataConTheta, - dataConOrigArgTys ) -import Type ( TyThing(..), splitForAllTys, funResultTy ) -import TcType ( deNoteType ) -import TysPrim ( alphaTyVars ) -import InstEnv ( Instance(..) ) -import FamInstEnv ( FamInst(..) ) +import Class +import TyCon +import DataCon +import Type +import TcType +import InstEnv +import FamInstEnv import TcRnMonad -import HscTypes ( ModIface(..), ModDetails(..), - ModGuts(..), HscEnv(..), hscEPS, Dependencies(..), - FixItem(..), - ModSummary(..), msHiFilePath, - mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, - typeEnvElts, - GenAvailInfo(..), availName, AvailInfo, - ExternalPackageState(..), - Usage(..), IsBootInterface, - Deprecs(..), IfaceDeprecs, Deprecations, - lookupIfaceByModule, isImplicitTyThing - ) - - -import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt ) -import Name ( Name, nameModule, nameModule_maybe, nameOccName, - isExternalName, isInternalName, isWiredInName, - NamedThing(..) ) +import HscTypes + +import DynFlags +import Name import NameEnv import NameSet -import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, - extendOccEnv_C, - OccSet, emptyOccSet, elemOccSet, occSetElts, - extendOccSet, extendOccSetList, mkOccSet, - isEmptyOccSet, intersectOccSet, intersectsOccSet, - unionOccSets, unitOccSet, - occNameFS, isTcOcc ) +import OccName import Module -import BinIface ( readBinIface, writeBinIface, v_IgnoreHiWay ) -import Unique ( Unique, Uniquable(..) ) -import ErrUtils ( dumpIfSet_dyn, showPass ) -import Digraph ( stronglyConnComp, SCC(..) ) -import SrcLoc ( SrcSpan ) -import PackageConfig ( PackageId ) +import BinIface +import Unique +import ErrUtils +import Digraph +import SrcLoc +import PackageConfig hiding ( Version ) import Outputable import BasicTypes hiding ( SuccessFlag(..) ) import UniqFM import Util hiding ( eqListBy ) import FiniteMap import FastString +import Maybes -import Data.List ( partition ) -import DATA_IOREF ( writeIORef ) -import Monad ( when ) -import List ( insert ) -import Maybes ( orElse, mapCatMaybes, isNothing, isJust, - expectJust, catMaybes, MaybeErr(..) ) +import Control.Monad +import Data.List \end{code} @@ -291,11 +257,13 @@ mkIface hsc_env maybe_old_iface ; let { entities = typeEnvElts type_env ; decls = [ tyThingToIfaceDecl entity | entity <- entities, - not (isImplicitTyThing entity - || isWiredInName (getName entity)) ] - -- Don't put implicit Ids and class tycons in - -- the interface file, Nor wired-in things; the - -- compiler knows about them anyhow + let name = getName entity, + not (isImplicitTyThing entity), + -- No implicit Ids and class tycons in the interface file + not (isWiredInName name), + -- Nor wired-in things; the compiler knows about them anyhow + nameIsLocalOrFrom this_mod name ] + -- Sigh: see Note [Root-main Id] in TcRnDriver ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] ; deprecs = mkIfaceDeprec src_deprecs @@ -309,9 +277,13 @@ mkIface hsc_env maybe_old_iface mi_deps = deps, mi_usages = usages, mi_exports = mkIfaceExports exports, + + -- Sort these lexicographically, so that + -- the result is stable across compilations mi_insts = sortLe le_inst iface_insts, mi_fam_insts= sortLe le_fam_inst iface_fam_insts, mi_rules = sortLe le_rule iface_rules, + mi_fixities = fixities, mi_deprecs = deprecs, mi_globals = Just rdr_env, @@ -322,6 +294,7 @@ mkIface hsc_env maybe_old_iface mi_rule_vers = initialVersion, mi_orphan = False, -- Always set by addVersionInfo, but -- it's a strict field, so we can't omit it. + mi_finsts = False, -- Ditto mi_decls = deliberatelyOmitted "decls", mi_ver_fn = deliberatelyOmitted "ver_fn", @@ -346,15 +319,19 @@ mkIface hsc_env maybe_old_iface ; return (new_iface, no_change_at_all) } where - r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 - i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 - i1 `le_fam_inst` i2 = ifFamInstTyConOcc i1 <= ifFamInstTyConOcc i2 + r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 + i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2 + i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2 + + le_occ :: Name -> Name -> Bool + -- Compare lexicographically by OccName, *not* by unique, because + -- the latter is not stable across compilations + le_occ n1 n2 = nameOccName n1 <= nameOccName n2 dflags = hsc_dflags hsc_env deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) - ifFamInstTyConOcc = nameOccName . ifaceTyConName . ifFamInstTyCon + ifFamInstTcName = ifaceTyConName . ifFamInstTyCon - ----------------------------- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () writeIfaceFile dflags location new_iface @@ -404,9 +381,12 @@ addVersionInfo addVersionInfo ver_fn Nothing new_iface new_decls -- No old interface, so definitely write a new one! = (new_iface { mi_orphan = anyNothing ifInstOrph (mi_insts new_iface) - || anyNothing ifRuleOrph (mi_rules new_iface), - mi_decls = [(initialVersion, decl) | decl <- new_decls], - mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion) new_decls)}, + || anyNothing ifRuleOrph (mi_rules new_iface) + , mi_finsts = not . null $ mi_fam_insts new_iface + , mi_decls = [(initialVersion, decl) | decl <- new_decls] + , mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion) + new_decls) + }, False, ptext SLIT("No old interface file"), pprOrphans orph_insts orph_rules) @@ -434,6 +414,7 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { mi_exp_vers = bump_unless no_export_change old_exp_vers, mi_rule_vers = bump_unless no_rule_change old_rule_vers, mi_orphan = not (null new_orph_rules && null new_orph_insts), + mi_finsts = not . null $ mi_fam_insts new_iface, mi_decls = decls_w_vers, mi_ver_fn = mkIfaceVerCache decls_w_vers } @@ -444,6 +425,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { mkOrphMap ifInstOrph (mi_insts old_iface) (new_non_orph_insts, new_orph_insts) = mkOrphMap ifInstOrph (mi_insts new_iface) + old_fam_insts = mi_fam_insts old_iface + new_fam_insts = mi_fam_insts new_iface same_insts occ = eqMaybeBy (eqListBy eqIfInst) (lookupOccEnv old_non_orph_insts occ) (lookupOccEnv new_non_orph_insts occ) @@ -463,7 +446,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { -- Kept sorted no_decl_change = isEmptyOccSet changed_occs no_rule_change = not (changedWrtNames changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules) - || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)) + || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts) + || changedWrtNames changed_occs (eqListBy eqIfFamInst old_fam_insts new_fam_insts)) no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface -- If the usages havn't changed either, we don't need to write the interface file @@ -554,7 +538,7 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { where occ = ifName new_decl why = case lookupOccEnv eq_env occ of - Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:"), + Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:") <> ppr names, nest 2 (braces (fsep (map ppr (occSetElts (occs `intersectOccSet` changed_occs)))))] where occs = mkOccSet (map nameOccName (nameSetToList names)) @@ -743,14 +727,15 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names -- a) we used something from; has something in used_names -- b) we imported all of it, even if we used nothing from it -- (need to recompile if its export list changes: export_vers) - -- c) is a home-package orphan module (need to recompile if its - -- instance decls change: rules_vers) + -- c) is a home-package orphan or family-instance module (need to + -- recompile if its instance decls change: rules_vers) mkUsage :: (ModuleName, IsBootInterface) -> Maybe Usage mkUsage (mod_name, _) | isNothing maybe_iface -- We can't depend on it if we didn't || (null used_occs -- load its interface. && isNothing export_vers - && not orphan_mod) + && not orphan_mod + && not finsts_mod) = Nothing -- Record no usage info | otherwise @@ -768,6 +753,7 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names Just iface = maybe_iface orphan_mod = mi_orphan iface + finsts_mod = mi_finsts iface version_env = mi_ver_fn iface mod_vers = mi_mod_vers iface rules_vers = mi_rule_vers iface @@ -1099,17 +1085,6 @@ tyThingToIfaceDecl (ATyCon tycon) = IfaceForeign { ifName = getOccName tycon, ifExtName = tyConExtName tycon } - | isPrimTyCon tycon || isFunTyCon tycon - -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), - ifCtxt = [], - ifCons = IfAbstractTyCon, - ifGadtSyntax = False, - ifGeneric = False, - ifRec = NonRecursive, - ifFamInst = Nothing } - | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where tyvars = tyConTyVars tycon