[commit: ghc] wip/T9233: Address #9233. (6772f8f)

[git at git.haskell.org]

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

On branch  : wip/T9233
Link       : http://ghc.haskell.org/trac/ghc/changeset/6772f8f2ac70fa6dc246aff001ddbd1533db4b5b/ghc

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

commit 6772f8f2ac70fa6dc246aff001ddbd1533db4b5b
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Tue Jul 15 16:45:06 2014 -0400

    Address #9233.
    
    The implementation of coercionRole on an NthCo coercion was
    terrible terrible terrible when called on deeply-nested NthCo's.
    This commit includes a streamlined algorithm to get this role.


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

6772f8f2ac70fa6dc246aff001ddbd1533db4b5b
 compiler/types/Coercion.lhs | 35 ++++++++++++++++++++++++++++++++---
 1 file changed, 32 insertions(+), 3 deletions(-)

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index b33eae9..3c1221a 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -1854,13 +1854,42 @@ coercionRole = go
     go (UnivCo r _ _)       = r
     go (SymCo co)           = go co
     go (TransCo co1 _)      = go co1 -- same as go co2
-    go (NthCo n co)         = let Pair ty1 _ = coercionKind co
-                                  (tc, _) = splitTyConApp ty1
-                              in nthRole (coercionRole co) tc n
+    go (NthCo n co)         = nthCoRole n co
     go (LRCo _ _)           = Nominal
     go (InstCo co _)        = go co
     go (SubCo _)            = Representational
     go (AxiomRuleCo c _ _)  = coaxrRole c
+
+-- | Gets the role of an NthCo. This is implemented separately
+-- because the naive version was very very slow. See #9233.
+nthCoRole :: Int -> Coercion -> Role
+nthCoRole n0 co0
+  | Representational <- r
+  = nthRole r tc n0
+  | otherwise
+  = r         -- Nominal and Phantom are simpler!
+  where
+    (tc, r) = tycon_role co0
+
+    tycon_role (Refl r ty)
+      = (tyConAppTyCon ty, r)
+    tycon_role (TyConAppCo r tc _) = (tc, r)
+    tycon_role (CoVarCo cv)
+      = (tyConAppTyCon $ fst $ coVarKind cv, coVarRole cv)
+    tycon_role (UnivCo r ty1 _)
+      = (tyConAppTyCon ty1, r)
+    tycon_role (SymCo co) = tycon_role co
+    tycon_role (TransCo co1 _) = tycon_role co1
+    tycon_role (NthCo n co)
+      = case tycon_role co of
+          (tc1, Representational) -> (tc1, nthRole Representational tc1 n)
+          (_, role)               -> (panic "tycon_role NthCo", role)
+    tycon_role (LRCo {})
+      = (panic "tycon_role LRCo", Nominal)
+    tycon_role co
+          -- can't really improve upon other algorithms in other cases
+      = (tyConAppTyCon $ pFst $ coercionKind co, coercionRole co)
+
 \end{code}
 
 Note [Nested InstCos]