[commit: ghc] master: Add perf test for #12545 (6ddb3aa)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/6ddb3aaf5265d15a422dbaeb5396c2c20acc9ff1/ghc

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

commit 6ddb3aaf5265d15a422dbaeb5396c2c20acc9ff1
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Mon Jun 12 17:03:13 2017 -0400

    Add perf test for #12545
    
    Commit 2b74bd9d8b4c6b20f3e8d9ada12e7db645cc3c19 did wonders for the
    program reported in #12545. Let's add a perf test for it to make sure it
    stays fast.
    
    Test Plan: make test TEST=T12545
    
    Reviewers: austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #12545
    
    Differential Revision: https://phabricator.haskell.org/D3632


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

6ddb3aaf5265d15a422dbaeb5396c2c20acc9ff1
 testsuite/tests/perf/compiler/T12545.hs  | 49 +++++++++++++++++++++++++++
 testsuite/tests/perf/compiler/T12545a.hs | 58 ++++++++++++++++++++++++++++++++
 testsuite/tests/perf/compiler/all.T      | 11 ++++++
 3 files changed, 118 insertions(+)

diff --git a/testsuite/tests/perf/compiler/T12545.hs b/testsuite/tests/perf/compiler/T12545.hs
new file mode 100644
index 0000000..0eb07a0
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T12545.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module T12545 where
+
+import T12545a
+
+data A
+
+type instance ElemsOf A = [ T1, T2, T3, T4, T5, T6, T7, T8
+                          , T9, T10, T11, T12, T13, T14, T15, T16
+                          , T17, T18, T19, T20, T21, T22, T23, T24
+                          , T25, T26, T27, T28, T29, T30, T31, T32
+                          ]
+
+data T1; instance ElemOf A T1 where
+data T2; instance ElemOf A T2 where
+data T3; instance ElemOf A T3 where
+data T4; instance ElemOf A T4 where
+data T5; instance ElemOf A T5 where
+data T6; instance ElemOf A T6 where
+data T7; instance ElemOf A T7 where
+data T8; instance ElemOf A T8 where
+data T9; instance ElemOf A T9 where
+data T10; instance ElemOf A T10 where
+data T11; instance ElemOf A T11 where
+data T12; instance ElemOf A T12 where
+data T13; instance ElemOf A T13 where
+data T14; instance ElemOf A T14 where
+data T15; instance ElemOf A T15 where
+data T16; instance ElemOf A T16 where
+data T17; instance ElemOf A T17 where
+data T18; instance ElemOf A T18 where
+data T19; instance ElemOf A T19 where
+data T20; instance ElemOf A T20 where
+data T21; instance ElemOf A T21 where
+data T22; instance ElemOf A T22 where
+data T23; instance ElemOf A T23 where
+data T24; instance ElemOf A T24 where
+data T25; instance ElemOf A T25 where
+data T26; instance ElemOf A T26 where
+data T27; instance ElemOf A T27 where
+data T28; instance ElemOf A T28 where
+data T29; instance ElemOf A T29 where
+data T30; instance ElemOf A T30 where
+data T31; instance ElemOf A T31 where
+data T32; instance ElemOf A T32 where
diff --git a/testsuite/tests/perf/compiler/T12545a.hs b/testsuite/tests/perf/compiler/T12545a.hs
new file mode 100644
index 0000000..3002085
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T12545a.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module T12545a
+  ( ElemWitness(..)
+  , ElemAt(..)
+  , JustElemPath
+  , FindElem
+  , IsElem
+  , ElemOf
+  , ElemsOf
+  ) where
+
+import Data.Proxy (Proxy(..))
+
+data ElemPath = HeadElem
+              | TailElem ElemPath
+
+data MaybeElemPath = NotElem
+                   | Elem ElemPath
+
+type family FindElem (p :: ElemPath) (a :: k) (l :: [k]) :: MaybeElemPath where
+  FindElem p a (a ': t) = 'Elem p
+  FindElem p a (b ': t) = FindElem ('TailElem p) a t
+  FindElem p a '[] = 'NotElem
+
+type family JustElemPath (p :: MaybeElemPath) :: ElemPath where
+  JustElemPath ('Elem p) = p
+
+data ElemWitness (p :: ElemPath) (a :: k) (l :: [k])  where
+  ElemHeadWitness :: ElemWitness 'HeadElem a (a ': t)
+  ElemTailWitness :: (ElemAt p a t,
+                      FindElem 'HeadElem a (b ': t) ~ 'Elem ('TailElem p))
+                  => ElemWitness p a t -> ElemWitness ('TailElem p) a (b ': t)
+
+class (FindElem 'HeadElem a l ~ 'Elem p) => ElemAt p (a :: k) (l :: [k]) where
+  elemWitness :: Proxy a -> Proxy l -> ElemWitness p a l
+
+instance ElemAt 'HeadElem a (a ': t) where
+  elemWitness _ _ = ElemHeadWitness
+
+instance (ElemAt p a t, FindElem 'HeadElem a (b ': t) ~ 'Elem ('TailElem p))
+         => ElemAt ('TailElem p) a (b ': t) where
+  elemWitness pa _ = ElemTailWitness (elemWitness pa (Proxy :: Proxy t))
+
+type IsElem a l = ElemAt (JustElemPath (FindElem 'HeadElem a l)) a l
+
+class IsElem t (ElemsOf a) => ElemOf a t where
+
+type family ElemsOf a :: [*]
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 8ea1c72..a55df8e 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -1043,6 +1043,17 @@ test('T12234',
      compile,
      [''])
 
+test('T12545',
+     [ only_ways(['normal']),
+       compiler_stats_num_field('bytes allocated',
+          [(wordsize(64), 3538652464, 5),
+          # 2017-06-08    3538652464  initial
+          ]),
+       extra_clean(['T12545a.hi', 'T12545a.o'])
+     ],
+     multimod_compile,
+     ['T12545', '-v0'] )
+
 test('T13035',
      [ only_ways(['normal']),
        compiler_stats_num_field('bytes allocated',