Avoid quadratic complexity in typeKind
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 26 Mar 2018 14:54:53 +0000 (15:54 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 27 Mar 2018 08:29:13 +0000 (09:29 +0100)
I took 10 minute to fix this potential performance hole
(Trac #14263)

There are no actual bug reports against it, so no regression
test.

compiler/types/Type.hs

index ef387b6..c274116 100644 (file)
@@ -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