diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/coreSyn/CoreUtils.lhs | 9 | ||||
| -rw-r--r-- | compiler/coreSyn/TrieMap.lhs | 60 | ||||
| -rw-r--r-- | compiler/typecheck/TcInteract.lhs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.lhs | 8 | ||||
| -rw-r--r-- | compiler/types/FunDeps.lhs | 87 |
5 files changed, 105 insertions, 65 deletions
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 34046e8159..c7dc1a6524 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -1350,10 +1350,11 @@ eqExprX id_unfolding_fun env e1 e2 (bs2,rs2) = unzip ps2 env' = rnBndrs2 env bs1 bs2 - go env (Case e1 b1 _ a1) (Case e2 b2 _ a2) - = go env e1 e2 - && eqTypeX env (idType b1) (idType b2) - && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 + go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] in TrieMap + = null a2 && go env e1 e2 && eqTypeX env t1 t2 + | otherwise + = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 go _ _ _ = False diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index e551d6423c..18e4dd82a6 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -239,22 +239,37 @@ Note [Binders] - the binders in an alternative because they are totally fixed by the context +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* For a key (Case e b ty (alt:alts)) we don't need to look the return type + 'ty', because every alternative has that type. + +* For a key (Case e b ty []) we MUST look at the return type 'ty', because + otherwise (Case (error () "urk") _ Int []) would compare equal to + (Case (error () "urk") _ Bool []) + which is utterly wrong (Trac #6097) + +We could compare the return type regardless, but the wildly common case +is that it's unnecesary, so we have two fields (cm_case and cm_ecase) +for the two possibilities. Only cm_ecase looks at the type. + +See also Note [Empty case alternatives] in CoreSyn. \begin{code} data CoreMap a = EmptyCM - | CM { cm_var :: VarMap a - , cm_lit :: LiteralMap a - , cm_co :: CoercionMap a - , cm_type :: TypeMap a - , cm_cast :: CoreMap (CoercionMap a) - , cm_source :: CoreMap (TickishMap a) - , cm_app :: CoreMap (CoreMap a) - , cm_lam :: CoreMap (TypeMap a) - , cm_letn :: CoreMap (CoreMap (BndrMap a)) - , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a)) - , cm_case :: CoreMap (ListMap AltMap a) - -- Note [Binders] + | CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMap a + , cm_type :: TypeMap a + , cm_cast :: CoreMap (CoercionMap a) + , cm_tick :: CoreMap (TickishMap a) + , cm_app :: CoreMap (CoreMap a) + , cm_lam :: CoreMap (TypeMap a) -- Note [Binders] + , cm_letn :: CoreMap (CoreMap (BndrMap a)) + , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a)) + , cm_case :: CoreMap (ListMap AltMap a) + , cm_ecase :: CoreMap (TypeMap a) -- Note [Empty case alternatives] } @@ -264,7 +279,7 @@ wrapEmptyCM = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap , cm_cast = emptyTM, cm_app = emptyTM , cm_lam = emptyTM, cm_letn = emptyTM , cm_letr = emptyTM, cm_case = emptyTM - , cm_source = emptyTM } + , cm_ecase = emptyTM, cm_tick = emptyTM } instance TrieMap CoreMap where type Key CoreMap = CoreExpr @@ -298,12 +313,13 @@ fdE k m . foldTM k (cm_co m) . foldTM k (cm_type m) . foldTM (foldTM k) (cm_cast m) - . foldTM (foldTM k) (cm_source m) + . foldTM (foldTM k) (cm_tick m) . foldTM (foldTM k) (cm_app m) . foldTM (foldTM k) (cm_lam m) . foldTM (foldTM (foldTM k)) (cm_letn m) . foldTM (foldTM (foldTM k)) (cm_letr m) . foldTM (foldTM k) (cm_case m) + . foldTM (foldTM k) (cm_ecase m) lkE :: CmEnv -> CoreExpr -> CoreMap a -> Maybe a -- lkE: lookup in trie for expressions @@ -316,9 +332,9 @@ lkE env expr cm go (Type t) = cm_type >.> lkT env t go (Coercion c) = cm_co >.> lkC env c go (Cast e c) = cm_cast >.> lkE env e >=> lkC env c - go (Tick tickish e) = cm_source >.> lkE env e >=> lkTickish tickish - go (App e1 e2) = cm_app >.> lkE env e2 >=> lkE env e1 - go (Lam v e) = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v + go (Tick tickish e) = cm_tick >.> lkE env e >=> lkTickish tickish + go (App e1 e2) = cm_app >.> lkE env e2 >=> lkE env e1 + go (Lam v e) = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v go (Let (NonRec b r) e) = cm_letn >.> lkE env r >=> lkE (extendCME env b) e >=> lkBndr env b go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs @@ -326,7 +342,9 @@ lkE env expr cm in cm_letr >.> lkList (lkE env1) rhss >=> lkE env1 e >=> lkList (lkBndr env1) bndrs - go (Case e b _ as) = cm_case >.> lkE env e + go (Case e b ty as) -- See Note [Empty case alternatives] + | null as = cm_ecase >.> lkE env e >=> lkT env ty + | otherwise = cm_case >.> lkE env e >=> lkList (lkA (extendCME env b)) as xtE :: CmEnv -> CoreExpr -> XT a -> CoreMap a -> CoreMap a @@ -337,7 +355,7 @@ xtE env (Coercion c) f m = m { cm_co = cm_co m |> xtC env c f } xtE _ (Lit l) f m = m { cm_lit = cm_lit m |> xtLit l f } xtE env (Cast e c) f m = m { cm_cast = cm_cast m |> xtE env e |>> xtC env c f } -xtE env (Tick t e) f m = m { cm_source = cm_source m |> xtE env e |>> xtTickish t f } +xtE env (Tick t e) f m = m { cm_tick = cm_tick m |> xtE env e |>> xtTickish t f } xtE env (App e1 e2) f m = m { cm_app = cm_app m |> xtE env e2 |>> xtE env e1 f } xtE env (Lam v e) f m = m { cm_lam = cm_lam m |> xtE (extendCME env v) e |>> xtBndr env v f } @@ -350,7 +368,9 @@ xtE env (Let (Rec prs) e) f m = m { cm_letr = let (bndrs,rhss) = unzip prs |> xtList (xtE env1) rhss |>> xtE env1 e |>> xtList (xtBndr env1) bndrs f } -xtE env (Case e b _ as) f m = m { cm_case = cm_case m |> xtE env e +xtE env (Case e b ty as) f m + | null as = m { cm_ecase = cm_ecase m |> xtE env e |>> xtT env ty f } + | otherwise = m { cm_case = cm_case m |> xtE env e |>> let env1 = extendCME env b in xtList (xtA env1) as f } diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 44d6a8d01f..e3b6a33298 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1320,11 +1320,9 @@ rewriteWithFunDeps eqn_pred_locs xis wloc instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,CtEvidence)] -- Post: Returns the position index as well as the corresponding FunDep equality -instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs +instFunDepEqn wl (FDEqn { fd_qtvs = tvs, fd_eqs = eqs , fd_pred1 = d1, fd_pred2 = d2 }) - = do { let tvs = varSetElems qtvs - ; tys' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution - ; let subst = zipTopTvSubst tvs tys' + = do { (subst, _) <- instFlexiTcS tvs -- Takes account of kind substitution ; foldM (do_one subst) [] eqs } where do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 287783cb88..5a40df94ae 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1337,11 +1337,15 @@ instDFunType dfun_id mb_inst_tys ; return (ty : tys, phi) } go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr mb_inst_tys) -instFlexiTcS :: TyVar -> TcS TcType +instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType]) -- Like TcM.instMetaTyVar but the variable that is created is -- always touchable; we are supposed to guess its instantiation. -- See Note [Touchable meta type variables] -instFlexiTcS tv = wrapTcS (instFlexiTcSHelper (tyVarName tv) (tyVarKind tv) ) +instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs) + where + inst_one subst tv = do { ty' <- instFlexiTcSHelper (tyVarName tv) + (substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv ty', ty') } newFlexiTcSTy :: Kind -> TcS TcType newFlexiTcSTy knd diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs index 31ef9cc7ab..ab1007f29d 100644 --- a/compiler/types/FunDeps.lhs +++ b/compiler/types/FunDeps.lhs @@ -28,7 +28,9 @@ module FunDeps ( import Name import Var import Class +import Id( idType ) import Type +import TcType( tcSplitDFunTy ) import Unify import InstEnv import VarSet @@ -208,7 +210,7 @@ Finally, the position parameters will help us rewrite the wanted constraint ``on type Pred_Loc = (PredType, SDoc) -- SDoc says where the Pred comes from data Equation - = FDEqn { fd_qtvs :: TyVarSet -- Instantiate these to fresh unification vars + = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars to fresh unification vars , fd_eqs :: [FDEq] -- and then make these equal , fd_pred1, fd_pred2 :: Pred_Loc } -- The Equation arose from -- combining these two constraints @@ -286,7 +288,7 @@ improveFromAnother pred1@(ty1, _) pred2@(ty2, _) | Just (cls1, tys1) <- getClassPredTys_maybe ty1 , Just (cls2, tys2) <- getClassPredTys_maybe ty2 , tys1 `lengthAtLeast` 2 && cls1 == cls2 - = [ FDEqn { fd_qtvs = emptyVarSet, fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2 } + = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2 } | let (cls_tvs, cls_fds) = classTvsFds cls1 , fd <- cls_fds , let (ltys1, rs1) = instFD fd cls_tvs tys1 @@ -303,7 +305,7 @@ improveFromAnother _ _ = [] pprEquation :: Equation -> SDoc pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)), + = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs), nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | (FDEq _ t1 t2) <- pairs])] improveFromInstEnv :: (InstEnv,InstEnv) @@ -320,7 +322,7 @@ improveFromInstEnv inst_env pred@(ty, _) , let (cls_tvs, cls_fds) = classTvsFds cls instances = classInstances inst_env cls rough_tcs = roughMatchTcs tys - = [ FDEqn { fd_qtvs = qtvs, fd_eqs = eqs, fd_pred1 = p_inst, fd_pred2=pred } + = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs, fd_pred1 = p_inst, fd_pred2=pred } | fd <- cls_fds -- Iterate through the fundeps first, -- because there often are none! , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs @@ -328,25 +330,27 @@ improveFromInstEnv inst_env pred@(ty, _) -- 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@(ClsInst { is_tvs = qtvs, is_tys = tys_inst, - is_tcs = inst_tcs }) <- instances - , not (instanceCantMatch inst_tcs trimmed_tcs) - , let p_inst = (mkClassPred cls tys_inst, + , ispec <- instances + , (meta_tvs, eqs) <- checkClsFD fd cls_tvs ispec + emptyVarSet tys trimmed_tcs -- NB: orientation + , let p_inst = (mkClassPred cls (is_tys ispec), sep [ ptext (sLit "arising from the dependency") <+> quotes (pprFunDep fd) , ptext (sLit "in the instance declaration") <+> pprNameDefnLoc (getName ispec)]) - , (qtvs, eqs) <- checkClsFD qtvs fd cls_tvs tys_inst tys -- NB: orientation - , not (null eqs) ] improveFromInstEnv _ _ = [] -checkClsFD :: TyVarSet -- Quantified type variables; see note below - -> FunDep TyVar -> [TyVar] -- One functional dependency from the class - -> [Type] -> [Type] - -> [(TyVarSet, [FDEq])] +checkClsFD :: FunDep TyVar -> [TyVar] -- One functional dependency from the class + -> ClsInst -- An instance template + -> TyVarSet -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -- TyVarSet are extra tyvars that can be instantiated + -> [([TyVar], [FDEq])] + +checkClsFD fd clas_tvs + (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst, is_dfun = dfun }) + extra_qtvs tys_actual rough_tcs_actual -checkClsFD qtvs fd clas_tvs tys1 tys2 -- 'qtvs' are the quantified type variables, the ones which an be instantiated -- to make the types match. For example, given -- class C a b | a->b where ... @@ -355,8 +359,8 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- and an Inst of form (C (Maybe t1) t2), -- then we will call checkClsFD with -- --- qtvs = {x}, tys1 = [Maybe x, Tree x] --- tys2 = [Maybe t1, t2] +-- is_qtvs = {x}, is_tys = [Maybe x, Tree x] +-- tys_actual = [Maybe t1, t2] -- -- We can instantiate x to t1, and then we want to force -- (Tree x) [t1/x] ~ t2 @@ -368,10 +372,14 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- This function is also used by InstEnv.badFunDeps, which needs to *unify* -- For the one-sided matching case, the qtvs are just from the template, -- so we get matching --- - = ASSERT2( length tys1 == length tys2 && - length tys1 == length clas_tvs - , ppr tys1 <+> ppr tys2 ) + + | instanceCantMatch rough_tcs_inst rough_tcs_actual + = [] -- Filter out ones that can't possibly match, + + | otherwise + = ASSERT2( length tys_inst == length tys_actual && + length tys_inst == length clas_tvs + , ppr tys_inst <+> ppr tys_actual ) case tcUnifyTys bind_fn ltys1 ltys2 of Nothing -> [] @@ -391,8 +399,11 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- so we would produce no FDs, which is clearly wrong. -> [] + | null fdeqs + -> [] + | otherwise - -> [(qtvs', fdeqs)] + -> [(meta_tvs, fdeqs)] -- We could avoid this substTy stuff by producing the eqn -- (qtvs, ls1++rs1, ls2++rs2) -- which will re-do the ls1/ls2 unification when the equation is @@ -409,8 +420,10 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- eqType again, since we know for sure that /at least one/ -- equation in there is useful) - qtvs' = filterVarSet (`notElemTvSubst` subst) qtvs - -- qtvs' are the quantified type variables + (dfun_tvs, _, _, _) = tcSplitDFunTy (idType dfun) + meta_tvs = [ setVarType tv (substTy subst (varType tv)) + | tv <- dfun_tvs, tv `notElemTvSubst` subst ] + -- meta_tvs are the quantified type variables -- that have not been substituted out -- -- Eg. class C a b | a -> b @@ -418,12 +431,21 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- Given constraint C Int z -- we generate the equation -- ({y}, [y], z) + -- + -- But note (a) we get them from the dfun_id, so they are *in order* + -- because the kind variables may be mentioned in the + -- type variabes' kinds + -- (b) we must apply 'subst' to the kinds, in case we have + -- matched out a kind variable, but not a type variable + -- whose kind mentions that kind variable! + -- Trac #6015, #6068 where - bind_fn tv | tv `elemVarSet` qtvs = BindMe - | otherwise = Skolem + bind_fn tv | tv `elemVarSet` qtvs = BindMe + | tv `elemVarSet` extra_qtvs = BindMe + | otherwise = Skolem - (ltys1, rtys1) = instFD fd clas_tvs tys1 - (ltys2, irs2) = instFD_WithPos fd clas_tvs tys2 + (ltys1, rtys1) = instFD fd clas_tvs tys_inst + (ltys2, irs2) = instFD_WithPos fd clas_tvs tys_actual \end{code} @@ -529,13 +551,8 @@ badFunDeps cls_insts clas ins_tv_set ins_tys = nubBy eq_inst $ [ ispec | fd <- fds, -- fds is often empty, so do this first! let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs, - ispec@(ClsInst { is_tcs = inst_tcs, is_tvs = tvs, - is_tys = tys }) <- cls_insts, - -- Filter out ones that can't possibly match, - -- based on the head of the fundep - not (instanceCantMatch inst_tcs trimmed_tcs), - notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) - fd clas_tvs tys ins_tys) + ispec <- cls_insts, + notNull (checkClsFD fd clas_tvs ispec ins_tv_set ins_tys trimmed_tcs) ] where (clas_tvs, fds) = classTvsFds clas |