From: simonpj@microsoft.com Date: Wed, 21 Feb 2007 16:30:47 +0000 (+0000) Subject: Deal more correctly with orphan instances X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=eb2bf7ad9f967861da2e19ff71a80428c7c2df28 Deal more correctly with orphan instances Conal Eliott (Trac #1145) exposed a nasty flaw in the way in which orphan instances are computed, when there are functional dependencies in the class. It took me some time to figure out what was going on, and led to more refactoring. Briefly: * Elaborate comments about orphan-hood and versioning added to IfaceSyn * The is_orph field vanishes from InstEnv.Instance * Similarly ru_orph vanishes from CoreSyn.CoreRule * Orphan-hood is computed in MkIface.instanceToIfaceInst, and MkIface.coreRuleToIfaceRule Elsewhere just tidying up. --- diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 8c799b5..d89f542 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -217,11 +217,9 @@ data CoreRule ru_rhs :: CoreExpr, -- Locality - ru_local :: Bool, -- The fn at the head of the rule is + ru_local :: Bool -- The fn at the head of the rule is -- defined in the same module as the rule - - -- Orphan-hood; see Note [Orphans] in InstEnv - ru_orph :: Maybe OccName } + } | BuiltinRule { -- Built-in rules are used for constant folding ru_name :: RuleName, -- and suchlike. It has no free variables. diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index b4ff273..99be1b0 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -297,20 +297,11 @@ dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs)) -- NB we can't use isLocalId in the orphan test, -- because isLocalId isn't true of class methods fn_name = idName fn_id - lhs_names = fn_name : nameSetToList (exprsFreeNames args) - -- No need to delete bndrs, because - -- exprsFreeNames finds only External names - - -- A rule is an orphan only if none of the variables - -- mentioned on its left-hand side are locally defined - orph = case filter (nameIsLocalOrFrom mod) lhs_names of - (n:ns) -> Just (nameOccName n) - [] -> Nothing rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act, ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs', ru_rough = roughTopNames args, - ru_local = local_rule, ru_orph = orph } + ru_local = local_rule } ; return (Just rule) } } } where diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index bcff5f0..fac6c34 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -41,7 +41,6 @@ import SrcLoc import BasicTypes import Outputable import FastString -import Module import Data.List import Data.Maybe @@ -140,7 +139,7 @@ data IfaceInst ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance ifDFun :: Name, -- The dfun ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance + ifInstOrph :: Maybe OccName } -- See Note [Orphans] -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -224,7 +223,84 @@ data IfaceConAlt = IfaceDefault data IfaceBinding = IfaceNonRec IfaceIdBndr IfaceExpr | IfaceRec [(IfaceIdBndr, IfaceExpr)] +\end{code} + +Note [Orphans]: the ifInstOrph and ifRuleOrph fields +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a module contains any "orphans", then its interface file is read +regardless, so that its instances are not missed. + +Roughly speaking, an instance is an orphan if its head (after the =>) +mentions nothing defined in this module. Functional dependencies +complicate the situation though. Consider + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data T = ... + instance C Int T where ... + +This instance is an orphan, because when compiling a third module Y we +might get a constraint (C Int v), and we'd want to improve v to T. So +we must make sure X's instances are loaded, even if we do not directly +use anything from X. + +More precisely, an instance is an orphan iff + + If there are no fundeps, then at least of the names in + the instance head is locally defined. + + If there are fundeps, then for every fundep, at least one of the + names free in a *non-determined* part of the instance head is + defined in this module. + +(Note that these conditions hold trivially if the class is locally +defined.) +Note [Versioning of instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Now consider versioning. If we *use* an instance decl in one compilation, +we'll depend on the dfun id for that instance, so we'll recompile if it changes. +But suppose we *don't* (currently) use an instance! We must recompile if +the instance is changed in such a way that it becomes important. (This would +only matter with overlapping instances, else the importing module wouldn't have +compiled before and the recompilation check is irrelevant.) + +The is_orph field is set to (Just n) if the instance is not an orphan. +The 'n' is *any* of the locally-defined names mentioned anywhere in the +instance head. This name is used for versioning; the instance decl is +considered part of the defn of this 'n'. + +I'm worried about whether this works right if we pick a name from +a functionally-dependent part of the instance decl. E.g. + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data S = ... + data T = ... + instance C S T where ... + +If we base the instance verion on T, I'm worried that changing S to S' +would change T's version, but not S or S'. But an importing module might +not depend on T, and so might not be recompiled even though the new instance +(C S' T) might be relevant. I have not been able to make a concrete example, +and it seems deeply obscure, so I'm going to leave it for now. + + +Note [Versioning of rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A rule that is not an orphan has an ifRuleOrph field of (Just n), where +n appears on the LHS of the rule; any change in the rule changes the version of n. + + +\begin{code} -- ----------------------------------------------------------------------------- -- Utils on IfaceSyn diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 0d4d163..e491039 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -183,6 +183,7 @@ import Id import IdInfo import NewDemand import CoreSyn +import CoreFVs import Class import TyCon import DataCon @@ -267,7 +268,7 @@ mkIface hsc_env maybe_old_iface ; 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 @@ -380,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) @@ -660,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 @@ -1131,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, @@ -1205,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, @@ -1227,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, diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index b4bf2ed..1643e19 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -499,7 +499,7 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedInstance cls mb_tcs' orph dfun oflag) } + ; return (mkImportedInstance cls mb_tcs' dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, @@ -547,7 +547,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ; let this_module = if_mod lcl ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', - ru_rhs = rhs', ru_orph = orph, + ru_rhs = rhs', ru_rough = mb_tcs, ru_local = nameModule fn == this_module }) } where diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 8189c2a..0c09827 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -143,7 +143,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot let imp_mod = mi_module iface deprecs = mi_deprecs iface - is_orph = mi_orphan iface + orph_iface = mi_orphan iface has_finsts = mi_finsts iface deps = mi_deps iface @@ -186,9 +186,9 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot let -- Compute new transitive dependencies - orphans | is_orph = ASSERT( not (imp_mod `elem` dep_orphs deps) ) - imp_mod : dep_orphs deps - | otherwise = dep_orphs deps + orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) ) + imp_mod : dep_orphs deps + | otherwise = dep_orphs deps finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) ) imp_mod : dep_finsts deps diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 10eb3f8..4b7e926 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -91,7 +91,7 @@ mkLocalRule name act fn bndrs args rhs = Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, ru_rough = roughTopNames args, - ru_orph = Just (nameOccName fn), ru_local = True } + ru_local = True } -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs index 665f231..9af9210 100644 --- a/compiler/types/FunDeps.lhs +++ b/compiler/types/FunDeps.lhs @@ -271,10 +271,14 @@ improveOne inst_env pred@(ClassP cls tys, _) preds = [ (eqn, p_inst, pred) | fd <- cls_fds -- Iterate through the fundeps first, -- because there often are none! - , let rough_fd_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs + , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs + -- Trim the rough_tcs based on the head of the fundep. + -- Remember that instanceCantMatch treats both argumnents + -- symmetrically, so it's ok to trim the rough_tcs, + -- rather than trimming each inst_tcs in turn , ispec@(Instance { is_tvs = qtvs, is_tys = tys_inst, - is_tcs = mb_tcs_inst }) <- instances - , not (instanceCantMatch mb_tcs_inst rough_fd_tcs) + is_tcs = inst_tcs }) <- instances + , not (instanceCantMatch inst_tcs trimmed_tcs) , eqn <- checkClsFD qtvs fd cls_tvs tys_inst tys , let p_inst = (mkClassPred cls tys_inst, ptext SLIT("arising from the instance declaration at") @@ -455,11 +459,11 @@ badFunDeps :: [Instance] -> Class badFunDeps cls_insts clas ins_tv_set ins_tys = [ ispec | fd <- fds, -- fds is often empty let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs, - ispec@(Instance { is_tcs = mb_tcs, is_tvs = tvs, + ispec@(Instance { is_tcs = inst_tcs, is_tvs = tvs, is_tys = tys }) <- cls_insts, -- Filter out ones that can't possibly match, -- based on the head of the fundep - not (instanceCantMatch trimmed_tcs mb_tcs), + not (instanceCantMatch inst_tcs trimmed_tcs), notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys) ] @@ -469,16 +473,16 @@ badFunDeps cls_insts clas ins_tv_set ins_tys trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] -- Computing rough_tcs for a particular fundep --- class C a b c | a c -> b where ... +-- class C a b c | a -> b where ... -- For each instance .... => C ta tb tc --- we want to match only on the types ta, tb; so our +-- we want to match only on the types ta, tc; so our -- rough-match thing must similarly be filtered. -- Hence, we Nothing-ise the tb type right here -trimRoughMatchTcs clas_tvs (ltvs,_) mb_tcs +trimRoughMatchTcs clas_tvs (_,rtvs) mb_tcs = zipWith select clas_tvs mb_tcs where - select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = Nothing + select clas_tv mb_tc | clas_tv `elem` rtvs = Nothing + | otherwise = mb_tc \end{code} diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 7d131d4..9cb68c8 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -25,9 +25,6 @@ import Class import Var import VarSet import Name -import OccName -import NameSet -import Type import TcType import TyCon import TcGadt @@ -53,11 +50,11 @@ type DFunId = Id data Instance = Instance { is_cls :: Name -- Class name - -- Used for "rough matching"; see note below + -- Used for "rough matching"; see Note [Rough-match field] -- INVARIANT: is_tcs = roughMatchTcs is_tys , is_tcs :: [Maybe Name] -- Top of type args - -- Used for "proper matching"; see note + -- Used for "proper matching"; see Note [Proper-match fields] , is_tvs :: TyVarSet -- Template tyvars for full match , is_tys :: [Type] -- Full arg types -- INVARIANT: is_dfun Id has type @@ -66,13 +63,12 @@ data Instance , is_dfun :: DFunId , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag - - , is_orph :: Maybe OccName } + } \end{code} -The "rough-match" fields -~~~~~~~~~~~~~~~~~~~~~~~~~ -The is_cls, is_args fields allow a "rough match" to be done +Note [Rough-match field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_cls, is_tcs fields allow a "rough match" to be done without poking inside the DFunId. Poking the DFunId forces us to suck in all the type constructors etc it involves, which is a total waste of time if it has no chance of matching @@ -89,7 +85,7 @@ In is_tcs, different real tycons can't.) NB: newtypes are not transparent, though! -The "proper-match" fields +Note [Proper-match fields] ~~~~~~~~~~~~~~~~~~~~~~~~~ The is_tvs, is_tys fields are simply cached values, pulled out (lazily) from the dfun id. They are cached here simply so @@ -105,31 +101,6 @@ However, note that: instantiate the dfun's context.) -Note [Orphans]: the "is_orph" field -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An instance is an orphan if its head (after the =>) mentions -nothing defined in this module. - - Just n The head mentions n, which is defined in this module - This is used for versioning; the instance decl is - considered part of the defn of n when computing versions - - Nothing The head mentions nothing defined in this module - -If a module contains any orphans, then its interface file is read -regardless, so that its instances are not missed. - -Functional dependencies worsen the situation a bit. Consider - class C a b | a -> b -In some other module we might have - module M where - data T = ... - instance C Int T where ... -This isn't considered an orphan, so we will only read M's interface -if something from M is used (e.g. T). So there's a risk we'll -miss the improvement from the instance. Workaround: import M. - -Rules are orphans and versioned in much the same way. \begin{code} instanceDFunId :: Instance -> DFunId @@ -186,26 +157,18 @@ mkLocalInstance :: DFunId -> OverlapFlag -> Instance mkLocalInstance dfun oflag = Instance { is_flag = oflag, is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys, - is_cls = cls_name, is_tcs = roughMatchTcs tys, - is_orph = orph } + is_cls = className cls, is_tcs = roughMatchTcs tys } where (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) - mod = nameModule (idName dfun) - cls_name = getName cls - tycl_names = foldr (unionNameSets . tyClsNamesOfType) - (unitNameSet cls_name) tys - orph = case filter (nameIsLocalOrFrom mod) (nameSetToList tycl_names) of - [] -> Nothing - (n:ns) -> Just (getOccName n) - -mkImportedInstance :: Name -> [Maybe Name] -> Maybe OccName + +mkImportedInstance :: Name -> [Maybe Name] -> DFunId -> OverlapFlag -> Instance -- Used for imported instances, where we get the rough-match stuff -- from the interface file -mkImportedInstance cls mb_tcs orph dfun oflag +mkImportedInstance cls mb_tcs dfun oflag = Instance { is_flag = oflag, is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys, - is_cls = cls, is_tcs = mb_tcs, is_orph = orph } + is_cls = cls, is_tcs = mb_tcs } where (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)