[commit: ghc] master: cmpTypeX: Avoid kind comparison when possible (073e20e)
git at git.haskell.org
git at git.haskell.org
Thu Feb 25 16:16:50 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/073e20ebda73309173b6b6e3ea10164e8808cc79/ghc
>---------------------------------------------------------------
commit 073e20ebda73309173b6b6e3ea10164e8808cc79
Author: Ben Gamari <bgamari.foss at gmail.com>
Date: Thu Feb 25 15:44:20 2016 +0100
cmpTypeX: Avoid kind comparison when possible
This comparison is only necessary when the types being compared contain
casts. Otherwise the structural equality of the types implies that their
kinds are equal.
Test Plan: Validate
Reviewers: goldfire, austin, simonpj
Reviewed By: simonpj
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1944
GHC Trac Issues: #11597
>---------------------------------------------------------------
073e20ebda73309173b6b6e3ea10164e8808cc79
compiler/types/Type.hs | 85 +++++++++++++++++++++++++++++++++++---------------
1 file changed, 60 insertions(+), 25 deletions(-)
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index bca64c2..78c20a9 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -2074,46 +2074,79 @@ cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2
where
rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2)))
+-- | An ordering relation between two 'Type's (known below as @t1 :: k1@
+-- and @t2 :: k2@)
+data TypeOrdering = TLT -- ^ @t1 < t2@
+ | TEQ -- ^ @t1 ~ t2@ and there are no casts in either,
+ -- therefore we can conclude @k1 ~ k2@
+ | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so
+ -- they may differ in kind.
+ | TGT -- ^ @t1 > t2@
+ deriving (Eq, Ord, Enum, Bounded)
+
cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse
-- See Note [Non-trivial definitional equality] in TyCoRep
-cmpTypeX env orig_t1 orig_t2
- = go env orig_t1 orig_t2 `thenCmp` go env k1 k2
- -- NB: this ordering appears to be faster than the other
+cmpTypeX env orig_t1 orig_t2 =
+ case go env orig_t1 orig_t2 of
+ -- If there are casts then we also need to do a comparison of the kinds of
+ -- the types being compared
+ TEQX -> toOrdering $ go env k1 k2
+ ty_ordering -> toOrdering ty_ordering
where
k1 = typeKind orig_t1
k2 = typeKind orig_t2
- -- short-cut to handle comparing * against *.
- -- appears to have a roughly 1% improvement in compile times
- go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = EQ
-
- go env t1 t2 | Just t1' <- coreViewOneStarKind t1 = go env t1' t2
- go env t1 t2 | Just t2' <- coreViewOneStarKind t2 = go env t1 t2'
+ toOrdering :: TypeOrdering -> Ordering
+ toOrdering TLT = LT
+ toOrdering TEQ = EQ
+ toOrdering TEQX = EQ
+ toOrdering TGT = GT
+
+ liftOrdering :: Ordering -> TypeOrdering
+ liftOrdering LT = TLT
+ liftOrdering EQ = TEQ
+ liftOrdering GT = TGT
+
+ thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering
+ thenCmpTy TEQ rel = rel
+ thenCmpTy TEQX rel = hasCast rel
+ thenCmpTy rel _ = rel
+
+ hasCast :: TypeOrdering -> TypeOrdering
+ hasCast TEQ = TEQX
+ hasCast rel = rel
+
+ -- Returns both the resulting ordering relation between the two types
+ -- and whether either contains a cast.
+ go :: RnEnv2 -> Type -> Type -> TypeOrdering
+ go env t1 t2
+ | Just t1' <- coreViewOneStarKind t1 = go env t1' t2
+ | Just t2' <- coreViewOneStarKind t2 = go env t1 t2'
go env (TyVarTy tv1) (TyVarTy tv2)
- = rnOccL env tv1 `compare` rnOccR env tv2
+ = liftOrdering $ rnOccL env tv1 `compare` rnOccR env tv2
go env (ForAllTy (Named tv1 _) t1) (ForAllTy (Named tv2 _) t2)
= go env (tyVarKind tv1) (tyVarKind tv2)
- `thenCmp` go (rnBndr2 env tv1 tv2) t1 t2
+ `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2
-- See Note [Equality on AppTys]
go env (AppTy s1 t1) ty2
| Just (s2, t2) <- repSplitAppTy_maybe ty2
- = go env s1 s2 `thenCmp` go env t1 t2
+ = go env s1 s2 `thenCmpTy` go env t1 t2
go env ty1 (AppTy s2 t2)
| Just (s1, t1) <- repSplitAppTy_maybe ty1
- = go env s1 s2 `thenCmp` go env t1 t2
+ = go env s1 s2 `thenCmpTy` go env t1 t2
go env (ForAllTy (Anon s1) t1) (ForAllTy (Anon s2) t2)
- = go env s1 s2 `thenCmp` go env t1 t2
+ = go env s1 s2 `thenCmpTy` go env t1 t2
go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)
- = (tc1 `cmpTc` tc2) `thenCmp` gos env tys1 tys2
- go _ (LitTy l1) (LitTy l2) = compare l1 l2
- go env (CastTy t1 _) t2 = go env t1 t2
- go env t1 (CastTy t2 _) = go env t1 t2
- go _ (CoercionTy {}) (CoercionTy {}) = EQ
+ = liftOrdering (tc1 `cmpTc` tc2) `thenCmpTy` gos env tys1 tys2
+ go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2)
+ go env (CastTy t1 _) t2 = hasCast $ go env t1 t2
+ go env t1 (CastTy t2 _) = hasCast $ go env t1 t2
+ go _ (CoercionTy {}) (CoercionTy {}) = TEQ
-- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy
go _ ty1 ty2
- = (get_rank ty1) `compare` (get_rank ty2)
+ = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2)
where get_rank :: Type -> Int
get_rank (CastTy {})
= pprPanic "cmpTypeX.get_rank" (ppr [ty1,ty2])
@@ -2125,15 +2158,17 @@ cmpTypeX env orig_t1 orig_t2
get_rank (ForAllTy (Anon {}) _) = 6
get_rank (ForAllTy (Named {}) _) = 7
- gos _ [] [] = EQ
- gos _ [] _ = LT
- gos _ _ [] = GT
- gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmp` gos env tys1 tys2
+ gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering
+ gos _ [] [] = TEQ
+ gos _ [] _ = TLT
+ gos _ _ [] = TGT
+ gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2
-------------
cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering
cmpTypesX _ [] [] = EQ
-cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2
+cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2
+ `thenCmp` cmpTypesX env tys1 tys2
cmpTypesX _ [] _ = LT
cmpTypesX _ _ [] = GT
More information about the ghc-commits
mailing list