diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2016-10-14 17:35:38 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2016-10-21 17:16:07 +0100 |
| commit | 6ddba64287fe07df3b2df1f3db974b03945fc07f (patch) | |
| tree | 7fb1647acc0fcf649c77118607906511947ba1fc | |
| parent | e1fc5a3351bc02dc059db5c2a1079b04db18b401 (diff) | |
| download | haskell-6ddba64287fe07df3b2df1f3db974b03945fc07f.tar.gz | |
Improve TcCanonical.unifyWanted and unifyDerived
When debugging something else I noticed that these functions
were emitting constraints like
[W] a ~ a
which is plain stupid. So I fixed it not to do that. Should
result in fewer constraints getting generated.
| -rw-r--r-- | compiler/typecheck/TcCanonical.hs | 33 |
1 files changed, 19 insertions, 14 deletions
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 1a35bcc280..3419400fc2 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -1823,25 +1823,27 @@ unifyWanted loc role orig_ty1 orig_ty2 = do { cos <- zipWith3M (unifyWanted loc) (tyConRolesX role tc1) tys1 tys2 ; return (mkTyConAppCo role tc1 cos) } - go (TyVarTy tv) ty2 + + go ty1@(TyVarTy tv) ty2 = do { mb_ty <- isFilledMetaTyVar_maybe tv ; case mb_ty of Just ty1' -> go ty1' ty2 - Nothing -> bale_out } - go ty1 (TyVarTy tv) + Nothing -> bale_out ty1 ty2} + go ty1 ty2@(TyVarTy tv) = do { mb_ty <- isFilledMetaTyVar_maybe tv ; case mb_ty of Just ty2' -> go ty1 ty2' - Nothing -> bale_out } + Nothing -> bale_out ty1 ty2 } go ty1@(CoercionTy {}) (CoercionTy {}) = return (mkReflCo role ty1) -- we just don't care about coercions! - go _ _ = bale_out + go ty1 ty2 = bale_out ty1 ty2 - bale_out = do { (new_ev, co) <- newWantedEq loc role orig_ty1 orig_ty2 - ; emitWorkNC [new_ev] - ; return co } + bale_out ty1 ty2 + | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1) + -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) + | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2 unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () -- See Note [unifyWanted and unifyDerived] @@ -1869,19 +1871,22 @@ unify_derived loc role orig_ty1 orig_ty2 | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 - go (TyVarTy tv) ty2 + go ty1@(TyVarTy tv) ty2 = do { mb_ty <- isFilledMetaTyVar_maybe tv ; case mb_ty of Just ty1' -> go ty1' ty2 - Nothing -> bale_out } - go ty1 (TyVarTy tv) + Nothing -> bale_out ty1 ty2 } + go ty1 ty2@(TyVarTy tv) = do { mb_ty <- isFilledMetaTyVar_maybe tv ; case mb_ty of Just ty2' -> go ty1 ty2' - Nothing -> bale_out } - go _ _ = bale_out + Nothing -> bale_out ty1 ty2 } + go ty1 ty2 = bale_out ty1 ty2 - bale_out = emitNewDerivedEq loc role orig_ty1 orig_ty2 + bale_out ty1 ty2 + | ty1 `tcEqType` ty2 = return () + -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) + | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2 maybeSym :: SwapFlag -> TcCoercion -> TcCoercion maybeSym IsSwapped co = mkTcSymCo co |