diff options
34 files changed, 429 insertions, 98 deletions
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 57f02d9b2a..120a11438b 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -72,7 +72,7 @@ module Module ModuleNameEnv, -- * Sets of Modules - ModuleSet, + ModuleSet, VisibleOrphanModules, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet ) where @@ -511,5 +511,10 @@ UniqFM. \begin{code} -- | A map keyed off of 'ModuleName's (actually, their 'Unique's) type ModuleNameEnv elt = UniqFM elt + +-- | Set of visible orphan modules, according to what modules have been directly +-- imported. This is based off of the dep_orphs field, which records +-- transitively reachable orphan modules (modules that define orphan instances). +type VisibleOrphanModules = ModuleSet \end{code} diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 3d602dd5a7..98bfae9f81 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -56,6 +56,7 @@ import HsBinds import TyCon (Role (..)) import StaticFlags (opt_PprStyle_Debug) import Util( filterOut ) +import InstEnv import Control.Monad import System.IO.Unsafe @@ -213,7 +214,7 @@ data IfaceClsInst ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst ifDFun :: IfExtName, -- The dfun ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See Note [Orphans] + ifInstOrph :: IsOrphan } -- 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, @@ -227,7 +228,7 @@ data IfaceFamInst = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name , ifFamInstTys :: [Maybe IfaceTyCon] -- See above , ifFamInstAxiom :: IfExtName -- The axiom - , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst + , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst } data IfaceRule @@ -239,7 +240,7 @@ data IfaceRule ifRuleArgs :: [IfaceExpr], -- Args of LHS ifRuleRhs :: IfaceExpr, ifRuleAuto :: Bool, - ifRuleOrph :: Maybe OccName -- Just like IfaceClsInst + ifRuleOrph :: IsOrphan -- Just like IfaceClsInst } data IfaceAnnotation diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 85bd396cd8..8b5dac58e7 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -339,10 +339,10 @@ mkIface_ hsc_env maybe_old_fingerprint unqual = mkPrintUnqualified dflags rdr_env inst_warns = listToBag [ instOrphWarn dflags unqual d | (d,i) <- insts `zip` iface_insts - , isNothing (ifInstOrph i) ] + , isOrphan (ifInstOrph i) ] rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r | r <- iface_rules - , isNothing (ifRuleOrph r) + , isOrphan (ifRuleOrph r) , if ifRuleAuto r then warn_auto_orphs else warn_orphs ] @@ -934,17 +934,16 @@ ruleOrphWarn dflags unqual mod rule -- (a) an OccEnv for ones that are not orphans, -- mapping the local OccName to a list of its decls -- (b) a list of orphan decls -mkOrphMap :: (decl -> Maybe OccName) -- (Just occ) for a non-orphan decl, keyed by occ - -- Nothing for an orphan decl - -> [decl] -- Sorted into canonical order - -> (OccEnv [decl], -- Non-orphan decls associated with their key; - -- each sublist in canonical order - [decl]) -- Orphan decls; in canonical order +mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl + -> [decl] -- Sorted into canonical order + -> (OccEnv [decl], -- Non-orphan decls associated with their key; + -- each sublist in canonical order + [decl]) -- Orphan decls; in canonical order mkOrphMap get_key decls = foldl go (emptyOccEnv, []) decls where go (non_orphs, orphs) d - | Just occ <- get_key d + | NotOrphan occ <- get_key d = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs) | otherwise = (non_orphs, d:orphs) \end{code} @@ -1797,7 +1796,8 @@ getFS x = occNameFS (getOccName x) instanceToIfaceInst :: ClsInst -> IfaceClsInst instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag , is_cls_nm = cls_name, is_cls = cls - , is_tys = tys, is_tcs = mb_tcs }) + , is_tcs = mb_tcs + , is_orphan = orph }) = ASSERT( cls_name == className cls ) IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag, @@ -1809,29 +1809,7 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag do_rough (Just n) = Just (toIfaceTyCon_name n) dfun_name = idName dfun_id - mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name - is_local name = nameIsLocalOrFrom mod name - -- Compute orphanhood. See Note [Orphans] in IfaceSyn - (tvs, fds) = classTvsFds cls - arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] - - -- See Note [When exactly is an instance decl an orphan?] in IfaceSyn - orph | is_local cls_name = Just (nameOccName cls_name) - | all isJust mb_ns = ASSERT( not (null 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 nameSetElems (unionNameSets nss) of - [] -> Nothing - (n : _) -> Just (nameOccName n) -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst @@ -1854,14 +1832,14 @@ famInstToIfaceFamInst (FamInst { fi_axiom = axiom, lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom) orph | is_local fam_decl - = Just (nameOccName fam_decl) + = NotOrphan (nameOccName fam_decl) | not (isEmptyNameSet lhs_names) - = Just (nameOccName (head (nameSetElems lhs_names))) + = NotOrphan (nameOccName (head (nameSetElems lhs_names))) | otherwise - = Nothing + = IsOrphan -------------------------- toIfaceLetBndr :: Id -> IfaceLetBndr @@ -1976,14 +1954,15 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, lhs_names = nameSetElems (ruleLhsOrphNames rule) orph = case filter (nameIsLocalOrFrom mod) lhs_names of - (n : _) -> Just (nameOccName n) - [] -> Nothing + (n : _) -> NotOrphan (nameOccName n) + [] -> IsOrphan bogusIfaceRule :: Name -> IfaceRule bogusIfaceRule id_name = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive, ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], - ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True } + ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan, + ifRuleAuto = True } --------------------- toIfaceExpr :: CoreExpr -> IfaceExpr diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index adc6725284..10984ece24 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -735,11 +735,12 @@ look at it. \begin{code} tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag - , ifInstCls = cls, ifInstTys = mb_tcs }) + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) = 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' dfun oflag) } + ; return (mkImportedInstance cls mb_tcs' dfun oflag orph) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index bb3fd380bc..cf3db52c94 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1971,9 +1971,13 @@ data Dependencies -- (Safe Haskell). See Note [RnNames . Tracking Trust Transitively] , dep_orphs :: [Module] - -- ^ Orphan modules (whether home or external pkg), - -- *not* including family instance orphans as they - -- are anyway included in 'dep_finsts' + -- ^ Transitive closure of orphan modules (whether + -- home or external pkg). + -- + -- (Possible optimization: don't include family + -- instance orphans as they are anyway included in + -- 'dep_finsts'. But then be careful about code + -- which relies on dep_orphs having the complete list!) , dep_finsts :: [Module] -- ^ Modules that contain family instances (whether the diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.lhs index 6fb9b3f798..e636d5b533 100644 --- a/compiler/typecheck/FunDeps.lhs +++ b/compiler/typecheck/FunDeps.lhs @@ -203,7 +203,7 @@ pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs), nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | (FDEq _ t1 t2) <- pairs])] -improveFromInstEnv :: (InstEnv,InstEnv) +improveFromInstEnv :: InstEnvs -> PredType -> [Equation SrcSpan] -- Needs to be an Equation because -- of quantified variables @@ -522,7 +522,7 @@ if s1 matches \begin{code} -checkFunDeps :: (InstEnv, InstEnv) -> ClsInst +checkFunDeps :: InstEnvs -> ClsInst -> Maybe [ClsInst] -- Nothing <=> ok -- Just dfs <=> conflict with dfs -- Check whether adding DFunId would break functional-dependency constraints diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index de7668db48..f3d3dff2c2 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -398,11 +398,14 @@ getOverlapFlag overlap_mode final_oflag = setOverlapModeMaybe default_oflag overlap_mode ; return final_oflag } -tcGetInstEnvs :: TcM (InstEnv, InstEnv) +tcGetInstEnvs :: TcM InstEnvs -- Gets both the external-package inst-env -- and the home-pkg inst env (includes module being compiled) -tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; - return (eps_inst_env eps, tcg_inst_env env) } +tcGetInstEnvs = do { eps <- getEps + ; env <- getGblEnv + ; return (InstEnvs (eps_inst_env eps) + (tcg_inst_env env) + (tcg_visible_orphan_mods env))} tcGetInsts :: TcM [ClsInst] -- Gets the local class instances. @@ -482,7 +485,9 @@ addLocalInst (home_ie, my_insts) ispec global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv | otherwise = eps_inst_env eps - inst_envs = (global_ie, home_ie') + inst_envs = InstEnvs global_ie + home_ie' + (tcg_visible_orphan_mods tcg_env) (matches, _, _) = lookupInstEnv inst_envs cls tys dups = filter (identicalInstHead ispec) (map fst matches) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index cb83d1b2d9..765ac4d071 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -226,9 +226,11 @@ tcLookupInstance cls tys extractTyVar _ = panic "TcEnv.tcLookupInstance: extractTyVar" -- NB: duplicated to prevent circular dependence on Inst - tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; - ; return (eps_inst_env eps, tcg_inst_env env) - } + tcGetInstEnvs = do { eps <- getEps + ; env <- getGblEnv + ; return (InstEnvs (eps_inst_env eps) + (tcg_inst_env env) + (tcg_visible_orphan_mods env)) } \end{code} \begin{code} diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs index a59206eb00..9ba89ccfc1 100644 --- a/compiler/typecheck/TcPluginM.hs +++ b/compiler/typecheck/TcPluginM.hs @@ -101,7 +101,7 @@ getTopEnv = unsafeTcPluginTcM TcRnMonad.getTopEnv getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) getEnvs = unsafeTcPluginTcM TcRnMonad.getEnvs -getInstEnvs :: TcPluginM (InstEnv, InstEnv) +getInstEnvs :: TcPluginM InstEnvs getInstEnvs = unsafeTcPluginTcM Inst.tcGetInstEnvs getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 0ca12bfbfc..6d91d267b9 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -419,6 +419,9 @@ tcRnImports hsc_env import_decls tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports, + tcg_visible_orphan_mods = foldl extendModuleSet + (tcg_visible_orphan_mods gbl) + (imp_orphs imports), tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, @@ -1404,6 +1407,14 @@ runTcInteractive hsc_env thing_inside vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) , let local_gres = filter isLocalGRE gres , not (null local_gres) ]) ] + ; let getOrphans m = fmap (concatMap (\iface -> mi_module iface + : dep_orphs (mi_deps iface))) + (loadSrcInterface (text "runTcInteractive") m + False Nothing) + ; ic_visible_mods <- fmap concat . forM (ic_imports icxt) $ \i -> + case i of + IIModule n -> getOrphans n + IIDecl i -> getOrphans (unLoc (ideclName i)) ; gbl_env <- getGblEnv ; let gbl_env' = gbl_env { tcg_rdr_env = ic_rn_gbl_env icxt @@ -1422,7 +1433,13 @@ runTcInteractive hsc_env thing_inside -- setting tcg_field_env is necessary -- to make RecordWildCards work (test: ghci049) , tcg_fix_env = ic_fix_env icxt - , tcg_default = ic_default icxt } + , tcg_default = ic_default icxt + , tcg_visible_orphan_mods = mkModuleSet ic_visible_mods + -- I guess there's a risk ic_imports will be + -- desynchronized with the true RdrEnv; probably + -- should insert some ASSERTs somehow. + -- TODO: Cache this + } ; setGblEnv gbl_env' $ tcExtendGhciIdEnv ty_things $ -- See Note [Initialising the type environment for GHCi] @@ -1957,7 +1974,7 @@ tcRnGetInfo hsc_env name lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) lookupInsts (ATyCon tc) - = do { (pkg_ie, home_ie) <- tcGetInstEnvs + = do { InstEnvs pkg_ie home_ie vis_mods <- tcGetInstEnvs ; (pkg_fie, home_fie) <- tcGetFamInstEnvs -- Load all instances for all classes that are -- in the type environment (which are all the ones @@ -1968,6 +1985,7 @@ lookupInsts (ATyCon tc) ; let cls_insts = [ ispec -- Search all | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , instIsVisible vis_mods ispec , tc_name `elemNameSet` orphNamesOfClsInst ispec ] ; let fam_insts = [ fispec diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index a4e1e11c13..15a6ba7262 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -132,6 +132,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, tcg_ann_env = emptyAnnEnv, + tcg_visible_orphan_mods = mkModuleSet [mod], tcg_th_used = th_var, tcg_th_splice_used = th_splice_var, tcg_exports = [], @@ -1307,7 +1308,9 @@ mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv - ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) } + ; let { if_env = IfGblEnv { + if_rec_types = Just (tcg_mod tcg_env, get_type_env) + } ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } ; setEnvs (if_env, ()) thing_inside } @@ -1327,7 +1330,9 @@ initIfaceTc :: ModIface -- No type envt from the current module, but we do know the module dependencies initIfaceTc iface do_this = do { tc_env_var <- newTcRef emptyTypeEnv - ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readTcRef tc_env_var) } ; + ; let { gbl_env = IfGblEnv { + if_rec_types = Just (mod, readTcRef tc_env_var) + } ; ; if_lenv = mkIfLclEnv mod doc } ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var) diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index cc9a7699e2..cf8b56cd04 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -269,6 +269,11 @@ data TcGblEnv tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances tcg_ann_env :: AnnEnv, -- ^ And for annotations + tcg_visible_orphan_mods :: ModuleSet, + -- ^ The set of orphan modules which transitively reachable from + -- direct imports. We use this to figure out if an orphan instance + -- in the global InstEnv should be considered visible. + -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. -- Nevertheless, it's convenient to accumulate them along diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 9355e3b498..0699122f5c 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1350,7 +1350,7 @@ getDefaultInfo = wrapTcS TcM.tcGetDefaultTys -- Just get some environments needed for instance looking up and matching -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -getInstEnvs :: TcS (InstEnv, InstEnv) +getInstEnvs :: TcS InstEnvs getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 411b006059..cf7110981e 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -17,15 +17,19 @@ module InstEnv ( instanceDFunId, tidyClsInstDFun, instanceRoughTcs, fuzzyClsInstCmp, - InstEnv, emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalInstHead, + IsOrphan(..), isOrphan, notOrphan, + + InstEnvs(..), InstEnv, + emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalInstHead, extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts, - memberInstEnv, + memberInstEnv, instIsVisible, classInstances, orphNamesOfClsInst, instanceBindFun, instanceCantMatch, roughMatchTcs ) where #include "HsVersions.h" +import Module import Class import Var import VarSet @@ -40,6 +44,7 @@ import BasicTypes import UniqFM import Util import Id +import Binary import FastString import Data.Data ( Data, Typeable ) import Data.Maybe ( isJust, isNothing ) @@ -56,6 +61,35 @@ import Data.Monoid %************************************************************************ \begin{code} + +-- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' +-- witnessing the instance's non-orphanhood. +data IsOrphan = IsOrphan | NotOrphan OccName + deriving (Data, Typeable) + +-- | Returns true if 'IsOrphan' is orphan. +isOrphan :: IsOrphan -> Bool +isOrphan IsOrphan = True +isOrphan _ = False + +-- | Returns true if 'IsOrphan' is not an orphan. +notOrphan :: IsOrphan -> Bool +notOrphan NotOrphan{} = True +notOrphan _ = False + +instance Binary IsOrphan where + put_ bh IsOrphan = putByte bh 0 + put_ bh (NotOrphan n) = do + putByte bh 1 + put_ bh n + get bh = do + h <- getByte bh + case h of + 0 -> return IsOrphan + _ -> do + n <- get bh + return $ NotOrphan n + data ClsInst = ClsInst { -- Used for "rough matching"; see Note [Rough-match field] -- INVARIANT: is_tcs = roughMatchTcs is_tys @@ -78,6 +112,7 @@ data ClsInst , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag + , is_orphan :: IsOrphan } deriving (Data, Typeable) @@ -211,22 +246,59 @@ mkLocalInstance :: DFunId -> OverlapFlag -> [TyVar] -> Class -> [Type] -> ClsInst -- Used for local instances, where we can safely pull on the DFunId -mkLocalInstance dfun oflag tvs cls tys +-- TODO: what is the difference between source_tvs and tvs? +mkLocalInstance dfun oflag source_tvs cls tys = ClsInst { is_flag = oflag, is_dfun = dfun - , is_tvs = tvs - , is_cls = cls, is_cls_nm = className cls - , is_tys = tys, is_tcs = roughMatchTcs tys } - -mkImportedInstance :: Name -> [Maybe Name] - -> DFunId -> OverlapFlag -> ClsInst + , is_tvs = source_tvs + , is_cls = cls, is_cls_nm = cls_name + , is_tys = tys, is_tcs = roughMatchTcs tys + , is_orphan = orph + } + where + cls_name = className cls + dfun_name = idName dfun + this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name + is_local name = nameIsLocalOrFrom this_mod name + + -- Compute orphanhood. See Note [Orphans] in IfaceSyn + (tvs, fds) = classTvsFds cls + arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] + + -- See Note [When exactly is an instance decl an orphan?] in IfaceSyn + orph | is_local cls_name = NotOrphan (nameOccName cls_name) + | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns + | otherwise = IsOrphan + + notOrphan NotOrphan{} = True + notOrphan _ = False + + mb_ns :: [IsOrphan] -- 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] -> IsOrphan + choose_one nss = case nameSetElems (unionNameSets nss) of + [] -> IsOrphan + (n : _) -> NotOrphan (nameOccName n) + +mkImportedInstance :: Name + -> [Maybe Name] + -> DFunId + -> OverlapFlag + -> IsOrphan + -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file -- The bound tyvars of the dfun are guaranteed fresh, because -- the dfun has been typechecked out of the same interface file -mkImportedInstance cls_nm mb_tcs dfun oflag +mkImportedInstance cls_nm mb_tcs dfun oflag orphan = ClsInst { is_flag = oflag, is_dfun = dfun , is_tvs = tvs, is_tys = tys - , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs } + , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs + , is_orphan = orphan } where (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) @@ -390,6 +462,16 @@ or, to put it another way, we have --------------------------------------------------- type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class +-- | 'InstEnvs' represents the combination of the global type class instance +-- environment, the local type class instance environment, and the set of +-- transitively reachable orphan modules (according to what modules have been +-- directly imported) used to test orphan instance visibility. +data InstEnvs = InstEnvs { + ie_global :: InstEnv, + ie_local :: InstEnv, + ie_visible :: VisibleOrphanModules + } + newtype ClsInstEnv = ClsIE [ClsInst] -- The instances for a particular class, in any order @@ -411,9 +493,21 @@ emptyInstEnv = emptyUFM instEnvElts :: InstEnv -> [ClsInst] instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts] -classInstances :: (InstEnv,InstEnv) -> Class -> [ClsInst] -classInstances (pkg_ie, home_ie) cls - = get home_ie ++ get pkg_ie +-- | Test if an instance is visible, by checking that its origin module +-- is in 'VisibleOrphanModules'. +instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool +instIsVisible vis_mods ispec + -- NB: Instances from the interactive package always are visible. We can't + -- add interactive modules to the set since we keep creating new ones + -- as a GHCi session progresses. + | isInteractiveModule mod = True + | IsOrphan <- is_orphan ispec = mod `elemModuleSet` vis_mods + | otherwise = True + where mod = nameModule (idName (is_dfun ispec)) + +classInstances :: InstEnvs -> Class -> [ClsInst] +classInstances (InstEnvs pkg_ie home_ie vis_mods) cls + = filter (instIsVisible vis_mods) (get home_ie ++ get pkg_ie) where get env = case lookupUFM env cls of Just (ClsIE insts) -> insts @@ -555,7 +649,7 @@ where the 'Nothing' indicates that 'b' can be freely instantiated. -- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, -- yield 'Left errorMessage'. -- -lookupUniqueInstEnv :: (InstEnv, InstEnv) +lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] -> Either MsgDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys @@ -570,6 +664,7 @@ lookupUniqueInstEnv instEnv cls tys _other -> Left $ ptext (sLit "instance not found") <+> (ppr $ mkTyConApp (classTyCon cls) tys) lookupInstEnv' :: InstEnv -- InstEnv to look in + -> VisibleOrphanModules -- But filter against this -> Class -> [Type] -- What we are looking for -> ([InstMatch], -- Successful matches [ClsInst]) -- These don't match but do unify @@ -583,7 +678,7 @@ lookupInstEnv' :: InstEnv -- InstEnv to look in -- but Foo [Int] is a unifier. This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv' ie cls tys +lookupInstEnv' ie vis_mods cls tys = lookup ie where rough_tcs = roughMatchTcs tys @@ -597,6 +692,8 @@ lookupInstEnv' ie cls tys find ms us [] = (ms, us) find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs , is_tys = tpl_tys, is_flag = oflag }) : rest) + | not (instIsVisible vis_mods item) + = find ms us rest -- Fast check for no match, uses the "rough match" fields | instanceCantMatch rough_tcs mb_tcs = find ms us rest @@ -632,15 +729,15 @@ lookupInstEnv' ie cls tys --------------- -- This is the common way to call this function. -lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env +lookupInstEnv :: InstEnvs -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ClsInstLookupResult -- ^ See Note [Rules for instance lookup] -lookupInstEnv (pkg_ie, home_ie) cls tys +lookupInstEnv (InstEnvs pkg_ie home_ie vis_mods) cls tys = (final_matches, final_unifs, safe_fail) where - (home_matches, home_unifs) = lookupInstEnv' home_ie cls tys - (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie cls tys + (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys + (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys all_matches = home_matches ++ pkg_matches all_unifs = home_unifs ++ pkg_unifs pruned_matches = foldr insert_overlapping [] all_matches diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 3358ceafab..098e9c8227 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -123,7 +123,7 @@ data GlobalEnv , global_pr_funs :: NameEnv Var -- ^Mapping from TyCons to their PR dfuns. - , global_inst_env :: (InstEnv, InstEnv) + , global_inst_env :: InstEnvs -- ^External package inst-env & home-package inst-env for class instances. , global_fam_inst_env :: FamInstEnvs @@ -139,7 +139,12 @@ data GlobalEnv -- to the global table, so that we can query scalarness during vectorisation, and especially, when -- vectorising the scalar entities' definitions themselves. -- -initGlobalEnv :: Bool -> VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv +initGlobalEnv :: Bool + -> VectInfo + -> [CoreVect] + -> InstEnvs + -> FamInstEnvs + -> GlobalEnv initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs = GlobalEnv { global_vect_avoid = vectAvoid diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index b530b3c6a6..3e6c33ac7d 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -42,6 +42,7 @@ import Id import Name import ErrUtils import Outputable +import Module -- |Run a vectorisation computation. @@ -85,7 +86,9 @@ initV hsc_env guts info thing_inside -- set up class and type family envrionments ; eps <- liftIO $ hscEPS hsc_env ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) - instEnvs = (eps_inst_env eps, mg_inst_env guts) + instEnvs = InstEnvs (eps_inst_env eps) + (mg_inst_env guts) + (mkModuleSet (dep_orphs (mg_deps guts))) builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all 'PA' and.. builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances @@ -114,7 +117,7 @@ initV hsc_env guts info thing_inside -- instance dfun for that type constructor and class. (DPH class instances cannot overlap in -- head constructors.) -- - initClassDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)] + initClassDicts :: InstEnvs -> Class -> [(Name, Var)] initClassDicts insts cls = map find $ classInstances insts cls where find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) diff --git a/testsuite/tests/driver/Makefile b/testsuite/tests/driver/Makefile index edc78d8845..4670958c91 100644 --- a/testsuite/tests/driver/Makefile +++ b/testsuite/tests/driver/Makefile @@ -569,6 +569,11 @@ T703: "$(TEST_HC)" $(TEST_HC_OPTS) --make T703.hs -v0 ! readelf -W -l T703 2>/dev/null | grep 'GNU_STACK' | grep -q 'RWE' +.PHONY: T2182 +T2182: + ! "$(TEST_HC)" $(TEST_HC_OPTS) --make T2182_A.hs T2182.hs -v0 + ! "$(TEST_HC)" $(TEST_HC_OPTS) --make T2182.hs T2182_A.hs -v0 + .PHONY: write_interface_oneshot write_interface_oneshot: $(RM) -rf write_interface_oneshot/A011.hi diff --git a/testsuite/tests/driver/T2182.hs b/testsuite/tests/driver/T2182.hs new file mode 100644 index 0000000000..367f6bad84 --- /dev/null +++ b/testsuite/tests/driver/T2182.hs @@ -0,0 +1,6 @@ +module T2182 where +instance Read (IO a) where + readsPrec = undefined +x = read "" :: IO Bool +y = show (\x -> x) +z = (\x -> x) == (\y -> y) diff --git a/testsuite/tests/driver/T2182.stderr b/testsuite/tests/driver/T2182.stderr new file mode 100644 index 0000000000..b8d9e8b437 --- /dev/null +++ b/testsuite/tests/driver/T2182.stderr @@ -0,0 +1,28 @@ + +T2182.hs:5:5: + No instance for (Show (t1 -> t1)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘show’ + In the expression: show (\ x -> x) + In an equation for ‘y’: y = show (\ x -> x) + +T2182.hs:6:15: + No instance for (Eq (t0 -> t0)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘==’ + In the expression: (\ x -> x) == (\ y -> y) + In an equation for ‘z’: z = (\ x -> x) == (\ y -> y) + +T2182.hs:5:5: + No instance for (Show (t1 -> t1)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘show’ + In the expression: show (\ x -> x) + In an equation for ‘y’: y = show (\ x -> x) + +T2182.hs:6:15: + No instance for (Eq (t0 -> t0)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘==’ + In the expression: (\ x -> x) == (\ y -> y) + In an equation for ‘z’: z = (\ x -> x) == (\ y -> y) diff --git a/testsuite/tests/driver/T2182_A.hs b/testsuite/tests/driver/T2182_A.hs new file mode 100644 index 0000000000..52ecca712e --- /dev/null +++ b/testsuite/tests/driver/T2182_A.hs @@ -0,0 +1,4 @@ +module T2182_A where +import Text.Show.Functions +instance Eq (a -> b) where + _ == _ = True diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index f2c58d1150..ed4d924843 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -398,6 +398,7 @@ test('T8959a', ['$MAKE -s --no-print-directory T8959a']) test('T703', normal, run_command, ['$MAKE -s --no-print-directory T703']) +test('T2182', normal, run_command, ['$MAKE -s --no-print-directory T2182']) test('T8101', normal, compile, ['-Wall -fno-code']) def build_T9050(name, way): diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index 035a38f4c4..5084150660 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -5,10 +5,13 @@ Use :print or :force to determine these types Relevant bindings include it :: t1 (bound at <interactive>:6:1) Note: there are several potential instances: - instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ - instance Show Ordering -- Defined in ‘GHC.Show’ - instance Show Integer -- Defined in ‘GHC.Show’ - ...plus 22 others + instance (Show a, Show b) => Show (Either a b) + -- Defined in ‘Data.Either’ + instance forall (k :: BOX) (s :: k). Show (Data.Proxy.Proxy s) + -- Defined in ‘Data.Proxy’ + instance (GHC.Arr.Ix a, Show a, Show b) => Show (GHC.Arr.Array a b) + -- Defined in ‘GHC.Arr’ + ...plus 25 others In a stmt of an interactive GHCi command: print it <interactive>:8:1: @@ -17,8 +20,11 @@ Use :print or :force to determine these types Relevant bindings include it :: t1 (bound at <interactive>:8:1) Note: there are several potential instances: - instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ - instance Show Ordering -- Defined in ‘GHC.Show’ - instance Show Integer -- Defined in ‘GHC.Show’ - ...plus 22 others + instance (Show a, Show b) => Show (Either a b) + -- Defined in ‘Data.Either’ + instance forall (k :: BOX) (s :: k). Show (Data.Proxy.Proxy s) + -- Defined in ‘Data.Proxy’ + instance (GHC.Arr.Ix a, Show a, Show b) => Show (GHC.Arr.Array a b) + -- Defined in ‘GHC.Arr’ + ...plus 25 others In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr index 0c92dba4e4..139ce8d111 100644 --- a/testsuite/tests/ghci.debugger/scripts/print019.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr @@ -5,8 +5,12 @@ Use :print or :force to determine these types Relevant bindings include it :: a1 (bound at <interactive>:11:1) Note: there are several potential instances: - instance Show TyCon -- Defined in ‘Data.Typeable.Internal’ - instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’ - instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ - ...plus 30 others + instance forall (k :: BOX) (s :: k). Show (Proxy s) + -- Defined in ‘Data.Proxy’ + instance forall (k :: BOX) (a :: k) (b :: k). + Show (Data.Type.Coercion.Coercion a b) + -- Defined in ‘Data.Type.Coercion’ + instance forall (k :: BOX) (a :: k) (b :: k). Show (a :~: b) + -- Defined in ‘Data.Type.Equality’ + ...plus 47 others In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/scripts/T2182ghci.script b/testsuite/tests/ghci/scripts/T2182ghci.script new file mode 100644 index 0000000000..9c9f78781b --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci.script @@ -0,0 +1,49 @@ +"NO" +(\x -> x) + +:m +Text.Show.Functions +"YES" +(\x -> x) + +:m -Text.Show.Functions +"NO" +(\x -> x) + +:load T2182ghci_A +"YES" +(\x -> x) +T + +:m -T2182ghci_A +"NO" +(\x -> x) + +:load T2182ghci_B +"YES" +(\x -> x) +T + +:m -T2182ghci_B +"NO" +(\x -> x) + +:load T2182ghci_C +"YES" +(\x -> x) +T + +:m -T2182ghci_C +:load T2182ghci_A +:load T2182ghci_B +"YES" +(\x -> x) +T + +:m -T2182ghci_A +"YES" +(\x -> x) +T + +:m -T2182ghci_B +"NO" +(\x -> x) diff --git a/testsuite/tests/ghci/scripts/T2182ghci.stderr b/testsuite/tests/ghci/scripts/T2182ghci.stderr new file mode 100644 index 0000000000..82fbb3188c --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci.stderr @@ -0,0 +1,30 @@ + +<interactive>:3:1: + No instance for (Show (t0 -> t0)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘print’ + In a stmt of an interactive GHCi command: print it + +<interactive>:11:1: + No instance for (Show (t0 -> t0)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘print’ + In a stmt of an interactive GHCi command: print it + +<interactive>:20:1: + No instance for (Show (t0 -> t0)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘print’ + In a stmt of an interactive GHCi command: print it + +<interactive>:29:1: + No instance for (Show (t0 -> t0)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘print’ + In a stmt of an interactive GHCi command: print it + +<interactive>:50:1: + No instance for (Show (t0 -> t0)) + (maybe you haven't applied enough arguments to a function?) + arising from a use of ‘print’ + In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/scripts/T2182ghci.stdout b/testsuite/tests/ghci/scripts/T2182ghci.stdout new file mode 100644 index 0000000000..6d0ce38983 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci.stdout @@ -0,0 +1,22 @@ +"NO" +"YES" +<function> +"NO" +"YES" +MyFunction +T +"NO" +"YES" +MyFunction +T +"NO" +"YES" +MyFunction +T +"YES" +MyFunction +T +"YES" +MyFunction +T +"NO" diff --git a/testsuite/tests/ghci/scripts/T2182ghci2.script b/testsuite/tests/ghci/scripts/T2182ghci2.script new file mode 100644 index 0000000000..7bb4791140 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci2.script @@ -0,0 +1,15 @@ +-- Warning: this test will stop working when we eliminate orphans from +-- GHC.Float. The idea of this test is to import an external package +-- module which transitively depends on the module defining the orphan +-- instance. +:m +GHC.Types +"NO" +0.2 :: Float + +:m +Prelude +"YES" +0.2 :: Float + +:m -Prelude +"NO" +0.2 :: Float diff --git a/testsuite/tests/ghci/scripts/T2182ghci2.stderr b/testsuite/tests/ghci/scripts/T2182ghci2.stderr new file mode 100644 index 0000000000..0a7f61959d --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci2.stderr @@ -0,0 +1,10 @@ + +<interactive>:8:1: + No instance for (GHC.Show.Show Float) + arising from a use of ‘System.IO.print’ + In a stmt of an interactive GHCi command: System.IO.print it + +<interactive>:16:1: + No instance for (GHC.Show.Show Float) + arising from a use of ‘System.IO.print’ + In a stmt of an interactive GHCi command: System.IO.print it diff --git a/testsuite/tests/ghci/scripts/T2182ghci2.stdout b/testsuite/tests/ghci/scripts/T2182ghci2.stdout new file mode 100644 index 0000000000..0c7b219fbb --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci2.stdout @@ -0,0 +1,4 @@ +"NO" +"YES" +0.2 +"NO" diff --git a/testsuite/tests/ghci/scripts/T2182ghci_A.hs b/testsuite/tests/ghci/scripts/T2182ghci_A.hs new file mode 100644 index 0000000000..a271f8b654 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci_A.hs @@ -0,0 +1,4 @@ +module T2182ghci_A where +data T = T deriving (Show) +instance Show (a -> b) where + show _ = "MyFunction" diff --git a/testsuite/tests/ghci/scripts/T2182ghci_B.hs b/testsuite/tests/ghci/scripts/T2182ghci_B.hs new file mode 100644 index 0000000000..623d2468de --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci_B.hs @@ -0,0 +1,2 @@ +module T2182ghci_B(T(..)) where +import T2182ghci_A diff --git a/testsuite/tests/ghci/scripts/T2182ghci_C.hs b/testsuite/tests/ghci/scripts/T2182ghci_C.hs new file mode 100644 index 0000000000..d54894b700 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T2182ghci_C.hs @@ -0,0 +1,2 @@ +module T2182ghci_C(T(..)) where +import T2182ghci_B diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index 12bfebf814..a802027569 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -99,6 +99,8 @@ test('T1914', ghci_script, ['T1914.script']) +test('T2182ghci', normal, ghci_script, ['T2182ghci.script']) +test('T2182ghci2', [extra_hc_opts("-XNoImplicitPrelude")], ghci_script, ['T2182ghci2.script']) test('T2976', normal, ghci_script, ['T2976.script']) test('T2816', normal, ghci_script, ['T2816.script']) test('T789', normal, ghci_script, ['T789.script']) diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr index 701bd761d3..af420d2382 100644 --- a/testsuite/tests/typecheck/should_fail/T5095.stderr +++ b/testsuite/tests/typecheck/should_fail/T5095.stderr @@ -60,6 +60,13 @@ T5095.hs:9:11: -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’ instance Eq Integer -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’ + instance forall (k :: BOX) (s :: k). Eq (Data.Proxy.Proxy s) + -- Defined in ‘Data.Proxy’ + instance (Eq a, Eq b) => Eq (Either a b) + -- Defined in ‘Data.Either’ + instance (GHC.Arr.Ix i, Eq e) => Eq (GHC.Arr.Array i e) + -- Defined in ‘GHC.Arr’ + instance Eq (GHC.Arr.STArray s i e) -- Defined in ‘GHC.Arr’ (The choice depends on the instantiation of ‘a’ To pick the first instance above, use IncoherentInstances when compiling the other instance declarations) |