X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FInstEnv.lhs;h=b7a356b610fab6ac7b23885cb433f0deecf6cf09;hb=370765b2f80105d7ca6e6080bab24c76970fdc4e;hp=a5f28a95c7638d4c0236f3e7b75bc04891a8ce2a;hpb=a0908440c99383763cb39bf611ef2c8e049bc48d;p=ghc-hetmet.git diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index a5f28a9..b7a356b 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -9,25 +9,25 @@ The bits common to TcInstDcls and TcDeriv. module InstEnv ( DFunId, InstEnv, - emptyInstEnv, extendInstEnv, pprInstEnv, - lookupInstEnv, - classInstEnv, simpleDFunClassTyCon, checkFunDeps + emptyInstEnv, extendInstEnv, + lookupInstEnv, instEnvElts, + classInstances, simpleDFunClassTyCon, checkFunDeps ) where #include "HsVersions.h" import Class ( Class, classTvsFds ) -import Var ( Id ) +import Var ( Id, isTcTyVar ) import VarSet import VarEnv -import TcType ( Type, tcTyConAppTyCon, - tcSplitDFunTy, tyVarsOfTypes, +import TcType ( Type, tcTyConAppTyCon, tcIsTyVarTy, + tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar, matchTys, unifyTyListsX ) import FunDeps ( checkClsFD ) import TyCon ( TyCon ) import Outputable -import UniqFM ( UniqFM, lookupWithDefaultUFM, emptyUFM, eltsUFM, addToUFM_C ) +import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM ) import Id ( idType ) import CmdLineOpts import Util ( notNull ) @@ -44,33 +44,51 @@ import Maybe ( isJust ) \begin{code} type DFunId = Id type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class -type ClsInstEnv = [InstEnvElt] -- The instances for a particular class + +data ClsInstEnv + = ClsIE [InstEnvElt] -- The instances for a particular class, in any order + Bool -- True <=> there is an instance of form C a b c + -- If *not* then the common case of looking up + -- (C a b c) can fail immediately + -- NB: use tcIsTyVarTy: don't look through newtypes!! + type InstEnvElt = (TyVarSet, [Type], DFunId) -- INVARIANTs: see notes below emptyInstEnv :: InstEnv emptyInstEnv = emptyUFM -classInstEnv :: InstEnv -> Class -> ClsInstEnv -classInstEnv env cls = lookupWithDefaultUFM env [] cls +instEnvElts :: InstEnv -> [InstEnvElt] +instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts] + +classInstances :: (InstEnv,InstEnv) -> Class -> [InstEnvElt] +classInstances (pkg_ie, home_ie) cls + = get home_ie ++ get pkg_ie + where + get env = case lookupUFM env cls of + Just (ClsIE insts _) -> insts + Nothing -> [] extendInstEnv :: InstEnv -> DFunId -> InstEnv extendInstEnv inst_env dfun_id - = addToUFM_C add inst_env clas [ins_item] + = addToUFM_C add inst_env clas (ClsIE [ins_item] ins_tyvar) where - add old _ = ins_item : old + add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts) + (ins_tyvar || cur_tyvar) (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) ins_tv_set = mkVarSet ins_tvs ins_item = (ins_tv_set, ins_tys, dfun_id) + ins_tyvar = all tcIsTyVarTy ins_tys +#ifdef UNUSED pprInstEnv :: InstEnv -> SDoc pprInstEnv env = vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+> brackets (pprWithCommas ppr tys) <+> ppr dfun - | cls_inst_env <- eltsUFM env + | ClsIE cls_inst_env _ <- eltsUFM env , (tyvars, tys, dfun) <- cls_inst_env ] - +#endif simpleDFunClassTyCon :: DFunId -> (Class, TyCon) simpleDFunClassTyCon dfun @@ -270,10 +288,11 @@ lookupInstEnv dflags (pkg_ie, home_ie) cls tys -- so don't attempt to pune the matches | otherwise = (pruned_matches, []) where + all_tvs = all tcIsTyVarTy tys incoherent_ok = dopt Opt_AllowIncoherentInstances dflags overlap_ok = dopt Opt_AllowOverlappingInstances dflags - (home_matches, home_unifs) = lookup_inst_env home_ie cls tys - (pkg_matches, pkg_unifs) = lookup_inst_env pkg_ie cls tys + (home_matches, home_unifs) = lookup_inst_env home_ie cls tys all_tvs + (pkg_matches, pkg_unifs) = lookup_inst_env pkg_ie cls tys all_tvs all_matches = home_matches ++ pkg_matches all_unifs | incoherent_ok = [] -- Don't worry about these if incoherent is ok! | otherwise = home_unifs ++ pkg_unifs @@ -283,12 +302,32 @@ lookupInstEnv dflags (pkg_ie, home_ie) cls tys lookup_inst_env :: InstEnv -- The envt -> Class -> [Type] -- What we are looking for + -> Bool -- All the [Type] are tyvars -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches [Id]) -- These don't match but do unify -lookup_inst_env env key_cls key_tys - = find (classInstEnv env key_cls) [] [] +lookup_inst_env env key_cls key_tys key_all_tvs + = case lookupUFM env key_cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts has_tv_insts) + | key_all_tvs && not has_tv_insts -> ([],[]) -- Short cut for common case + -- The thing we are looking up is of form (C a b c), and + -- the ClsIE has no instances of that form, so don't bother to search + | otherwise -> find insts [] [] where - key_vars = tyVarsOfTypes key_tys + key_vars = filterVarSet not_existential (tyVarsOfTypes key_tys) + not_existential tv = not (isTcTyVar tv && isExistentialTyVar tv) + -- The key_tys can contain skolem constants, and we can guarantee that those + -- are never going to be instantiated to anything, so we should not involve + -- them in the unification test. Example: + -- class Foo a where { op :: a -> Int } + -- instance Foo a => Foo [a] -- NB overlap + -- instance Foo [Int] -- NB overlap + -- data T = forall a. Foo a => MkT a + -- f :: T -> Int + -- f (MkT x) = op [x,x] + -- The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd + -- complain, saying that the choice of instance depended on the instantiation + -- of 'a'; but of course it isn't *going* to be instantiated. find [] ms us = (ms, us) find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us @@ -298,7 +337,10 @@ lookup_inst_env env key_cls key_tys Nothing -- Does not match, so next check whether the things unify -- [see notes about overlapping instances above] - -> case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of + -> ASSERT( not (key_vars `intersectsVarSet` tpl_tyvars) ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of Just _ -> find rest ms (dfun_id:us) Nothing -> find rest ms us @@ -313,7 +355,7 @@ insert_overlapping new_item (item:items) -- Keep new one | old_beats_new = item : items -- Keep old one - | otherwise = item : insert_overlapping new_item items + | otherwise = item : insert_overlapping new_item items -- Keep both where new_beats_old = new_item `beats` item @@ -362,16 +404,16 @@ checkFunDeps :: (InstEnv, InstEnv) -> DFunId -> Maybe [DFunId] -- Nothing <=> ok -- Just dfs <=> conflict with dfs -- Check wheher adding DFunId would break functional-dependency constraints -checkFunDeps (pkg_ie, home_ie) dfun +checkFunDeps inst_envs dfun | null bad_fundeps = Nothing | otherwise = Just bad_fundeps where (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun) ins_tv_set = mkVarSet ins_tvs - cls_inst_env = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas + cls_inst_env = classInstances inst_envs clas bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys -badFunDeps :: ClsInstEnv -> Class +badFunDeps :: [InstEnvElt] -> Class -> TyVarSet -> [Type] -- Proposed new instance type -> [DFunId] badFunDeps cls_inst_env clas ins_tv_set ins_tys