Performance test for Trac #5321

3 files changed, 237 insertions, 0 deletions

diff --git a/testsuite/tests/perf/compiler/T5321FD.hs b/testsuite/tests/perf/compiler/T5321FD.hs
new file mode 100644
index 0000000000..6e10939837
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T5321FD.hs
@@ -0,0 +1,102 @@
+{-# OPTIONS_GHC -fcontext-stack=1000 #-} 
+{-# LANGUAGE 
+     FlexibleContexts, FlexibleInstances, FunctionalDependencies, 
+     MultiParamTypeClasses, OverlappingInstances, TypeSynonymInstances, 
+     TypeOperators, UndecidableInstances, TypeFamilies #-} 
+module T5321FD where
+
+-------- USES FUNCTIONAL DEPENDENCIES -------------
+
+-- Our running example, for simplicity's sake, is a type-level map of a
+-- single function. For reference, here is the code for a simple
+-- value-level map of a single function.
+
+-- vfoo = id
+-- mapfoo (x : xs) = vfoo x : mapfoo xs
+-- mapfoo [] = []
+
+-- Because Haskell is a lazy language, this runs in O(n) time and constant stack.
+
+-- We now lift map to the type level, to operate over HLists.
+
+-- First, the basic HList types
+
+infixr 3 :*
+data x :* xs = x :* xs deriving Show
+data HNil = HNil deriving Show
+
+-- Next, a large boring HList
+
+-- Adds ten cells
+addData x = i :* i :* d :* d :* s :* 
+            i :* i :* d :* d :* s :* 
+            x 
+    where i = 1 :: Int 
+          d = 1 :: Double 
+          s = "" 
+
+-- Has 70 cells. 
+sampleData = addData $ addData $ addData $ addData $ addData $ 
+             addData $ addData $ 
+             HNil
+
+-- Next, a simple polymorphic function to map
+
+class Foo x y | x -> y 
+    where foo :: x -> y 
+          foo = undefined
+
+instance Foo Int Double
+instance Foo Double Int
+instance Foo String String
+
+------------------------
+-- Now, our map
+
+class HMapFoo1 as bs | as -> bs where 
+    hMapFoo1 :: as -> bs
+
+instance (Foo a b, HMapFoo1 as bs) => HMapFoo1 (a :* as) (b :* bs) where 
+    hMapFoo1 (x :* xs) = foo x :* hMapFoo1 xs
+
+instance HMapFoo1 HNil HNil where 
+    hMapFoo1 _ = HNil
+
+-- If we enable the following line, compilation time is ~ 9 seconds.
+
+testHMapFoo1 = hMapFoo1 sampleData 
+
+
+------------------------
+class HMapFoo2 acc as bs | acc as -> bs where 
+    hMapFoo2 :: acc -> as -> bs
+
+instance (Foo a b, HMapFoo2 (b :* bs) as res) => HMapFoo2 bs (a :* as) res where 
+    hMapFoo2 acc (x :* xs) = hMapFoo2 (foo x :* acc) xs
+
+instance HMapFoo2 acc HNil acc where 
+    hMapFoo2 acc _ = acc
+
+-- If we enable the following line, compilation time is a much more satisfying ~0.5s.
+
+testHMapFoo2 = hMapFoo2 HNil sampleData 
+
+------------------------
+-- But wait, there's trouble on the horizon! Consider the following version: 
+
+class HMapFoo3 acc as bs | acc as -> bs where 
+    hMapFoo3 :: acc -> as -> bs
+
+instance (HMapFoo3 (b :* bs) as res, Foo a b) => HMapFoo3 bs (a :* as) res where 
+    hMapFoo3 acc (x :* xs) = hMapFoo3 (foo x :* acc) xs
+
+instance HMapFoo3 acc HNil acc where 
+    hMapFoo3 acc _ = acc
+
+-- The only difference between hMapFoo2 and hMapFoo3 is that the order of
+-- constraints on the inductive case has been reversed, with the
+-- recursive constraint first and the immediately checkable constraint
+-- second. Now, if we enable the following line, compilation time rockets
+-- to ~6s!
+
+testHMapFoo3 = hMapFoo3 HNil sampleData 
diff --git a/testsuite/tests/perf/compiler/T5321Fun.hs b/testsuite/tests/perf/compiler/T5321Fun.hs
new file mode 100644
index 0000000000..efd7db770b
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T5321Fun.hs
@@ -0,0 +1,109 @@
+{-# OPTIONS_GHC -fcontext-stack=1000 #-} 
+{-# LANGUAGE 
+     FlexibleContexts, FlexibleInstances, FunctionalDependencies, 
+     MultiParamTypeClasses, OverlappingInstances, TypeSynonymInstances, 
+     TypeOperators, UndecidableInstances, TypeFamilies #-} 
+module T5321Fun where
+
+-- As the below code demonstrates, the same issues demonstrated with
+-- Functional Dependencies also appear with Type Families, although less
+--horribly, as their code-path seems more optimized in the current
+-- constraint solver:
+
+-- Our running example, for simplicity's sake, is a type-level map of a
+-- single function. For reference, here is the code for a simple
+-- value-level map of a single function.
+
+-- > vfoo = id
+-- > mapfoo (x : xs) = vfoo x : mapfoo xs
+-- > mapfoo [] = []
+
+-- Because Haskell is a lazy language, this runs in O(n) time and constant stack.
+
+-- We now lift map to the type level, to operate over HLists.
+
+-- First, the basic HList types
+
+infixr 3 :*
+data x :* xs = x :* xs deriving Show
+data HNil = HNil deriving Show
+
+-- Next, a large boring HList
+
+-- Adds ten cells
+addData x = i :* i :* d :* d :* s :* 
+            i :* i :* d :* d :* s :* 
+            x 
+    where i = 1 :: Int 
+          d = 1 :: Double 
+          s = "" 
+
+-- Has 70 cells. 
+sampleData = addData $ addData $ addData $ addData $ addData $ 
+             addData $ addData $ 
+             HNil
+
+
+class TFoo x where 
+     type TFooFun x 
+     tfoo :: x -> TFooFun x 
+     tfoo = undefined
+
+instance TFoo Int where 
+    type TFooFun Int = Double
+instance TFoo Double where 
+    type TFooFun Double = Int
+instance TFoo String where 
+    type TFooFun String = String
+
+class THMapFoo1 as where 
+      type THMapFoo1Res as 
+      thMapFoo1 :: as -> THMapFoo1Res as
+
+instance (TFoo a, THMapFoo1 as) => THMapFoo1 (a :* as) where 
+    type THMapFoo1Res (a :* as) = TFooFun a :* THMapFoo1Res as 
+    thMapFoo1 (x :* xs) = tfoo x :* thMapFoo1 xs
+
+instance THMapFoo1 HNil where 
+    type THMapFoo1Res HNil = HNil 
+    thMapFoo1 _ = HNil
+
+-- The following, when enabled, takes ~3.5s. This demonstrates that slowdown occurs with type families as well.
+
+testTHMapFoo1 = thMapFoo1 sampleData 
+
+class THMapFoo2 acc as where 
+      type THMapFoo2Res acc as 
+      thMapFoo2 :: acc -> as -> THMapFoo2Res acc as
+
+instance (TFoo a, THMapFoo2 (TFooFun a :* acc) as) => THMapFoo2 acc (a :* as) where 
+    type THMapFoo2Res acc (a :* as) = THMapFoo2Res (TFooFun a :* acc) as 
+    thMapFoo2 acc (x :* xs) = thMapFoo2 (tfoo x :* acc) xs
+
+instance THMapFoo2 acc HNil where 
+    type THMapFoo2Res acc HNil = acc 
+    thMapFoo2 acc _ = acc
+
+-- The following, when enabled, takes ~0.6s. This demonstrates that the
+-- tail recursive transform fixes the slowdown with type families just as
+-- with fundeps.
+
+testTHMapFoo2 = thMapFoo2 HNil sampleData 
+
+class THMapFoo3 acc as where 
+      type THMapFoo3Res acc as 
+      thMapFoo3 :: acc -> as -> THMapFoo3Res acc as
+
+instance (THMapFoo3 (TFooFun a :* acc) as, TFoo a) => THMapFoo3 acc (a :* as) where 
+    type THMapFoo3Res acc (a :* as) = THMapFoo3Res (TFooFun a :* acc) as 
+    thMapFoo3 acc (x :* xs) = thMapFoo3 (tfoo x :* acc) xs
+
+instance THMapFoo3 acc HNil where 
+    type THMapFoo3Res acc HNil = acc 
+    thMapFoo3 acc _ = acc
+
+-- The following, when enabled, also takes ~0.6s. This demonstrates that,
+-- unlike the fundep case, the order of type class constraints does not,
+-- in this instance, affect the performance of type families.
+
+testTHMapFoo3 = thMapFoo3 HNil sampleData 
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 0d55c726fa..584b8c998e 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -206,3 +206,29 @@ test('T783',
                                                       450000000))
       ],
       compile,[''])
+
+test('T5321Fun',
+     [ only_ways(['normal']),  # no optimisation for this one
+      # expected value: 175,569,928 (x86/Linux)
+      if_wordsize(32,
+          compiler_stats_num_field('bytes allocated', 1000000000,
+                                                      1100000000)),
+      # expected value: 390895576 (amd64/Linux):
+      if_wordsize(64,
+          compiler_stats_num_field('bytes allocated', 2000000000,
+                                                      2200000000))
+      ],
+      compile,[''])
+
+test('T5321FD',
+     [ only_ways(['normal']),  # no optimisation for this one
+      # expected value: 175,569,928 (x86/Linux)
+      if_wordsize(32,
+          compiler_stats_num_field('bytes allocated', 500000000,
+                                                      600000000)),
+      # expected value: 390895576 (amd64/Linux):
+      if_wordsize(64,
+          compiler_stats_num_field('bytes allocated', 1000000000,
+                                                      1200000000))
+      ],
+      compile,[''])