26 Jul 20:58 2013

## Are type families really this slow, or is this a GHC bug?

Mike Izbicki <mike <at> izbicki.me>

2013-07-26 18:58:25 GMT

2013-07-26 18:58:25 GMT

I'm using the TypeFamilies extension to generate types that are quite
large. GHC can handle these large types fine when they are created
manually, but when type families get involved, GHC's performance dies.
It's doing in quadratic time what looks to me like it should be linear
time. I don't know if this is expected behavior, if I'm doing something
wrong, or if this is a GHC bug.

I've attached a code sample below that demonstrates the problem. Types.hs generates other haskell files. The first parameter is the size of the type (which is type list of that length), and the second specifies which test to run. All tests generate the same type in the end, but some use type families and some don't.

I've attached a code sample below that demonstrates the problem. Types.hs generates other haskell files. The first parameter is the size of the type (which is type list of that length), and the second specifies which test to run. All tests generate the same type in the end, but some use type families and some don't.

Here's an example of running it:

These
tests show quadratic time when using the type family. I have to
increase the context stack size to be greater than the recursion depth
of the type family. I don't know if this is a bad sign or to be
expected.

$ ghc --version

The Glorious Glasgow Haskell Compilation System, version 7.6.3

$ ghc Types

$ ./Types 200 a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=250

real 0m2.973s

$ ./Types 300 a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=350

real 0m6.018s

$ ./Types 400 a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=450

real 0m9.995s

$ ./Types 500 a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=550

real 0m15.645s

Without the type family, I get MUCH better performance:

$ ./Types 10000 d > test.hs && time ghc test.hs > /dev/null

real 0m2.271s

------------------------

------------------------

import System.Environment

code :: Int -> String -> String

code i test = concat $ map (++"\n") $

[ "{-# LANGUAGE TypeOperators,DataKinds,

KindSignatures,TypeFamilies,PolyKinds #-}"

, "import GHC.TypeLits"

, "data Nat1 = Zero | Succ Nat1"

, "type family Replicate1 (n :: Nat1) (x::a) :: [a]"

, "type instance Replicate1 Zero x = '[]"

, "type instance Replicate1 (Succ n) x = x ': (Replicate1 n x)"

, "class Class a where"

, " f :: a -> a"

, "data Data (xs::a) = X | Y"

, " deriving (Read,Show)"

, "main = print test1"

]

++

case head test of

'a' ->

[ "instance (xs ~ Replicate1 ("++mkNat1 i++") ()) => Class (Data xs) where"

, " f X = Y"

, " f Y = X"

, "test1 = f (X :: Data ( Replicate1 ("++mkNat1 i++") () ))"

]

'b' ->

[ "instance (xs ~ ("++mkList i++") ) => Class (Data xs) where"

, " f X = Y"

, " f Y = X"

, "test1 = f (X :: Data ( Replicate1 ("++mkNat1 i++") () ))"

]

'c' ->

[ "instance (xs ~ Replicate1 ("++mkNat1 i++") ()) => Class (Data xs) where"

, " f X = Y"

, " f Y = X"

, "test1 = f (X :: Data ( ("++mkList i++") ))"

]

otherwise ->

[ "instance (xs ~ ("++mkList i++") ) => Class (Data xs) where"

, " f X = Y"

, " f Y = X"

, "test1 = f (X :: Data ( ("++mkList i++") ))"

]

mkList :: Int -> String

mkList 0 = " '[] "

mkList i = " () ': " ++ mkList (i-1)

mkNat1 :: Int -> String

mkNat1 0 = " Zero "

mkNat1 i = " Succ ( " ++ mkNat1 (i-1) ++ ")"

main = do

numstr : test : xs <- getArgs

let num = read numstr :: Int

putStrLn $ code num test

, "import GHC.TypeLits"

, "data Nat1 = Zero | Succ Nat1"

, "type family Replicate1 (n :: Nat1) (x::a) :: [a]"

, "type instance Replicate1 Zero x = '[]"

, "type instance Replicate1 (Succ n) x = x ': (Replicate1 n x)"

, "class Class a where"

, " f :: a -> a"

, "data Data (xs::a) = X | Y"

, " deriving (Read,Show)"

, "main = print test1"

]

++

case head test of

'a' ->

[ "instance (xs ~ Replicate1 ("++mkNat1 i++") ()) => Class (Data xs) where"

, " f X = Y"

, " f Y = X"

, "test1 = f (X :: Data ( Replicate1 ("++mkNat1 i++") () ))"

]

'b' ->

[ "instance (xs ~ ("++mkList i++") ) => Class (Data xs) where"

, " f X = Y"

, " f Y = X"

, "test1 = f (X :: Data ( Replicate1 ("++mkNat1 i++") () ))"

]

'c' ->

[ "instance (xs ~ Replicate1 ("++mkNat1 i++") ()) => Class (Data xs) where"

, " f X = Y"

, " f Y = X"

, "test1 = f (X :: Data ( ("++mkList i++") ))"

]

otherwise ->

[ "instance (xs ~ ("++mkList i++") ) => Class (Data xs) where"

, " f X = Y"

, " f Y = X"

, "test1 = f (X :: Data ( ("++mkList i++") ))"

]

mkList :: Int -> String

mkList 0 = " '[] "

mkList i = " () ': " ++ mkList (i-1)

mkNat1 :: Int -> String

mkNat1 0 = " Zero "

mkNat1 i = " Succ ( " ++ mkNat1 (i-1) ++ ")"

main = do

numstr : test : xs <- getArgs

let num = read numstr :: Int

putStrLn $ code num test

_______________________________________________ Haskell-Cafe mailing list Haskell-Cafe <at> haskell.org http://www.haskell.org/mailman/listinfo/haskell-cafe