Add regression test for #15578wip/T15578

2 files changed, 89 insertions, 0 deletions

diff --git a/testsuite/tests/perf/should_run/T15578.hs b/testsuite/tests/perf/should_run/T15578.hs
new file mode 100644
index 0000000000..be056e222b
--- /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 6a7bcf0040..1a85e7073d 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'])