X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=a02f449f322c2dee8c9ce43c60d5a5f3715890f2;hb=8406c69e81f9416bc4b93c4323bbd36b25655e65;hp=751811125ed42b4178e925a342e19f270eb4c832;hpb=8100cd4395e46ae747be4298c181a4730d6206bc;p=ghc-hetmet.git diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7518111..a02f449 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -183,12 +183,12 @@ import Id import IdInfo import NewDemand import CoreSyn +import CoreFVs import Class import TyCon import DataCon import Type import TcType -import TysPrim import InstEnv import FamInstEnv import TcRnMonad @@ -258,15 +258,17 @@ 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 @@ -276,9 +278,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, @@ -314,15 +320,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 @@ -371,8 +381,7 @@ 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) + = (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) @@ -529,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)) @@ -651,10 +660,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 @@ -1080,16 +1085,16 @@ tyThingToIfaceDecl (ATyCon 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 { otIsNewtype = False } = IfOpenDataTyCon + ifaceConDecls OpenTyCon { otIsNewtype = True } = IfOpenNewTyCon + 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 @@ -1122,17 +1127,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, @@ -1196,14 +1226,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, @@ -1218,6 +1248,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,