[commit: ghc] master: Add T9630 (23f47b1)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/23f47b15bd45ead7ba50dce276162bb019822e7c/ghc

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

commit 23f47b15bd45ead7ba50dce276162bb019822e7c
Author: David Feuer <david.feuer at gmail.com>
Date:   Sun Jun 18 16:49:14 2017 -0400

    Add T9630
    
    This is not the most precise test, unfortunately, but it does
    demonstrate a modest improvement in compiler residency as a
    result of the specializer don't-loop patch. A rather less
    realistic variation on this has somewhat more dramatic effects.
    
    Reviewers: austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie
    
    Differential Revision: https://phabricator.haskell.org/D3656


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

23f47b15bd45ead7ba50dce276162bb019822e7c
 testsuite/tests/perf/compiler/T9630.hs  |  21 +++++++
 testsuite/tests/perf/compiler/T9630a.hs | 100 ++++++++++++++++++++++++++++++++
 testsuite/tests/perf/compiler/all.T     |  11 ++++
 3 files changed, 132 insertions(+)

diff --git a/testsuite/tests/perf/compiler/T9630.hs b/testsuite/tests/perf/compiler/T9630.hs
new file mode 100644
index 0000000..e0bcec2
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T9630.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DeriveGeneric #-}
+module T9630 where
+import T9630a
+import GHC.Generics
+import Control.Applicative
+
+data T = T () () () ()
+          ()()()()()()()
+          ()()()()()()()()()()()()()()()()
+          ()()()()()()()()()()()()()()()()
+          ()()()()()()()()()()()()()()()()
+          ()()()()()()()()()()()()()()()()
+          ()()()()()()()()()()()()()()()()
+          ()()()()()()()()()()()()()()()()
+          ()()()()()()()()()()()()()()()()
+          ()()()()()()()()()()()()()()()()
+  deriving Generic
+
+instance Serialize T where
+  get = to <$> gGet
+  put = gPut . from
diff --git a/testsuite/tests/perf/compiler/T9630a.hs b/testsuite/tests/perf/compiler/T9630a.hs
new file mode 100644
index 0000000..1d879f2
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T9630a.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE RankNTypes #-}
+
+-----------------------------------------------------------------------------
+-- | Modified from cereal, which is
+-- Copyright   : Lennart Kolmodin, Galois Inc. 2009
+-- License     : BSD3-style
+
+module T9630a (
+      Serialize(..), GSerialize (..), Putter, Get
+    ) where
+
+import Data.ByteString.Builder (Builder)
+import Data.ByteString as B
+import GHC.Generics
+import Control.Applicative (Applicative (..), (<$>))
+
+class Serialize t where
+    put :: Putter t
+    get :: Get t
+
+instance Serialize () where
+    put ()  = pure ()
+    get     = pure ()
+
+-- Generics
+
+class GSerialize f where
+    gPut :: Putter (f a)
+    gGet :: Get (f a)
+
+instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
+    gPut (a :*: b) = gPut a *> gPut b
+    gGet = (:*:) <$> gGet  <*> gGet
+
+instance GSerialize a => GSerialize (M1 i c a) where
+    gPut = gPut . unM1
+    gGet = M1 <$> gGet
+
+instance Serialize a => GSerialize (K1 i a) where
+    gPut = put . unK1
+    gGet = K1 <$> get
+
+
+-- Put
+
+data PairS a = PairS a !Builder
+
+newtype PutM a = Put { unPut :: PairS a }
+
+type Put = PutM ()
+
+type Putter a = a -> Put
+
+instance Functor PutM where
+        fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
+
+instance Applicative PutM where
+        pure a = Put (PairS a mempty)
+
+        m <*> k = Put $
+            let PairS f w  = unPut m
+                PairS x w' = unPut k
+            in PairS (f x) (w `mappend` w')
+
+-- Get
+
+data Result r = Fail String B.ByteString
+              | Partial (B.ByteString -> Result r)
+              | Done r B.ByteString
+
+
+newtype Get a = Get
+  { unGet :: forall r. Input -> Buffer -> More
+                    -> Failure r -> Success a r
+                    -> Result r }
+
+type Input  = B.ByteString
+type Buffer = Maybe B.ByteString
+
+type Failure   r = Input -> Buffer -> More -> [String] -> String -> Result r
+type Success a r = Input -> Buffer -> More -> a                  -> Result r
+
+data More
+  = Complete
+  | Incomplete (Maybe Int)
+    deriving (Eq)
+
+
+instance Functor Get where
+    fmap p m =        Get $ \ s0 b0 m0 kf ks ->
+      unGet m s0 b0 m0 kf $ \ s1 b1 m1 a     -> ks s1 b1 m1 (p a)
+
+instance Applicative Get where
+    pure a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a
+
+    f <*> x =         Get $ \ s0 b0 m0 kf ks ->
+      unGet f s0 b0 m0 kf $ \ s1 b1 m1 g     ->
+      unGet x s1 b1 m1 kf $ \ s2 b2 m2 y     -> ks s2 b2 m2 (g y)
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index a55df8e..daf22f6 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -1152,3 +1152,14 @@ test('Naperian',
      ],
      compile,
      [''])
+
+test ('T9630',
+      [ compiler_stats_num_field('max_bytes_used', # Note [residency]
+          [(wordsize(64), 41568168, 15)
+          # initial:    56955240
+          # 2017-06-07: 41568168     Stop the specialiser generating loopy code
+          ]),
+      extra_clean(['T9630a.hi', 'T9630a.o'])
+      ],
+      multimod_compile,
+      ['T9630', '-v0 -O'])