[commit: ghc] master: Avoid quadratic complexity in typeKind (1fce2c3)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/1fce2c3a83f0356146f24674b79b04f66c231e9d/ghc

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

commit 1fce2c3a83f0356146f24674b79b04f66c231e9d
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Mar 26 15:54:53 2018 +0100

    Avoid quadratic complexity in typeKind
    
    I took 10 minute to fix this potential performance hole
    (Trac #14263)
    
    There are no actual bug reports against it, so no regression
    test.


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

1fce2c3a83f0356146f24674b79b04f66c231e9d
 compiler/types/Type.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index ef387b6..c274116 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -2296,7 +2296,7 @@ nonDetCmpTc tc1 tc2
 
 typeKind :: HasDebugCallStack => Type -> Kind
 typeKind (TyConApp tc tys)     = piResultTys (tyConKind tc) tys
-typeKind (AppTy fun arg)       = piResultTy (typeKind fun) arg
+typeKind (AppTy fun arg)       = typeKind_apps fun [arg]
 typeKind (LitTy l)             = typeLiteralKind l
 typeKind (FunTy {})            = liftedTypeKind
 typeKind (ForAllTy _ ty)       = typeKind ty
@@ -2304,6 +2304,15 @@ typeKind (TyVarTy tyvar)       = tyVarKind tyvar
 typeKind (CastTy _ty co)       = pSnd $ coercionKind co
 typeKind (CoercionTy co)       = coercionType co
 
+typeKind_apps :: HasDebugCallStack => Type -> [Type] -> Kind
+-- The sole purpose of the function is to accumulate
+-- the type arugments, so we can call piResultTys, rather than
+-- a succession of calls to piResultTy (which is asymptotically
+-- less efficient as the number of arguments increases)
+typeKind_apps (AppTy fun arg) args = typeKind_apps fun (arg:args)
+typeKind_apps fun             args = piResultTys (typeKind fun) args
+
+--------------------------
 typeLiteralKind :: TyLit -> Kind
 typeLiteralKind l =
   case l of