[commit: ghc] wip/T15578: Add regression test for #15578 (6855d92)

[git at git.haskell.org]

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

On branch  : wip/T15578
Link       : http://ghc.haskell.org/trac/ghc/changeset/6855d926f7ebeaed9fdf16333c9ca5402c490cca/ghc

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

commit 6855d926f7ebeaed9fdf16333c9ca5402c490cca
Author: Tobias Dammers <tdammers at gmail.com>
Date:   Fri Sep 7 20:53:15 2018 +0200

    Add regression test for #15578


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

6855d926f7ebeaed9fdf16333c9ca5402c490cca
 testsuite/tests/perf/should_run/T15578.hs | 80 +++++++++++++++++++++++++++++++
 testsuite/tests/perf/should_run/all.T     |  9 ++++
 2 files changed, 89 insertions(+)

diff --git a/testsuite/tests/perf/should_run/T15578.hs b/testsuite/tests/perf/should_run/T15578.hs
new file mode 100644
index 0000000..be056e2
--- /dev/null
+++ b/testsuite/tests/perf/should_run/T15578.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Strict            #-}
+{-# LANGUAGE BangPatterns      #-}
+{-# LANGUAGE DeriveGeneric     #-}
+
+module Main where
+
+import qualified Data.Set  as Set
+import qualified Data.Text as Text
+
+import Data.Set              (Set)
+import Data.Text             (Text)
+import System.IO             (BufferMode (NoBuffering), hSetBuffering, stdout)
+import GHC.Generics          (Generic)
+import Control.DeepSeq       (force, NFData)
+import Control.Exception     (evaluate)
+
+
+--------------------------------
+-- === Running benchmarks === --
+--------------------------------
+
+iters :: Int
+iters = 100000000
+
+src1 :: Text
+src1 = Text.replicate iters "tttt"
+
+data Grammar a
+    = Tokens !(Set a) !(a -> Bool)
+    | Many   !(Grammar a)
+    | X      !(Grammar a)
+
+instance Ord a => Semigroup (Grammar a) where
+    Tokens s f <> Tokens s' g = Tokens (s <> s') $ \c -> f c || g c
+    {-# INLINE (<>) #-}
+
+token :: Eq a => a -> Grammar a
+token = \a -> Tokens (Set.singleton a) (a ==)
+{-# INLINE token #-}
+
+many :: Grammar a -> Grammar a
+many = Many
+{-# INLINE many #-}
+
+data Result
+    = Success Text Text
+    | Fail
+    deriving (Show, Generic)
+
+instance NFData Result
+
+runTokenParser :: Grammar Char -> Text -> Result
+runTokenParser = \grammar stream -> case grammar of
+    Tokens _ tst -> let
+        head = Text.head stream
+        in if tst head
+            then Success (Text.tail stream) (Text.singleton head)
+            else Fail
+    Many (Tokens _ tst) -> let
+        (!consumed, !rest) = Text.span tst stream
+        in Success rest consumed
+    X !grammar -> runTokenParser grammar stream
+
+testGrammar1 :: Grammar Char
+testGrammar1 = let
+    s1 = token 't'
+    in many s1
+{-# INLINE testGrammar1 #-}
+
+test3 :: Text -> Result
+test3 src =
+  runTokenParser testGrammar1 src
+{-# NOINLINE test3 #-}
+
+main :: IO ()
+main = do
+    srcx <- evaluate $ force src1
+    evaluate $ force $ test3 srcx
+    pure ()
diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T
index 6a7bcf0..1a85e70 100644
--- a/testsuite/tests/perf/should_run/all.T
+++ b/testsuite/tests/perf/should_run/all.T
@@ -604,3 +604,12 @@ test('T15426',
      only_ways(['normal'])],
     compile_and_run,
     ['-O2'])
+
+test('T15578',
+    [stats_num_field('bytes allocated',
+                    [ (wordsize(64), 800041456, 5) ]),
+                    # 2018-09-07     800041456   Improvements from #15578
+                    # initial      42400041456
+     only_ways(['normal'])],
+    compile_and_run,
+    ['-O2'])