X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=564d3a4a7d695aa1c78c6d2654b5e4cfb420df56;hp=e99e8bf03853b126f418d74b6bf06056fdeaa6c2;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index e99e8bf..564d3a4 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,48 @@ 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 CoreFVs +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 VarEnv +import Var +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} @@ -275,10 +244,12 @@ mkIface hsc_env maybe_old_iface mg_deps = deps, mg_rdr_env = rdr_env, mg_fix_env = fix_env, - mg_deprecs = src_deprecs }) + mg_deprecs = src_deprecs, + mg_hpc_info = hpc_info }) (ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, + md_vect_info = vect_info, md_types = type_env, md_exports = exports }) @@ -291,17 +262,20 @@ 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 - ; iface_rules = map coreRuleToIfaceRule rules + ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts + ; iface_vect_info = flattenVectInfo vect_info ; intermediate_iface = ModIface { mi_module = this_mod, @@ -309,9 +283,15 @@ 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_vect_info = iface_vect_info, + mi_fixities = fixities, mi_deprecs = deprecs, mi_globals = Just rdr_env, @@ -322,8 +302,10 @@ 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", + mi_hpc = isHpcUsed hpc_info, -- And build the cached values mi_dep_fn = mkIfaceDepCache deprecs, @@ -346,15 +328,33 @@ 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 + + flattenVectInfo (VectInfo { vectInfoVar = vVar + , vectInfoTyCon = vTyCon + }) = + IfaceVectInfo { + ifaceVectInfoVar = [ Var.varName v + | (v, _) <- varEnvElts vVar], + ifaceVectInfoTyCon = [ tyConName t + | (t, t_v) <- nameEnvElts vTyCon + , t /= t_v], + ifaceVectInfoTyConReuse = [ tyConName t + | (t, t_v) <- nameEnvElts vTyCon + , t == t_v] + } - ----------------------------- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () writeIfaceFile dflags location new_iface @@ -403,10 +403,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)}, + = (new_iface { mi_orphan = not (null orph_insts && null orph_rules) + , 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 +436,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 +447,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,12 +468,14 @@ 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 no_other_changes = mi_usages new_iface == mi_usages old_iface && - mi_deps new_iface == mi_deps old_iface + mi_deps new_iface == mi_deps old_iface && + mi_hpc new_iface == mi_hpc old_iface no_change_at_all = no_output_change && no_other_changes pp_diffs = vcat [pp_change no_export_change "Export list" @@ -554,7 +561,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)) @@ -676,10 +683,6 @@ mkOrphMap get_key decls = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs) | otherwise = (non_orphs, d:orphs) -anyNothing :: (a -> Maybe b) -> [a] -> Bool -anyNothing p [] = False -anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs - ---------------------- mkIfaceDeprec :: Deprecations -> IfaceDeprecs mkIfaceDeprec NoDeprecs = NoDeprecs @@ -743,14 +746,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 +772,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 @@ -850,9 +855,8 @@ check_old_iface hsc_env mod_summary source_unchanged maybe_iface -- If the source has changed and we're in interactive mode, avoid reading -- an interface; just return the one we might have been supplied with. - ; ghc_mode <- getGhcMode - ; if (ghc_mode == Interactive || ghc_mode == JustTypecheck) - && not source_unchanged then + ; let dflags = hsc_dflags hsc_env + ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then return (outOfDate, maybe_iface) else case maybe_iface of { @@ -1080,10 +1084,12 @@ tyThingToIfaceDecl (AClass clas) tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType syn_tyki } + ifSynRhs = toIfaceType syn_tyki, + ifFamInst = famInstToIface (tyConFamInst_maybe tycon) + } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1099,31 +1105,19 @@ 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 (syn_isOpen, syn_tyki) = case synTyConRhs tycon of - OpenSynTyCon ki -> (True , ki) - SynonymTyCon ty -> (False, ty) + OpenSynTyCon ki _ -> (True , ki) + SynonymTyCon ty -> (False, ty) - ifaceConDecls (NewTyCon { data_con = con }) = + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = + ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls OpenDataTyCon = IfOpenDataTyCon - ifaceConDecls OpenNewTyCon = IfOpenNewTyCon - ifaceConDecls AbstractTyCon = IfAbstractTyCon + ifaceConDecls OpenTyCon {} = IfOpenDataTyCon + ifaceConDecls AbstractTyCon = IfAbstractTyCon -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used -- in TcRnDriver for GHCi, when browsing a module, in which case the @@ -1156,17 +1150,42 @@ getFS x = occNameFS (getOccName x) -------------------------- instanceToIfaceInst :: Instance -> IfaceInst instanceToIfaceInst ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, - is_cls = cls, is_tcs = mb_tcs, - is_orph = orph }) - = IfaceInst { ifDFun = getName dfun_id, + is_cls = cls_name, is_tcs = mb_tcs }) + = ASSERT( cls_name == className cls ) + IfaceInst { ifDFun = dfun_name, ifOFlag = oflag, - ifInstCls = cls, + ifInstCls = cls_name, ifInstTys = map do_rough mb_tcs, ifInstOrph = orph } where do_rough Nothing = Nothing do_rough (Just n) = Just (toIfaceTyCon_name n) + dfun_name = idName dfun_id + mod = nameModule dfun_name + is_local name = nameIsLocalOrFrom mod name + + -- Compute orphanhood. See Note [Orphans] in IfaceSyn + (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id) + -- Slightly awkward: we need the Class to get the fundeps + (tvs, fds) = classTvsFds cls + arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys] + orph | is_local cls_name = Just (nameOccName cls_name) + | all isJust mb_ns = head mb_ns + | otherwise = Nothing + + mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns | null fds = [choose_one arg_names] + | otherwise = map do_one fds + do_one (ltvs,rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names + , not (tv `elem` rtvs)] + + choose_one :: [NameSet] -> Maybe OccName + choose_one nss = case nameSetToList (unionManyNameSets nss) of + [] -> Nothing + (n:ns) -> Just (nameOccName n) + -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon, @@ -1179,6 +1198,22 @@ famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon, do_rough (Just n) = Just (toIfaceTyCon_name n) -------------------------- +toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) + (toIfaceType (idType id)) + prag_info + where + -- Stripped-down version of tcIfaceIdInfo + -- Change this if you want to export more IdInfo for + -- non-top-level Ids. Don't forget to change + -- CoreTidy.tidyLetBndr too! + -- + -- See Note [IdInfo on nested let-bindings] in IfaceSyn + id_info = idInfo id + inline_prag = inlinePragInfo id_info + prag_info | isAlwaysActive inline_prag = NoInfo + | otherwise = HasInfo [HsInline inline_prag] + +-------------------------- toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, @@ -1230,14 +1265,14 @@ toIfaceIdInfo id_info | otherwise = Just (HsInline inline_prag) -------------------------- -coreRuleToIfaceRule :: CoreRule -> IfaceRule -coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) +coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule +coreRuleToIfaceRule mod (BuiltinRule { ru_fn = fn}) = pprTrace "toHsRule: builtin" (ppr fn) $ bogusIfaceRule fn -coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, - ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, ru_orph = orph }) +coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, + ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs }) = IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = map toIfaceBndr bndrs, ifRuleHead = fn, @@ -1252,6 +1287,17 @@ coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) do_arg arg = toIfaceExpr arg + -- Compute orphanhood. See Note [Orphans] in IfaceSyn + -- A rule is an orphan only if none of the variables + -- mentioned on its left-hand side are locally defined + lhs_names = fn : nameSetToList (exprsFreeNames args) + -- No need to delete bndrs, because + -- exprsFreeNames finds only External names + + orph = case filter (nameIsLocalOrFrom mod) lhs_names of + (n:ns) -> Just (nameOccName n) + [] -> Nothing + bogusIfaceRule :: Name -> IfaceRule bogusIfaceRule id_name = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, @@ -1276,8 +1322,8 @@ toIfaceNote InlineMe = IfaceInlineMe toIfaceNote (CoreNote s) = IfaceCoreNote s --------------------- -toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r) -toIfaceBind (Rec prs) = IfaceRec [(toIfaceIdBndr b, toIfaceExpr r) | (b,r) <- prs] +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] --------------------- toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r) @@ -1316,6 +1362,8 @@ toIfaceVar v | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) -- Foreign calls have special syntax | isExternalName name = IfaceExt name + | Just (TickBox m ix) <- isTickBoxOp_maybe v + = IfaceTick m ix | otherwise = IfaceLcl (getFS name) where name = idName v