summaryrefslogtreecommitdiff
path: root/testsuite
diff options
context:
space:
mode:
authorAndrzej Rybczak <andrzej@rybczak.net>2020-03-25 19:28:43 +0100
committerAndrzej Rybczak <andrzej@rybczak.net>2020-10-15 11:40:32 +0200
commit998803dc4dbceb36074644483e11e6183fa5355a (patch)
tree3c6ec7866d001b549b36050da6e946d3b6d83f1d /testsuite
parent3d7db1488c4bd7764e8b1fe3cfde4c5a548cde16 (diff)
downloadhaskell-998803dc4dbceb36074644483e11e6183fa5355a.tar.gz
Add flags for annotating Generic{,1} methods INLINE[1] (#11068)
Makes it possible for GHC to optimize away intermediate Generic representation for more types. Metric Increase: T12227
Diffstat (limited to 'testsuite')
-rw-r--r--testsuite/tests/deriving/should_compile/T11068_aggressive.hs12
-rw-r--r--testsuite/tests/deriving/should_compile/T11068_aggressive.stderr250
-rw-r--r--testsuite/tests/deriving/should_compile/all.T1
-rw-r--r--testsuite/tests/perf/compiler/Makefile5
-rw-r--r--testsuite/tests/perf/compiler/T11068.hs104
-rw-r--r--testsuite/tests/perf/compiler/T11068a.hs394
-rw-r--r--testsuite/tests/perf/compiler/T11068b.hs200
-rw-r--r--testsuite/tests/perf/compiler/all.T2
8 files changed, 968 insertions, 0 deletions
diff --git a/testsuite/tests/deriving/should_compile/T11068_aggressive.hs b/testsuite/tests/deriving/should_compile/T11068_aggressive.hs
new file mode 100644
index 0000000000..40c539d37e
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T11068_aggressive.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# OPTIONS_GHC -finline-generics-aggressively #-}
+module T11068_aggressive where
+
+import GHC.Generics
+
+-- For 2 data constructors -finline-generics annotates class methods of the
+-- derived Generic instance as INLINE[1] only if each has at most 5 fields.
+data X
+ = X1 Int Int Int Int Int Int Int Int Int Int
+ | X2 Int Int Int Int Int Int Int Int Int Int
+ deriving Generic
diff --git a/testsuite/tests/deriving/should_compile/T11068_aggressive.stderr b/testsuite/tests/deriving/should_compile/T11068_aggressive.stderr
new file mode 100644
index 0000000000..497b1bc3a0
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T11068_aggressive.stderr
@@ -0,0 +1,250 @@
+
+==================== Derived instances ====================
+Derived class instances:
+ instance GHC.Generics.Generic T11068_aggressive.X where
+ {-# INLINE [1] GHC.Generics.from #-}
+ {-# INLINE [1] GHC.Generics.to #-}
+ GHC.Generics.from x
+ = GHC.Generics.M1
+ (case x of
+ T11068_aggressive.X1 g1 g2 g3 g4 g5 g6 g7 g8 g9 g10
+ -> GHC.Generics.L1
+ (GHC.Generics.M1
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g1))
+ (GHC.Generics.M1 (GHC.Generics.K1 g2)))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g3))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g4))
+ (GHC.Generics.M1 (GHC.Generics.K1 g5)))))
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g6))
+ (GHC.Generics.M1 (GHC.Generics.K1 g7)))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g8))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g9))
+ (GHC.Generics.M1 (GHC.Generics.K1 g10)))))))
+ T11068_aggressive.X2 g1 g2 g3 g4 g5 g6 g7 g8 g9 g10
+ -> GHC.Generics.R1
+ (GHC.Generics.M1
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g1))
+ (GHC.Generics.M1 (GHC.Generics.K1 g2)))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g3))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g4))
+ (GHC.Generics.M1 (GHC.Generics.K1 g5)))))
+ ((GHC.Generics.:*:)
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g6))
+ (GHC.Generics.M1 (GHC.Generics.K1 g7)))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g8))
+ ((GHC.Generics.:*:)
+ (GHC.Generics.M1 (GHC.Generics.K1 g9))
+ (GHC.Generics.M1 (GHC.Generics.K1 g10))))))))
+ GHC.Generics.to (GHC.Generics.M1 x)
+ = case x of
+ (GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) ((GHC.Generics.:*:) ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+ (GHC.Generics.M1 (GHC.Generics.K1 g2)))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g3))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g4))
+ (GHC.Generics.M1 (GHC.Generics.K1 g5)))))
+ ((GHC.Generics.:*:) ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g6))
+ (GHC.Generics.M1 (GHC.Generics.K1 g7)))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g8))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g9))
+ (GHC.Generics.M1 (GHC.Generics.K1 g10))))))))
+ -> T11068_aggressive.X1 g1 g2 g3 g4 g5 g6 g7 g8 g9 g10
+ (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) ((GHC.Generics.:*:) ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+ (GHC.Generics.M1 (GHC.Generics.K1 g2)))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g3))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g4))
+ (GHC.Generics.M1 (GHC.Generics.K1 g5)))))
+ ((GHC.Generics.:*:) ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g6))
+ (GHC.Generics.M1 (GHC.Generics.K1 g7)))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g8))
+ ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g9))
+ (GHC.Generics.M1 (GHC.Generics.K1 g10))))))))
+ -> T11068_aggressive.X2 g1 g2 g3 g4 g5 g6 g7 g8 g9 g10
+
+
+Derived type family instances:
+ type GHC.Generics.Rep T11068_aggressive.X = GHC.Generics.D1
+ ('GHC.Generics.MetaData
+ "X" "T11068_aggressive" "main" 'GHC.Types.False)
+ (GHC.Generics.C1
+ ('GHC.Generics.MetaCons
+ "X1" 'GHC.Generics.PrefixI 'GHC.Types.False)
+ (((GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0 GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))))
+ GHC.Generics.:*: ((GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)))))
+ GHC.Generics.:+: GHC.Generics.C1
+ ('GHC.Generics.MetaCons
+ "X2"
+ 'GHC.Generics.PrefixI
+ 'GHC.Types.False)
+ (((GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))))
+ GHC.Generics.:*: ((GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: (GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int)
+ GHC.Generics.:*: GHC.Generics.S1
+ ('GHC.Generics.MetaSel
+ 'GHC.Maybe.Nothing
+ 'GHC.Generics.NoSourceUnpackedness
+ 'GHC.Generics.NoSourceStrictness
+ 'GHC.Generics.DecidedLazy)
+ (GHC.Generics.Rec0
+ GHC.Types.Int))))))
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 86a48ccf7b..4e938809be 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -65,6 +65,7 @@ test('T7947', [], multimod_compile, ['T7947', '-v0'])
test('T10561', normal, compile, [''])
test('T10487', [], multimod_compile, ['T10487', '-v0'])
test('T10524', normal, compile, [''])
+test('T11068_aggressive', [normalise_errmsg_fun(just_the_deriving)], compile, ['-ddump-deriv -dsuppress-uniques'])
test('T11148', normal, makefile_test, [])
test('T9968', normal, compile, [''])
test('T9968a', normal, compile, [''])
diff --git a/testsuite/tests/perf/compiler/Makefile b/testsuite/tests/perf/compiler/Makefile
index ded99684b3..66597883b6 100644
--- a/testsuite/tests/perf/compiler/Makefile
+++ b/testsuite/tests/perf/compiler/Makefile
@@ -7,3 +7,8 @@ T4007:
$(RM) -f T4007.hi T4007.o
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-rule-firings T4007.hs
+T11068:
+ $(RM) -f T11068a.hi T11068a.o T11068b.hi T11068b.o T11068.hi T11068.o
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068a.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068b.hs
+ -'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068.hs -ddump-simpl | grep 'Generic'
diff --git a/testsuite/tests/perf/compiler/T11068.hs b/testsuite/tests/perf/compiler/T11068.hs
new file mode 100644
index 0000000000..5e39ea7c90
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T11068.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+module T11068 where
+
+import Control.DeepSeq
+import GHC.Generics
+
+import T11068a
+import T11068b
+
+-- X1
+
+instance NFData X1
+
+x1_id :: X1 -> X1
+x1_id = to . from
+
+x1_lens :: Lens' X1 Integer
+x1_lens = gfield @"x1_f1"
+
+-- X1'
+
+instance NFData X1'
+
+x1'_id :: X1' -> X1'
+x1'_id = to . from
+
+x1'_lens :: Lens' X1' Integer
+x1'_lens = gfield @"x1'_f1"
+
+-- X4
+
+instance NFData X4
+
+x4_id :: X4 -> X4
+x4_id = to . from
+
+x4_lens :: Lens' X4 Integer
+x4_lens = gfield @"x4_f1"
+
+-- X4'
+
+instance NFData X4'
+
+x4'_id :: X4' -> X4'
+x4'_id = to . from
+
+x4'_lens :: Lens' X4' Integer
+x4'_lens = gfield @"x4'_f1"
+
+-- X8
+
+instance NFData X8
+
+x8_id :: X8 -> X8
+x8_id = to . from
+
+x8_lens :: Lens' X8 Integer
+x8_lens = gfield @"x8_f1"
+
+-- X8'
+
+instance NFData X8'
+
+x8'_id :: X8' -> X8'
+x8'_id = to . from
+
+x8'_lens :: Lens' X8' Integer
+x8'_lens = gfield @"x8'_f1"
+
+-- X12'
+
+instance NFData X12'
+
+-- id for data types with strict fields fully optimizes up to 12x1
+x12'_id :: X12' -> X12'
+x12'_id = to . from
+
+x12'_lens :: Lens' X12' Integer
+x12'_lens = gfield @"x12'_f1"
+
+-- X16
+
+instance NFData X16
+
+x16_id :: X16 -> X16
+x16_id = to . from
+
+x16_lens :: Lens' X16 Integer
+x16_lens = gfield @"x16_f1"
+
+-- X16'
+
+instance NFData X16'
+
+x16'_lens :: Lens' X16' Integer
+x16'_lens = gfield @"x16'_f1"
+
+-- X24
+
+instance NFData X24
+
+x24_id :: X24 -> X24
+x24_id = to . from
diff --git a/testsuite/tests/perf/compiler/T11068a.hs b/testsuite/tests/perf/compiler/T11068a.hs
new file mode 100644
index 0000000000..1faa835044
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T11068a.hs
@@ -0,0 +1,394 @@
+{-# LANGUAGE DeriveGeneric #-}
+module T11068a where
+
+import GHC.Generics
+
+data X1
+ = X11 { x1_f1 :: Integer
+ , x1_f2 :: Integer
+ , x1_f3 :: Integer
+ , x1_f4 :: Integer
+ , x1_f5 :: Integer
+ , x1_f6 :: Integer
+ , x1_f7 :: Integer
+ , x1_f8 :: Integer
+ , x1_f9 :: Integer
+ , x1_f10 :: Integer
+ , x1_f11 :: Integer
+ , x1_f12 :: Integer
+ , x1_f13 :: Integer
+ , x1_f14 :: Integer
+ , x1_f15 :: Integer
+ , x1_f16 :: Integer
+ , x1_f17 :: Integer
+ , x1_f18 :: Integer
+ , x1_f19 :: Integer
+ , x1_f20 :: Integer
+ , x1_f21 :: Integer
+ , x1_f22 :: Integer
+ , x1_f23 :: Integer
+ , x1_f24 :: Integer
+ , x1_f25 :: Integer
+ , x1_f26 :: Integer
+ , x1_f27 :: Integer
+ , x1_f28 :: Integer
+ , x1_f29 :: Integer
+ , x1_f30 :: Integer
+ , x1_f31 :: Integer
+ , x1_f32 :: Integer
+ , x1_f33 :: Integer
+ , x1_f34 :: Integer
+ , x1_f35 :: Integer
+ , x1_f36 :: Integer
+ , x1_f37 :: Integer
+ , x1_f38 :: Integer
+ , x1_f39 :: Integer
+ , x1_f40 :: Integer
+ , x1_f41 :: Integer
+ , x1_f42 :: Integer
+ , x1_f43 :: Integer
+ , x1_f44 :: Integer
+ , x1_f45 :: Integer
+ , x1_f46 :: Integer
+ , x1_f47 :: Integer
+ , x1_f48 :: Integer
+ , x1_f49 :: Integer
+ , x1_f50 :: Integer
+ , x1_f51 :: Integer
+ , x1_f52 :: Integer
+ , x1_f53 :: Integer
+ , x1_f54 :: Integer
+ , x1_f55 :: Integer
+ , x1_f56 :: Integer
+ , x1_f57 :: Integer
+ , x1_f58 :: Integer
+ , x1_f59 :: Integer
+ , x1_f60 :: Integer
+ , x1_f61 :: Integer
+ , x1_f62 :: Integer
+ , x1_f63 :: Integer
+ , x1_f64 :: Integer
+ , x1_f65 :: Integer
+ , x1_f66 :: Integer
+ , x1_f67 :: Integer
+ , x1_f68 :: Integer
+ , x1_f69 :: Integer
+ , x1_f70 :: Integer
+ , x1_f71 :: Integer
+ , x1_f72 :: Integer
+ , x1_f73 :: Integer
+ , x1_f74 :: Integer
+ , x1_f75 :: Integer
+ , x1_f76 :: Integer
+ , x1_f77 :: Integer
+ , x1_f78 :: Integer
+ , x1_f79 :: Integer
+ , x1_f80 :: Integer
+ , x1_f81 :: Integer
+ , x1_f82 :: Integer
+ , x1_f83 :: Integer
+ , x1_f84 :: Integer
+ , x1_f85 :: Integer
+ , x1_f86 :: Integer
+ , x1_f87 :: Integer
+ , x1_f88 :: Integer
+ , x1_f89 :: Integer
+ , x1_f90 :: Integer
+ , x1_f91 :: Integer
+ , x1_f92 :: Integer
+ , x1_f93 :: Integer
+ , x1_f94 :: Integer
+ , x1_f95 :: Integer
+ , x1_f96 :: Integer
+ , x1_f97 :: Integer
+ , x1_f98 :: Integer
+ , x1_f99 :: Integer
+ , x1_f100 :: Integer
+ } deriving Generic
+
+data X1'
+ = X1'1 { x1'_f1 :: !Integer
+ , x1'_f2 :: !Integer
+ , x1'_f3 :: !Integer
+ , x1'_f4 :: !Integer
+ , x1'_f5 :: !Integer
+ , x1'_f6 :: !Integer
+ , x1'_f7 :: !Integer
+ , x1'_f8 :: !Integer
+ , x1'_f9 :: !Integer
+ , x1'_f10 :: !Integer
+ , x1'_f11 :: !Integer
+ , x1'_f12 :: !Integer
+ , x1'_f13 :: !Integer
+ , x1'_f14 :: !Integer
+ , x1'_f15 :: !Integer
+ , x1'_f16 :: !Integer
+ , x1'_f17 :: !Integer
+ , x1'_f18 :: !Integer
+ , x1'_f19 :: !Integer
+ , x1'_f20 :: !Integer
+ , x1'_f21 :: !Integer
+ , x1'_f22 :: !Integer
+ , x1'_f23 :: !Integer
+ , x1'_f24 :: !Integer
+ , x1'_f25 :: !Integer
+ , x1'_f26 :: !Integer
+ , x1'_f27 :: !Integer
+ , x1'_f28 :: !Integer
+ , x1'_f29 :: !Integer
+ , x1'_f30 :: !Integer
+ , x1'_f31 :: !Integer
+ , x1'_f32 :: !Integer
+ , x1'_f33 :: !Integer
+ , x1'_f34 :: !Integer
+ , x1'_f35 :: !Integer
+ , x1'_f36 :: !Integer
+ , x1'_f37 :: !Integer
+ , x1'_f38 :: !Integer
+ , x1'_f39 :: !Integer
+ , x1'_f40 :: !Integer
+ , x1'_f41 :: !Integer
+ , x1'_f42 :: !Integer
+ , x1'_f43 :: !Integer
+ , x1'_f44 :: !Integer
+ , x1'_f45 :: !Integer
+ , x1'_f46 :: !Integer
+ , x1'_f47 :: !Integer
+ , x1'_f48 :: !Integer
+ , x1'_f49 :: !Integer
+ , x1'_f50 :: !Integer
+ , x1'_f51 :: !Integer
+ , x1'_f52 :: !Integer
+ , x1'_f53 :: !Integer
+ , x1'_f54 :: !Integer
+ , x1'_f55 :: !Integer
+ , x1'_f56 :: !Integer
+ , x1'_f57 :: !Integer
+ , x1'_f58 :: !Integer
+ , x1'_f59 :: !Integer
+ , x1'_f60 :: !Integer
+ , x1'_f61 :: !Integer
+ , x1'_f62 :: !Integer
+ , x1'_f63 :: !Integer
+ , x1'_f64 :: !Integer
+ , x1'_f65 :: !Integer
+ , x1'_f66 :: !Integer
+ , x1'_f67 :: !Integer
+ , x1'_f68 :: !Integer
+ , x1'_f69 :: !Integer
+ , x1'_f70 :: !Integer
+ , x1'_f71 :: !Integer
+ , x1'_f72 :: !Integer
+ , x1'_f73 :: !Integer
+ , x1'_f74 :: !Integer
+ , x1'_f75 :: !Integer
+ , x1'_f76 :: !Integer
+ , x1'_f77 :: !Integer
+ , x1'_f78 :: !Integer
+ , x1'_f79 :: !Integer
+ , x1'_f80 :: !Integer
+ , x1'_f81 :: !Integer
+ , x1'_f82 :: !Integer
+ , x1'_f83 :: !Integer
+ , x1'_f84 :: !Integer
+ , x1'_f85 :: !Integer
+ , x1'_f86 :: !Integer
+ , x1'_f87 :: !Integer
+ , x1'_f88 :: !Integer
+ , x1'_f89 :: !Integer
+ , x1'_f90 :: !Integer
+ , x1'_f91 :: !Integer
+ , x1'_f92 :: !Integer
+ , x1'_f93 :: !Integer
+ , x1'_f94 :: !Integer
+ , x1'_f95 :: !Integer
+ , x1'_f96 :: !Integer
+ , x1'_f97 :: !Integer
+ , x1'_f98 :: !Integer
+ , x1'_f99 :: !Integer
+ , x1'_f100 :: !Integer
+ } deriving Generic
+
+data X4
+ = X41 { x4_f1 :: Integer
+ , x4_f2 :: Integer
+ , x4_f3 :: Integer
+ , x4_f4 :: Integer
+ , x4_f5 :: Integer
+ }
+ | X42 { x4_f1 :: Integer
+ , x4_f2 :: Integer
+ , x4_f3 :: Integer
+ , x4_f4 :: Integer
+ , x4_f5 :: Integer
+ }
+ | X43 { x4_f1 :: Integer
+ , x4_f2 :: Integer
+ , x4_f3 :: Integer
+ , x4_f4 :: Integer
+ , x4_f5 :: Integer
+ }
+ | X44 { x4_f1 :: Integer
+ , x4_f2 :: Integer
+ , x4_f3 :: Integer
+ , x4_f4 :: Integer
+ , x4_f5 :: Integer
+ } deriving Generic
+
+data X4'
+ = X4'1 { x4'_f1 :: !Integer
+ , x4'_f2 :: !Integer
+ , x4'_f3 :: !Integer
+ , x4'_f4 :: !Integer
+ , x4'_f5 :: !Integer
+ }
+ | X4'2 { x4'_f1 :: !Integer
+ , x4'_f2 :: !Integer
+ , x4'_f3 :: !Integer
+ , x4'_f4 :: !Integer
+ , x4'_f5 :: !Integer
+ }
+ | X4'3 { x4'_f1 :: !Integer
+ , x4'_f2 :: !Integer
+ , x4'_f3 :: !Integer
+ , x4'_f4 :: !Integer
+ , x4'_f5 :: !Integer
+ }
+ | X4'4 { x4'_f1 :: !Integer
+ , x4'_f2 :: !Integer
+ , x4'_f3 :: !Integer
+ , x4'_f4 :: !Integer
+ , x4'_f5 :: !Integer
+ } deriving Generic
+
+data X8
+ = X81 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X82 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X83 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X84 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X85 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X86 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X87 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ }
+ | X88 { x8_f1 :: Integer
+ , x8_f2 :: Integer
+ } deriving Generic
+
+data X8'
+ = X8'1 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'2 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'3 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'4 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'5 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'6 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'7 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ }
+ | X8'8 { x8'_f1 :: !Integer
+ , x8'_f2 :: !Integer
+ } deriving Generic
+
+data X12'
+ = X12'1 { x12'_f1 :: !Integer }
+ | X12'2 { x12'_f1 :: !Integer }
+ | X12'3 { x12'_f1 :: !Integer }
+ | X12'4 { x12'_f1 :: !Integer }
+ | X12'5 { x12'_f1 :: !Integer }
+ | X12'6 { x12'_f1 :: !Integer }
+ | X12'7 { x12'_f1 :: !Integer }
+ | X12'8 { x12'_f1 :: !Integer }
+ | X12'9 { x12'_f1 :: !Integer }
+ | X12'10 { x12'_f1 :: !Integer }
+ | X12'11 { x12'_f1 :: !Integer }
+ | X12'12 { x12'_f1 :: !Integer }
+ deriving Generic
+
+data X16
+ = X161 { x16_f1 :: Integer }
+ | X162 { x16_f1 :: Integer }
+ | X163 { x16_f1 :: Integer }
+ | X164 { x16_f1 :: Integer }
+ | X165 { x16_f1 :: Integer }
+ | X166 { x16_f1 :: Integer }
+ | X167 { x16_f1 :: Integer }
+ | X168 { x16_f1 :: Integer }
+ | X169 { x16_f1 :: Integer }
+ | X1610 { x16_f1 :: Integer }
+ | X1611 { x16_f1 :: Integer }
+ | X1612 { x16_f1 :: Integer }
+ | X1613 { x16_f1 :: Integer }
+ | X1614 { x16_f1 :: Integer }
+ | X1615 { x16_f1 :: Integer }
+ | X1616 { x16_f1 :: Integer }
+ deriving Generic
+
+data X16'
+ = X16'1 { x16'_f1 :: !Integer }
+ | X16'2 { x16'_f1 :: !Integer }
+ | X16'3 { x16'_f1 :: !Integer }
+ | X16'4 { x16'_f1 :: !Integer }
+ | X16'5 { x16'_f1 :: !Integer }
+ | X16'6 { x16'_f1 :: !Integer }
+ | X16'7 { x16'_f1 :: !Integer }
+ | X16'8 { x16'_f1 :: !Integer }
+ | X16'9 { x16'_f1 :: !Integer }
+ | X16'10 { x16'_f1 :: !Integer }
+ | X16'11 { x16'_f1 :: !Integer }
+ | X16'12 { x16'_f1 :: !Integer }
+ | X16'13 { x16'_f1 :: !Integer }
+ | X16'14 { x16'_f1 :: !Integer }
+ | X16'15 { x16'_f1 :: !Integer }
+ | X16'16 { x16'_f1 :: !Integer }
+ deriving Generic
+
+data X24
+ = X241
+ | X242
+ | X243
+ | X244
+ | X245
+ | X246
+ | X247
+ | X248
+ | X249
+ | X2410
+ | X2411
+ | X2412
+ | X2413
+ | X2414
+ | X2415
+ | X2416
+ | X2417
+ | X2418
+ | X2419
+ | X2420
+ | X2421
+ | X2422
+ | X2423
+ | X2424
+ deriving Generic
diff --git a/testsuite/tests/perf/compiler/T11068b.hs b/testsuite/tests/perf/compiler/T11068b.hs
new file mode 100644
index 0000000000..eab7b8cfe5
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T11068b.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T11068b (Lens', GField(..)) where
+
+import Data.Kind
+import Data.Type.Bool
+import Data.Type.Equality
+import GHC.Generics
+import GHC.TypeLits
+
+-- Code taken from the optics / generic-lens-lite library.
+
+----------------------------------------
+-- Profunctors
+
+data Context a b t = Context (b -> t) a
+ deriving Functor
+
+class Profunctor p where
+ dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
+ lmap :: (a -> b) -> p b c -> p a c
+ rmap :: (c -> d) -> p b c -> p b d
+
+class Profunctor p => Strong p where
+ first' :: p a b -> p (a, c) (b, c)
+ second' :: p a b -> p (c, a) (c, b)
+
+ linear :: LensVL s t a b -> p a b -> p s t
+ linear f = dimap
+ ((\(Context bt a) -> (a, bt)) . f (Context id))
+ (\(b, bt) -> bt b)
+ . first'
+ {-# INLINE linear #-}
+
+data Store a b s t = Store (s -> a) (s -> b -> t)
+
+instance Profunctor (Store a b) where
+ dimap f g (Store get set) = Store (get . f) (\s -> g . set (f s))
+ lmap f (Store get set) = Store (get . f) (\s -> set (f s))
+ rmap g (Store get set) = Store get (\s -> g . set s)
+
+instance Strong (Store a b) where
+ first' (Store get set) = Store (get . fst) (\(s, c) b -> (set s b, c))
+ second' (Store get set) = Store (get . snd) (\(c, s) b -> (c, set s b))
+
+----------------------------------------
+-- Lens
+
+type LensVL s t a b = forall f. Functor f => (a -> f b) -> s -> f t
+type LensVL' s a = LensVL s s a a
+
+newtype Lens s t a b = Lens (forall p. Strong p => p a b -> p s t)
+type Lens' s a = Lens s s a a
+
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+lens get set = Lens $ dimap (\s -> (get s, s))
+ (\(b, s) -> set s b)
+ . first'
+
+lensVL :: LensVL s t a b -> Lens s t a b
+lensVL l = Lens (linear l)
+
+withLens :: Lens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r
+withLens (Lens l) k = case l $ Store id (\_ -> id) of
+ Store get set -> k get set
+
+----------------------------------------
+-- Field
+
+class GField (name :: Symbol) s a | name s -> a where
+ gfield :: Lens' s a
+
+instance
+ ( Generic s
+ , path ~ GetPathTree name (Rep s)
+ , GFieldSum name s path (Rep s) a
+ ) => GField name s a where
+ gfield = withLens
+ (lensVL (\f s -> to <$> gfieldSum @name @s @path f (from s)))
+ (\get set -> lensVL $ \f s -> set s <$> f (get s))
+ {-# INLINE gfield #-}
+
+data Void0
+-- | Hidden instance.
+instance a ~ Void0 => GField name Void0 a where
+ gfield = lensVL id
+
+class GFieldSum (name :: Symbol) s (path :: PathTree) (g :: Type -> Type) a
+ | name g -> a where
+ gfieldSum :: LensVL' (g x) a
+
+instance
+ ( GFieldSum name s path V1 a
+ , TypeError ('Text "Type " ':<>: Quoted ('ShowType s) ':<>:
+ 'Text " has no data constructors")
+ ) => GFieldSum name s path V1 a where
+ gfieldSum = error "unreachable"
+
+instance
+ ( GFieldSum name s path g a
+ ) => GFieldSum name s path (M1 D m g) a where
+ gfieldSum f (M1 x) = M1 <$> gfieldSum @name @s @path f x
+
+instance
+ ( GFieldSum name s path1 g1 a
+ , GFieldSum name s path2 g2 a
+ ) => GFieldSum name s ('PathTree path1 path2) (g1 :+: g2) a where
+ gfieldSum f (L1 x) = L1 <$> gfieldSum @name @s @path1 f x
+ gfieldSum f (R1 y) = R1 <$> gfieldSum @name @s @path2 f y
+ {-# INLINE gfieldSum #-}
+
+instance
+ ( path ~ FromMaybe
+ (TypeError
+ ('Text "Type " ':<>: Quoted ('ShowType s) ':<>:
+ 'Text " doesn't have a field named " ':<>: Quoted ('Text name)))
+ mpath
+ , GFieldProd name s path g a
+ ) => GFieldSum name s ('PathLeaf mpath) (M1 C m g) a where
+ gfieldSum f (M1 x) = M1 <$> gfieldProd @name @s @path f x
+
+class GFieldProd (name :: Symbol) s (path :: [Path]) g a | name g -> a where
+ gfieldProd :: LensVL' (g x) a
+
+instance
+ ( GFieldProd name s path g1 a
+ ) => GFieldProd name s ('PathLeft : path) (g1 :*: g2) a where
+ gfieldProd f (x :*: y) = (:*: y) <$> gfieldProd @name @s @path f x
+
+instance
+ ( GFieldProd name s path g2 a
+ ) => GFieldProd name s ('PathRight : path) (g1 :*: g2) a where
+ gfieldProd f (x :*: y) = (x :*:) <$> gfieldProd @name @s @path f y
+
+instance
+ ( a ~ b -- for better error message if types don't match
+ ) => GFieldProd name s '[] (M1 S ('MetaSel ('Just name) su ss ds) (Rec0 b)) a where
+ gfieldProd f (M1 (K1 x)) = M1 . K1 <$> f x
+
+----------------------------------------
+-- Helpers
+
+type family Quoted (s :: ErrorMessage) :: ErrorMessage where
+ Quoted s = 'Text "‘" ':<>: s ':<>: 'Text "’"
+
+data PathTree
+ = PathTree PathTree PathTree
+ | PathLeaf (Maybe [Path])
+ | NoPath
+
+data Path = PathLeft | PathRight
+
+-- | Compute paths to a field for a generic representation of a data type.
+type family GetPathTree (name :: Symbol) g :: PathTree where
+ GetPathTree name (M1 D _ g) = GetPathTree name g
+ GetPathTree name V1 = 'NoPath
+ GetPathTree name (g1 :+: g2) = 'PathTree (GetPathTree name g1)
+ (GetPathTree name g2)
+ GetPathTree name (M1 C _ g) = 'PathLeaf (GetPath name g '[])
+
+-- | Compute path to a constructor in a sum or a field in a product.
+type family GetPath (name :: Symbol) g (acc :: [Path]) :: Maybe [Path] where
+ GetPath name (M1 D _ g) acc = GetPath name g acc
+
+ -- Find path to a constructor in a sum type
+ GetPath name (M1 C ('MetaCons name _ _) _) acc = 'Just (Reverse acc '[])
+ GetPath name (g1 :+: g2) acc = Alt (GetPath name g1 ('PathLeft : acc))
+ (GetPath name g2 ('PathRight : acc))
+
+ -- Find path to a field in a product type
+ GetPath name (M1 S ('MetaSel ('Just name) _ _ _) _) acc = 'Just (Reverse acc '[])
+ GetPath name (g1 :*: g2) acc = Alt (GetPath name g1 ('PathLeft : acc))
+ (GetPath name g2 ('PathRight : acc))
+
+ GetPath _ _ _ = 'Nothing
+
+-- | Reverse a type-level list.
+type family Reverse (xs :: [k]) (acc :: [k]) :: [k] where
+ Reverse '[] acc = acc
+ Reverse (x : xs) acc = Reverse xs (x : acc)
+
+type family FromMaybe (def :: a) (m :: Maybe a) :: a where
+ FromMaybe _ ('Just a) = a
+ FromMaybe def 'Nothing = def
+
+-- | Type-level mplus for 'Maybe'.
+type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
+ Alt ('Just a) _ = 'Just a
+ Alt _ b = b
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 87647c69d7..090dbb4acf 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -178,6 +178,8 @@ test('T10370',
compile,
[''])
+test('T11068', normal, makefile_test, ['T11068'])
+
test('T10547',
[ collect_compiler_stats('bytes allocated', 4),
],
View Lorry Controller Status