TypeFamilies painfully slow

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.

Related tickets

• #17223
• #22323
• #25360

Related MRs

• !6476 Directed coercions
• !9210 (closed) Tweak isAxiom_maybe to ignore non-newtype axioms

Unlike in ticket #5321 (closed), using tail recursion does not eliminate the problem, and the order of arguments greatly affects compile time.

I've attached a file Types.hs that demonstrates the problems:

Types.hs

import System.Environment

code :: Int -> String -> String -> String
code i familyTest instanceTest = concat $ map (++"\n") $
    [ "{-# LANGUAGE TypeOperators,DataKinds,KindSignatures,TypeFamilies,PolyKinds,UndecidableInstances #-}"
    , "import GHC.TypeLits"

    , "data Nat1 = Zero | Succ Nat1"
    ]
    ++
    case head familyTest of
        'a' -> 
            [ "type family Replicate1 (n :: Nat1) (x::a) :: [a]"
            , "type instance Replicate1 Zero x = '[]"
            , "type instance Replicate1 (Succ n) x = x ': (Replicate1 n x)"
            ]
        'b' -> 
            [ "type family Replicate1 (n :: Nat1) (x::a) :: [a]"
            , "type instance Replicate1 n x = Replicate1' '[] n x "
            , "type family Replicate1' (acc::[a]) (n :: Nat1) (x::a)  :: [a]"
            , "type instance Replicate1' acc Zero x = acc"
            , "type instance Replicate1' acc (Succ n) x = Replicate1' (x ': acc) n x "
            ]
        'c' -> 
            [ "type family Replicate1 (n :: Nat1) (x::a) :: [a]"
            , "type instance Replicate1 n x = Replicate1' n x '[]"
            , "type family Replicate1' (n :: Nat1) (x::a) (acc::[a]) :: [a]"
            , "type instance Replicate1' Zero x acc = acc"
            , "type instance Replicate1' (Succ n) x acc = Replicate1' n x (x ': acc)"
            ]
    ++
    [ "class Class a where"
    , "    f :: a -> a"

    , "data Data (xs::a) = X | Y"
    , "    deriving (Read,Show)"
    
    , "main = print test1"
    ]
    ++
    case head instanceTest 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++") ))"
            ]
        'd' -> 
            [ "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 : familyTest : instanceTest : xs <- getArgs
    let num = read numstr :: Int
    
    putStrLn $ code num familyTest instanceTest 

This file generates another Haskell file which has the problems. It takes 3 flags. The first is the size of the type to generate, the second is which type family function to use, and the third is whether to call the type family or just use a manually generated type.

Here are my performance results:

Using non-tail recursion, I get these results. I have to increase the stack size based on the size of the type I want to generate.

$ ./Types 200 a a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=250
real    0m2.973s
$ ./Types 300 a a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=350
real    0m6.018s
$ ./Types 400 a a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=450
real    0m9.995s
$ ./Types 500 a a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=550
real    0m15.645s

Tail recursion generates much slower compile times for some reason, and I still need to adjust the stack size:

$ ./Types 200 b a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=250
real    0m16.120s

Changing the order of arguments to the recursive type family greatly changes the run times:

$ ./Types 200 c a > test.hs && time ghc test.hs > /dev/null -fcontext-stack=250
real    0m6.095s

Without the type family, I get MUCH better performance:

$ ./Types 10000 a d > test.hs && time ghc test.hs > /dev/null
real    0m2.271s

Trac metadata

Trac field	Value
Version	7.6.3
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler (Type checker)
Test case
Differential revisions
BlockedBy
Related	#5321 (closed)
Blocking
CC
Operating system
Architecture