GitLab

Consider the following program:

{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
module Bug where

data family Sing (z :: k)

class SEq k where
  (%==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> ()
  infix 4 %==

data Foo a b c d
  = A a b c d |
    B a b c d |
    C a b c d |
    D a b c d |
    E a b c d |
    F a b c d

data instance Sing (z_awDE :: Foo a b c d) where
    SA :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('A a b c d)
    SB :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('B a b c d)
    SC :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('C a b c d)
    SD :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('D a b c d)
    SE :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('E a b c d)
    SF :: Sing a -> Sing b -> Sing c -> Sing d -> Sing ('F a b c d)

$([d| instance (SEq a, SEq b, SEq c, SEq d) => SEq (Foo a b c d) where
        (%==) (SA _ _ _ _) (SA _ _ _ _) = ()
        (%==) (SA _ _ _ _) (SB _ _ _ _) = ()
        (%==) (SA _ _ _ _) (SC _ _ _ _) = ()
        (%==) (SA _ _ _ _) (SD _ _ _ _) = ()
        (%==) (SA _ _ _ _) (SE _ _ _ _) = ()
        (%==) (SA _ _ _ _) (SF _ _ _ _) = ()
        (%==) (SB _ _ _ _) (SA _ _ _ _) = ()
        (%==) (SB _ _ _ _) (SB _ _ _ _) = ()
        (%==) (SB _ _ _ _) (SC _ _ _ _) = ()
        (%==) (SB _ _ _ _) (SD _ _ _ _) = ()
        (%==) (SB _ _ _ _) (SE _ _ _ _) = ()
        (%==) (SB _ _ _ _) (SF _ _ _ _) = ()
        (%==) (SC _ _ _ _) (SA _ _ _ _) = ()
        (%==) (SC _ _ _ _) (SB _ _ _ _) = ()
        (%==) (SC _ _ _ _) (SC _ _ _ _) = ()
        (%==) (SC _ _ _ _) (SD _ _ _ _) = ()
        (%==) (SC _ _ _ _) (SE _ _ _ _) = ()
        (%==) (SC _ _ _ _) (SF _ _ _ _) = ()
        (%==) (SD _ _ _ _) (SA _ _ _ _) = ()
        (%==) (SD _ _ _ _) (SB _ _ _ _) = ()
        (%==) (SD _ _ _ _) (SC _ _ _ _) = ()
        (%==) (SD _ _ _ _) (SD _ _ _ _) = ()
        (%==) (SD _ _ _ _) (SE _ _ _ _) = ()
        (%==) (SD _ _ _ _) (SF _ _ _ _) = ()
        (%==) (SE _ _ _ _) (SA _ _ _ _) = ()
        (%==) (SE _ _ _ _) (SB _ _ _ _) = ()
        (%==) (SE _ _ _ _) (SC _ _ _ _) = ()
        (%==) (SE _ _ _ _) (SD _ _ _ _) = ()
        (%==) (SE _ _ _ _) (SE _ _ _ _) = ()
        (%==) (SE _ _ _ _) (SF _ _ _ _) = ()
        (%==) (SF _ _ _ _) (SA _ _ _ _) = ()
        (%==) (SF _ _ _ _) (SB _ _ _ _) = ()
        (%==) (SF _ _ _ _) (SC _ _ _ _) = ()
        (%==) (SF _ _ _ _) (SD _ _ _ _) = ()
        (%==) (SF _ _ _ _) (SE _ _ _ _) = ()
        (%==) (SF _ _ _ _) (SF _ _ _ _) = () |])

It takes significantly longer to compile this program on 8.4 and HEAD:

$ /opt/ghc/8.4.1/bin/ghc --version
The Glorious Glasgow Haskell Compilation System, version 8.4.1
$ time /opt/ghc/8.4.1/bin/ghc Bug.hs -fforce-recomp
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o )

real    0m0.285s
user    0m0.236s
sys     0m0.036s
$ /opt/ghc/head/bin/ghc --version                      
The Glorious Glasgow Haskell Compilation System, version 8.5.20180306
$ time /opt/ghc/head/bin/ghc Bug.hs -fforce-recomp     
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o )

real    0m29.684s
user    0m29.656s
sys     0m0.060s

The reason for this regression is somewhat incidental—it's due to commit ffb2738f (Fix #14838 by marking TH-spliced code as FromSource). Before that commit, we were supressing pattern-match coverage checking entirely on TH-quoted code. We no longer do this, which means that we coverage-check the TH-quoted instance in that program, which appears to be why it takes so long to compile.

This is a serious issue in practice because a good chunk of singletons-generated code is of this form, which means that a good amount of code is effectively uncompilable on GHC HEAD now. (See, for instance, this Travis failure on GHC HEAD.)

Trac metadata

Trac field	Value
Version	8.5
Type	Bug
TypeOfFailure	OtherFailure
Priority	highest
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture