diff options
| -rw-r--r-- | compiler/GHC/Core/FamInstEnv.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Core/InstEnv.hs | 47 | ||||
| -rw-r--r-- | compiler/GHC/Core/Unify.hs | 67 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Make.hs | 32 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Rename.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/IfaceToCore.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Instance/FunDeps.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Module.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/indexed-types/should_compile/T19336.hs | 43 | ||||
| -rw-r--r-- | testsuite/tests/indexed-types/should_compile/T19336.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/indexed-types/should_compile/all.T | 1 |
11 files changed, 158 insertions, 71 deletions
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 3e0fc7361d..187ccf4994 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -104,8 +104,9 @@ data FamInst -- See Note [FamInsts and CoAxioms] , fi_fam :: Name -- Family name -- Used for "rough matching"; same idea as for class instances - -- See Note [Rough-match field] in GHC.Core.InstEnv - , fi_tcs :: [Maybe Name] -- Top of type args + -- See Note [Rough matching in class and family instances] + -- in GHC.Core.Unify + , fi_tcs :: [RoughMatchTc] -- Top of type args -- INVARIANT: fi_tcs = roughMatchTcs fi_tys -- Used for "proper matching"; ditto @@ -264,7 +265,7 @@ also. -- interface file. In particular, we get the rough match info from the iface -- (instead of computing it here). mkImportedFamInst :: Name -- Name of the family - -> [Maybe Name] -- Rough match info + -> [RoughMatchTc] -- Rough match info -> CoAxiom Unbranched -- Axiom introduced -> FamInst -- Resulting family instance mkImportedFamInst fam mb_tcs axiom diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index 0a5b306705..840465425f 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -49,7 +49,7 @@ import GHC.Types.Basic import GHC.Types.Unique.DFM import GHC.Types.Id import Data.Data ( Data ) -import Data.Maybe ( isJust, isNothing ) +import Data.Maybe ( isJust ) import GHC.Utils.Misc import GHC.Utils.Outputable @@ -70,8 +70,8 @@ data ClsInst = ClsInst { -- Used for "rough matching"; see -- Note [ClsInst laziness and the rough-match fields] -- INVARIANT: is_tcs = roughMatchTcs is_tys - is_cls_nm :: Name -- ^ Class name - , is_tcs :: [Maybe Name] -- ^ Top of type args + is_cls_nm :: Name -- ^ Class name + , is_tcs :: [RoughMatchTc] -- ^ Top of type args -- | @is_dfun_name = idName . is_dfun@. -- @@ -107,10 +107,10 @@ fuzzyClsInstCmp x y = stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` mconcat (map cmp (zip (is_tcs x) (is_tcs y))) where - cmp (Nothing, Nothing) = EQ - cmp (Nothing, Just _) = LT - cmp (Just _, Nothing) = GT - cmp (Just x, Just y) = stableNameCmp x y + cmp (OtherTc, OtherTc) = EQ + cmp (OtherTc, KnownTc _) = LT + cmp (KnownTc _, OtherTc) = GT + cmp (KnownTc x, KnownTc y) = stableNameCmp x y isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) @@ -135,25 +135,16 @@ We avoid this as follows: pull in interfaces that it refers to. See Note [Proper-match fields]. * Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and - is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking + is_tcs :: [RoughMatchTc] fields to perform a "rough match", *without* poking inside the DFunId. The rough-match fields allow us to say "definitely does not - match", based only on Names. + match", based only on Names. See GHC.Core.Unify + Note [Rough matching in class and family instances] This laziness is very important; see #12367. Try hard to avoid pulling on the structured fields unless you really need the instance. * Another place to watch is InstEnv.instIsVisible, which needs the module to which the ClsInst belongs. We can get this from is_dfun_name. - -* In is_tcs, - Nothing means that this type arg is a type variable - - (Just n) means that this type arg is a - TyConApp with a type constructor of n. - This is always a real tycon, never a synonym! - (Two different synonyms might match, but two - different real tycons can't.) - NB: newtypes are not transparent, though! -} {- @@ -206,10 +197,9 @@ updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst updateClsInstDFun tidy_dfun ispec = ispec { is_dfun = tidy_dfun (is_dfun ispec) } -instanceRoughTcs :: ClsInst -> [Maybe Name] +instanceRoughTcs :: ClsInst -> [RoughMatchTc] instanceRoughTcs = is_tcs - instance NamedThing ClsInst where getName ispec = getName (is_dfun ispec) @@ -300,12 +290,12 @@ mkLocalInstance dfun oflag tvs cls tys choose_one nss = chooseOrphanAnchor (unionNameSets nss) -mkImportedInstance :: Name -- ^ the name of the class - -> [Maybe Name] -- ^ the types which the class was applied to - -> Name -- ^ the 'Name' of the dictionary binding - -> DFunId -- ^ the 'Id' of the dictionary. - -> OverlapFlag -- ^ may this instance overlap? - -> IsOrphan -- ^ is this instance an orphan? +mkImportedInstance :: Name -- ^ the name of the class + -> [RoughMatchTc] -- ^ the types which the class was applied to + -> Name -- ^ the 'Name' of the dictionary binding + -> DFunId -- ^ the 'Id' of the dictionary. + -> OverlapFlag -- ^ may this instance overlap? + -> IsOrphan -- ^ is this instance an orphan? -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file @@ -842,7 +832,6 @@ lookupInstEnv' ie vis_mods cls tys = lookup ie where rough_tcs = roughMatchTcs tys - all_tvs = all isNothing rough_tcs -------------- lookup env = case lookupUDFM env cls of @@ -871,7 +860,7 @@ lookupInstEnv' ie vis_mods cls tys | otherwise = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set, - (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr cls <+> ppr tys) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index dbfd4083ad..3b67a0a6f8 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-} module GHC.Core.Unify ( tcMatchTy, tcMatchTyKi, @@ -11,8 +11,8 @@ module GHC.Core.Unify ( tcMatchTyX_BM, ruleMatchTyKiX, -- * Rough matching - roughMatchTcs, instanceCantMatch, - typesCantMatch, + RoughMatchTc(..), roughMatchTcs, instanceCantMatch, + typesCantMatch, isRoughOtherTc, -- Side-effect free unification tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, @@ -53,6 +53,7 @@ import GHC.Exts( oneShot ) import GHC.Utils.Panic import GHC.Data.FastString +import Data.Data ( Data ) import Data.List ( mapAccumL ) import Control.Monad import qualified Data.Semigroup as S @@ -258,26 +259,70 @@ alwaysBindFun _tv _ty = BindMe * * ********************************************************************* -} --- See Note [Rough match] field in GHC.Core.InstEnv +{- Note [Rough matching in class and family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + instance C (Maybe [Tree a]) Bool +and suppose we are looking up + C Bool Bool + +We can very quickly rule the instance out, because the first +argument is headed by Maybe, whereas in the constraint we are looking +up has first argument headed by Bool. These "headed by" TyCons are +called the "rough match TyCons" of the constraint or instance. +They are used for a quick filter, to check when an instance cannot +possibly match. + +The main motivation is to avoid sucking in whole instance +declarations that are utterly useless. See GHC.Core.InstEnv +Note [ClsInst laziness and the rough-match fields]. + +INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon, +like Maybe or Either, including a newtype or a data family, both of +which are generative. It replies True to `isGenerativeTyCon tc Nominal`. + +But it is never + - A type synonym + E.g. Int and (S Bool) might match + if (S Bool) is a synonym for Int + + - A type family (#19336) + E.g. (Just a) and (F a) might match if (F a) reduces to (Just a) + albeit perhaps only after 'a' is instantiated. +-} + +data RoughMatchTc + = KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds + -- true to `isGenerativeTyCon tc Nominal`. See + -- Note [Rough matching in class and family instances] + | OtherTc -- e.g. type variable at the head + deriving( Data ) + +isRoughOtherTc :: RoughMatchTc -> Bool +isRoughOtherTc OtherTc = True +isRoughOtherTc (KnownTc {}) = False -roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs :: [Type] -> [RoughMatchTc] roughMatchTcs tys = map rough tys where rough ty | Just (ty', _) <- splitCastTy_maybe ty = rough ty' - | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) - | otherwise = Nothing + | Just (tc,_) <- splitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc ) + KnownTc (tyConName tc) + -- See Note [Rough matching in class and family instances] + | otherwise = OtherTc -instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot -- possibly be instantiated to actual, nor vice versa; -- False is non-committal instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as instanceCantMatch _ _ = False -- Safe -itemCantMatch :: Maybe Name -> Maybe Name -> Bool -itemCantMatch (Just t) (Just a) = t /= a -itemCantMatch _ _ = False +itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool +itemCantMatch (KnownTc t) (KnownTc a) = t /= a +itemCantMatch _ _ = False {- diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 836c9dc23d..1c43e3e6e6 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -48,6 +48,7 @@ import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Driver.Env import GHC.Driver.Backend @@ -685,34 +686,25 @@ tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) instanceToIfaceInst :: ClsInst -> IfaceClsInst instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag , is_cls_nm = cls_name, is_cls = cls - , is_tcs = mb_tcs + , is_tcs = rough_tcs , is_orphan = orph }) = ASSERT( cls_name == className cls ) - IfaceClsInst { ifDFun = dfun_name, - ifOFlag = oflag, - 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 - + IfaceClsInst { ifDFun = idName dfun_id + , ifOFlag = oflag + , ifInstCls = cls_name + , ifInstTys = ifaceRoughMatchTcs rough_tcs + , ifInstOrph = orph } -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst famInstToIfaceFamInst (FamInst { fi_axiom = axiom, fi_fam = fam, - fi_tcs = roughs }) + fi_tcs = rough_tcs }) = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom , ifFamInstFam = fam - , ifFamInstTys = map do_rough roughs + , ifFamInstTys = ifaceRoughMatchTcs rough_tcs , ifFamInstOrph = orph } where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) - fam_decl = tyConName $ coAxiomTyCon axiom mod = ASSERT( isExternalName (coAxiomName axiom) ) nameModule (coAxiomName axiom) @@ -725,6 +717,12 @@ famInstToIfaceFamInst (FamInst { fi_axiom = axiom, | otherwise = chooseOrphanAnchor lhs_names +ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] +ifaceRoughMatchTcs tcs = map do_rough tcs + where + do_rough OtherTc = Nothing + do_rough (KnownTc n) = Just (toIfaceTyCon_name n) + -------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index f523d24625..cd97c000a8 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -414,7 +414,7 @@ rnIfaceNeverExported name = do rnIfaceClsInst :: Rename IfaceClsInst rnIfaceClsInst cls_inst = do n <- rnIfaceGlobal (ifInstCls cls_inst) - tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst) + tys <- mapM rnRoughMatchTyCon (ifInstTys cls_inst) dfun <- rnIfaceNeverExported (ifDFun cls_inst) return cls_inst { ifInstCls = n @@ -422,14 +422,14 @@ rnIfaceClsInst cls_inst = do , ifDFun = dfun } -rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon) -rnMaybeIfaceTyCon Nothing = return Nothing -rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc +rnRoughMatchTyCon :: Rename (Maybe IfaceTyCon) +rnRoughMatchTyCon Nothing = return Nothing +rnRoughMatchTyCon (Just tc) = Just <$> rnIfaceTyCon tc rnIfaceFamInst :: Rename IfaceFamInst rnIfaceFamInst d = do fam <- rnIfaceGlobal (ifFamInstFam d) - tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d) + tys <- mapM rnRoughMatchTyCon (ifFamInstTys d) axiom <- rnIfaceGlobal (ifFamInstAxiom d) return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 0cc11a1bab..5a843c5e7e 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -53,6 +53,7 @@ import GHC.Core.TyCo.Subst ( substTyCoVars ) import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core +import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Core.Utils import GHC.Core.Unfold.Make import GHC.Core.Lint @@ -1145,13 +1146,17 @@ look at it. ************************************************************************ -} +tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc +tcRoughTyCon (Just tc) = KnownTc (ifaceTyConName tc) +tcRoughTyCon Nothing = OtherTc + tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag , ifInstCls = cls, ifInstTys = mb_tcs , ifInstOrph = orph }) = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ fmap tyThingId (tcIfaceImplicit dfun_name) - ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; let mb_tcs' = map tcRoughTyCon mb_tcs ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst @@ -1161,7 +1166,7 @@ tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs tcIfaceCoAxiom axiom_name -- will panic if branched, but that's OK ; let axiom'' = toUnbranchedAxiom axiom' - mb_tcs' = map (fmap ifaceTyConName) mb_tcs + mb_tcs' = map tcRoughTyCon mb_tcs ; return (mkImportedFamInst fam mb_tcs' axiom'') } {- diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index 3abb0140b1..623ed147ff 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -236,7 +236,7 @@ improveFromInstEnv _ _ _ = [] improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class -> ClsInst -- An instance template - -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -> [Type] -> [RoughMatchTc] -- Arguments of this (C tys) predicate -> [([TyCoVar], [TypeEqn])] -- Empty or singleton improveClsFD clas_tvs fd @@ -666,7 +666,7 @@ checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls -- instance C Int Char Char -- The second instance conflicts with the first by *both* fundeps -trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] +trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc] -- Computing rough_tcs for a particular fundep -- class C a b c | a -> b where ... -- For each instance .... => C ta tb tc @@ -679,4 +679,4 @@ trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs = zipWith select clas_tvs mb_tcs where select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = Nothing + | otherwise = OtherTc diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 084a98883d..42f0a3fddc 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -114,6 +114,7 @@ import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Class import GHC.Core.Coercion.Axiom +import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons , famInstEnvElts, extendFamInstEnvList, normaliseType ) @@ -1681,7 +1682,7 @@ tcMissingParentClassWarn warnFlag isName shouldName -- "<location>: Warning: <type> is an instance of <is> but not -- <should>" e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (Just name:_) = + warnMsg (KnownTc name:_) = addWarnAt (Reason warnFlag) instLoc $ hsep [ (quotes . ppr . nameOccName) name , text "is an instance of" diff --git a/testsuite/tests/indexed-types/should_compile/T19336.hs b/testsuite/tests/indexed-types/should_compile/T19336.hs new file mode 100644 index 0000000000..dfc7409fa3 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T19336.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + , DataKinds, NoMonomorphismRestriction, UndecidableInstances + , TypeFamilies #-} + +{-# OPTIONS_GHC -Wall #-} + +module T19336 where + +import GHC.TypeLits + +class X a b where + convert :: a -> b + +instance X Int String where + convert = show + +instance X String String where + convert = id + +instance {-# OVERLAPPABLE #-} TypeError ('Text "Oops") => X a b where + convert = error "unreachable" + +type family F a where + F String = String + F Int = String + +convert_f :: X a (F a) => a -> a -> F a +convert_f _ = convert + +---------- + +class Poly a where + poly :: a + +instance Poly String where + poly = "hi" + +instance Poly Int where + poly = 2 + +---------- + +oops = convert_f poly diff --git a/testsuite/tests/indexed-types/should_compile/T19336.stderr b/testsuite/tests/indexed-types/should_compile/T19336.stderr new file mode 100644 index 0000000000..f841f79628 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T19336.stderr @@ -0,0 +1,4 @@ + +T19336.hs:43:1: warning: [-Wmissing-signatures (in -Wall)] + Top-level binding with no type signature: + oops :: (X a (F a), Poly a) => a -> F a diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index 469dd915df..7d8aa9f3ae 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -302,3 +302,4 @@ test('GivenLoop', normal, compile, ['']) test('T18875', normal, compile, ['']) test('T8707', normal, compile, ['-O']) test('T14111', normal, compile, ['-O']) +test('T19336', normal, compile, ['-O']) |