Commit eb2bf7ad authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent ede4d6f3
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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}
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment