[commit: ghc] ghc-8.0: cmpTypeX: Avoid kind comparison when possible (6f7baa0)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/6f7baa0eb995b6cef8b9ae4ad0845f76a229bd3b/ghc

>---------------------------------------------------------------

commit 6f7baa0eb995b6cef8b9ae4ad0845f76a229bd3b
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
    
    (cherry picked from commit 073e20ebda73309173b6b6e3ea10164e8808cc79)


>---------------------------------------------------------------

6f7baa0eb995b6cef8b9ae4ad0845f76a229bd3b
 compiler/types/Type.hs | 76 ++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 58 insertions(+), 18 deletions(-)

diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index d08afb8..07b20c6 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -2045,40 +2045,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 k1 k2 `thenCmp` go env orig_t1 orig_t2
+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
 
-    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])
@@ -2090,10 +2129,11 @@ cmpTypeX env orig_t1 orig_t2 = go env k1 k2 `thenCmp` go 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