Derive <$

Using the default definition of `<$` for derived `Functor`
instance is very bad for recursive data types. Derive
the definition instead.

Fixes #13218

Reviewers: austin, bgamari, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: RyanGlScott, thomie

Differential Revision: https://phabricator.haskell.org/D3072

4 files changed, 43 insertions, 12 deletions

diff --git a/testsuite/tests/generics/GenDerivOutput.stderr b/testsuite/tests/generics/GenDerivOutput.stderr
index 3e1f175178..d531e914f4 100644
--- a/testsuite/tests/generics/GenDerivOutput.stderr
+++ b/testsuite/tests/generics/GenDerivOutput.stderr
@@ -46,6 +46,9 @@ Derived class instances:
     GHC.Base.fmap f GenDerivOutput.Nil = GenDerivOutput.Nil
     GHC.Base.fmap f (GenDerivOutput.Cons a1 a2)
       = GenDerivOutput.Cons (f a1) (GHC.Base.fmap f a2)
+    (GHC.Base.<$) z GenDerivOutput.Nil = GenDerivOutput.Nil
+    (GHC.Base.<$) z (GenDerivOutput.Cons a1 a2)
+      = GenDerivOutput.Cons ((\ b1 -> z) a1) ((GHC.Base.<$) z a2)
   
   instance GHC.Generics.Generic (GenDerivOutput.Rose a) where
     GHC.Generics.from x
@@ -224,9 +227,3 @@ Derived type family instances:
                                                                                                              GenDerivOutput.Rose)))
 
 
-
-==================== Filling in method body ====================
-GHC.Base.Functor [GenDerivOutput.List]
-  GHC.Base.<$ = GHC.Base.$dm<$ @GenDerivOutput.List
-
-
diff --git a/testsuite/tests/generics/T10604/T10604_deriving.stderr b/testsuite/tests/generics/T10604/T10604_deriving.stderr
index 6898af06a8..6862ff5adc 100644
--- a/testsuite/tests/generics/T10604/T10604_deriving.stderr
+++ b/testsuite/tests/generics/T10604/T10604_deriving.stderr
@@ -24,6 +24,7 @@ Derived class instances:
   
   instance GHC.Base.Functor (T10604_deriving.Proxy *) where
     GHC.Base.fmap f T10604_deriving.Proxy = T10604_deriving.Proxy
+    (GHC.Base.<$) z T10604_deriving.Proxy = T10604_deriving.Proxy
   
   instance forall k (a :: k).
            GHC.Generics.Generic (T10604_deriving.Proxy k a) where
@@ -541,9 +542,3 @@ Derived type family instances:
                                                                    * GHC.Types.Int))))
 
 
-
-==================== Filling in method body ====================
-GHC.Base.Functor [T10604_deriving.Proxy *]
-  GHC.Base.<$ = GHC.Base.$dm<$ @T10604_deriving.Proxy *
-
-
diff --git a/testsuite/tests/perf/should_run/T13218.hs b/testsuite/tests/perf/should_run/T13218.hs
new file mode 100644
index 0000000000..c01d3f1ef4
--- /dev/null
+++ b/testsuite/tests/perf/should_run/T13218.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE DeriveTraversable #-}
+
+import Data.Monoid (Endo (..))
+import Control.Exception (evaluate)
+
+data Tree a = Bin !(Tree a) a !(Tree a) | Tip
+  deriving (Functor, Foldable)
+
+t1, t2, t3, t4, t5 :: Tree ()
+t1 = Bin Tip () Tip
+t2 = Bin t1 () t1
+t3 = Bin t2 () t2
+t4 = Bin t3 () t3
+t5 = Bin t4 () t4
+t6 = Bin t5 () t5
+t7 = Bin t6 () t6
+
+replaceManyTimes :: Functor f => f a -> f Int
+replaceManyTimes xs = appEndo
+  (foldMap (\x -> Endo (x <$)) [1..20000])
+  (0 <$ xs)
+
+main :: IO ()
+main = do
+  evaluate $ sum $ replaceManyTimes t7
+  pure ()
diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T
index c0cab8e146..4bd75f70de 100644
--- a/testsuite/tests/perf/should_run/all.T
+++ b/testsuite/tests/perf/should_run/all.T
@@ -490,3 +490,16 @@ test('T12990',
      only_ways(['normal'])],
     compile_and_run,
     ['-O2'])
+
+test('T13218',
+    [stats_num_field('bytes allocated',
+                     [ (wordsize(64), 82040056, 5) ]),
+                     # 8.1 with default <$  163644216
+                     # 8.1 with derived <$   82040056
+     stats_num_field('max_bytes_used',
+                     [ (wordsize(64), 359128, 10) ]),
+                     # 8.1 with default <$  64408248
+                     # 8.1 with derived <$    359128
+     only_ways(['normal'])],
+    compile_and_run,
+    ['-O'])