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 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -217,11 +217,9 @@ data CoreRule
        ru_rhs   :: CoreExpr,
 
        -- Locality
        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
                                -- 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.
 
   | 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 (file)
--- 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
                -- 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, 
 
              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
        ; return (Just rule)
        } } }
   where

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index bcff5f0..fac6c34 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -41,7 +41,6 @@ import SrcLoc
 import BasicTypes
 import Outputable
 import FastString
 import BasicTypes
 import Outputable
 import FastString

-import Module

 
 import Data.List
 import Data.Maybe
 
 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
                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,
        -- 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)]
 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
 
 -- -----------------------------------------------------------------------------
 -- Utils on IfaceSyn
 

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 0d4d163..e491039 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -183,6 +183,7 @@ import Id
 import IdInfo
 import NewDemand
 import CoreSyn
 import IdInfo
 import NewDemand
 import CoreSyn

+import CoreFVs

 import Class
 import TyCon
 import DataCon
 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
 
                ; 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_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!
 
 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) 
                , 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)
 
        = (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
 ----------------------
 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,
 --------------------------
 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,
                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)
 
                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,
 --------------------------
 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
 famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon,

@@ -1205,14 +1226,14 @@ toIfaceIdInfo id_info
                  | otherwise                      = Just (HsInline inline_prag)
 
 --------------------------
                  | 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
 
   = 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, 
   = 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
 
     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,  
 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 (file)
--- 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
   = 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, 
 
 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', 
         ; 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
                          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 (file)
--- 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
     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
 
        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
 
     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
 
        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 (file)
--- 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,
   = 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]
 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]

diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 665f231..9af9210 100644 (file)
--- 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!
       = [ (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, 
        , 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")
        , 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,
 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
                                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)
     ]
              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
 
 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
 -- 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
 -- 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
   = 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}
 
 
 \end{code}
 
 

diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 7d131d4..9cb68c8 100644 (file)
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -25,9 +25,6 @@ import Class
 import Var
 import VarSet
 import Name
 import Var
 import VarSet
 import Name

-import OccName
-import NameSet
-import Type

 import TcType
 import TyCon
 import TcGadt
 import TcType
 import TyCon
 import TcGadt

@@ -53,11 +50,11 @@ type DFunId = Id
 data Instance 
   = Instance { is_cls  :: Name         -- Class name
        
 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
 
                -- 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 
             , 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_dfun :: DFunId
             , is_flag :: OverlapFlag   -- See detailed comments with
                                        -- the decl of BasicTypes.OverlapFlag

-
-            , is_orph :: Maybe OccName }
+    }

 \end{code}
 
 \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
 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!
 
                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 
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 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.)
 
 
     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
 
 \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,
 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)
   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
                   -> 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,
   = 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)
 
   where
     (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)