test suite: add reproducer for #17516

3 files changed, 478 insertions, 0 deletions

diff --git a/testsuite/tests/perf/compiler/T17516.hs b/testsuite/tests/perf/compiler/T17516.hs
new file mode 100644
index 0000000000..ae5a4ef6a4
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T17516.hs
@@ -0,0 +1,334 @@
+-- Reduced from Codec.MIME.String.Headers from mime-string-0.5
+module T17516 (get_addr_spec, get_to) where
+
+import Prelude hiding ( (<*>), (<$>), (<*), (<$) )
+import Data.Char
+import Data.List (intersperse)
+
+import T17516A
+
+-----------------------
+-- Utils
+
+ignore :: Parser inp a -> Parser inp ()
+ignore p = () <$  p
+
+boxp :: Parser inp a -> Parser inp [a]
+boxp p = box <$> p
+
+-----------------------
+-- RFC 2234
+
+p_CTL :: Parser Char Char
+p_CTL = pPred (\c -> ord c < 32 || ord c == 127)
+
+p_SP :: Parser Char Char
+p_SP = pChar ' '
+
+p_HTAB :: Parser Char Char
+p_HTAB = pChar '\t'
+
+p_WSP :: Parser Char Char
+p_WSP = p_SP <|> p_HTAB
+
+-----------------------
+-- RFC 2822
+
+p_NO_WS_CTL :: Parser Char Char
+p_NO_WS_CTL = pPred (\c -> let o = ord c in 1 <= o && o <= 8
+                                         || o == 11
+                                         || o == 12
+                                         || 14 <= o && o <= 31
+                                         || o == 127)
+
+-- If we follow the spec precisely then we get pMany (pMany), and hence
+-- non-termination, so we merge the definition of p_obs_text in.
+p_text :: Parser Char String
+p_text = concat
+     <$> pMany (
+                    p_encoded_words
+                <|  boxp (pPred (\c -> let o = ord c in 0 <= o && o <= 9
+                                                     || o == 11
+                                                     || o == 12
+                                                     || 14 <= o && o <= 127))
+               )
+
+-- We are lax about checking they have any necessary surrounding
+-- whitespace
+p_encoded_words :: Parser Char String
+p_encoded_words = (\x xs -> x ++ concat xs)
+              <$> p_encoded_word
+              <*> pMany (id <$  cws <*> p_encoded_word)
+
+-- XXX What happens if iconv doesn't understand the charset "cs"?
+p_encoded_word :: Parser Char String
+p_encoded_word = (\_ dec text -> dec text)
+             <$  pString "=?"
+             <*> p_charset
+             <*  pChar '?'
+             <*> p_encoding
+             <*  pChar '?'
+             <*> p_encoded_text
+             <*  pString "?="
+
+-- token definition inlined as they use a different one to p_token.
+p_charset :: Parser Char String
+p_charset = pAtLeast 1 (pPred isAscii <!> (p_SP <|> p_CTL <|> p_especials))
+
+p_especials :: Parser Char Char
+p_especials = pPred (`elem` "()<>@,;:\\\"/[]?.=")
+
+-- This is much stricter than specified, but if it's not [qQbB] then
+-- we'd want to fall back to showing it as a string anyway.
+p_encoding :: Parser Char (String -> String)
+p_encoding = id <$  (pChar 'Q' <|> pChar 'q')
+         <|> id <$  (pChar 'B' <|> pChar 'b')
+
+p_encoded_text :: Parser Char String
+p_encoded_text = pMany (pPred (\c -> isAsciiPrint c && c /= '?' && c /= ' '))
+
+p_quoted_pair :: Parser Char String
+p_quoted_pair = id <$  pChar '\\' <*> p_text <|> boxp p_obs_qp
+
+p_obs_qp :: Parser Char Char
+p_obs_qp = id <$  pChar '\\' <*> pPred isAscii
+
+-- Done differently as the newlines are already gone
+p_FWS :: Parser Char String
+p_FWS = pMany p_WSP
+
+p_ctext :: Parser Char Char
+p_ctext = p_NO_WS_CTL
+      <|> pPred (\c -> let o = ord c in 33 <= o && o <= 39
+                                     || 42 <= o && o <= 91
+                                     || 93 <= o && o <= 126)
+
+p_ccontent :: Parser Char ()
+p_ccontent = ignore p_ctext <|> ignore p_quoted_pair <|> p_comment
+
+p_comment :: Parser Char ()
+p_comment = ()
+        <$  pChar '('
+        <*  pMany (() <$  pMany p_NO_WS_CTL <*  p_ccontent)
+        <*  pMany p_NO_WS_CTL
+        <*  pChar ')'
+
+-- We might want to keep the result. If we do then we also need to
+-- handle encoded words properly.
+-- This isn't quite CFWS as we need to be able to accept "1.0"
+-- as a MIME version with cws between all the characters.
+-- Also, we've already removed all the newlines in the headers.
+cws :: Parser Char ()
+cws = ignore $ pMany (ignore (pAtLeast 1 p_WSP) <|> p_comment)
+
+p_qtext :: Parser Char Char
+p_qtext = p_NO_WS_CTL
+      <|> pPred (\c -> let o = ord c in o == 33
+                                     || 35 <= o && o <= 91
+                                     || 93 <= o && o <= 126)
+
+p_qcontent :: Parser Char String
+p_qcontent = boxp p_qtext
+         <|> p_quoted_pair
+
+p_quoted_string :: Parser Char String
+p_quoted_string = (++)
+              <$  cws
+              <*  pChar '"'
+              <*> (concat <$> pMany ((++) <$> pOptDef "" p_FWS <*> p_qcontent))
+              <*> pOptDef "" p_FWS
+              <*  pChar '"'
+
+p_dcontent :: Parser Char String
+p_dcontent = boxp p_dtext <|> p_quoted_pair
+
+p_dtext :: Parser Char Char
+p_dtext = p_NO_WS_CTL
+      <|> pPred (\c -> let o = ord c in 33 <= o && o <= 90
+                                     || 94 <= o && o <= 126)
+
+p_atom :: Parser Char String
+p_atom = id
+     <$  cws
+     <*> pAtLeast 1 p_atext
+     <*  cws
+
+p_atext :: Parser Char Char
+p_atext = pPred (\c -> isAsciiAlphaNum c || c `elem` "!#$%&'+-/=?^_`{|}~")
+
+p_dot_atom :: Parser Char String
+p_dot_atom = id
+         <$  cws
+         <*> p_dot_atom_text
+         <*  cws
+
+p_word :: Parser Char String
+p_word = p_atom <|> p_quoted_string
+
+-- This incorporates obs-phrase
+p_phrase :: Parser Char [String]
+p_phrase = (:)
+       <$> (p_encoded_words <|  p_word)
+       <*> pMany (id <$  cws <*> (p_encoded_words <|  p_word <|  pString "."))
+   <|> boxp p_quoted_string
+
+p_dot_atom_text :: Parser Char String
+p_dot_atom_text = (\x xs -> x ++ concat xs)
+              <$> pAtLeast 1 p_atext
+              <*> pMany ((:) <$> pChar '.' <*> pAtLeast 1 p_atext)
+
+p_local_part :: Parser Char String
+p_local_part = p_dot_atom <|> p_quoted_string <|> p_obs_local_part
+
+p_obs_local_part :: Parser Char String
+p_obs_local_part = (\x xs -> x ++ concat xs)
+               <$> p_word
+               <*> pMany ((:) <$> pChar '.' <*> p_word)
+
+p_domain :: Parser Char Domain
+p_domain = Domain <$> p_dot_atom <|> p_domain_literal <|> p_obs_domain
+
+p_domain_literal :: Parser Char Domain
+p_domain_literal = (LiteralDomain . concat)
+               <$  cws
+               <*  pChar '['
+               <*> pMany (    id
+                          <$  p_FWS
+                          <*> p_dcontent)
+               <*  p_FWS
+               <*  pChar ']'
+               <*  cws
+
+p_obs_domain :: Parser Char Domain
+p_obs_domain = (\x xs -> Domain (x ++ concat xs))
+           <$> p_atom
+           <*> pMany ((:) <$> pChar '.' <*> p_atom)
+
+data Domain = Domain String | LiteralDomain String
+    deriving (Show, Read, Eq)
+
+newtype To = To [Address]
+    deriving (Show, Read)
+
+data Address = Address Mailbox
+             | Group String [Mailbox]
+    deriving (Show, Read)
+
+get_to :: String -> Maybe To
+get_to xs
+ = case parse ph_to xs of
+       Left t -> Just t
+       Right _ -> Nothing
+
+ph_to :: Parser Char To
+ph_to = To <$  cws <*> p_address_list <*  cws <*  pEOI
+
+-- obs-addr-list merged in
+p_address_list :: Parser Char [Address]
+p_address_list = (:)
+             <$  pMany (() <$  pChar ',' <*  cws)
+             <*> p_address
+             <*> pMany (    id
+                        <$  pAtLeast 1 (() <$  cws <*  pChar ',')
+                        <*  cws
+                        <*> p_address)
+             <*  pMany (() <$  cws <*  pChar ',')
+
+p_address :: Parser Char Address
+p_address = Address <$> p_mailbox
+        <|> p_group
+
+p_group :: Parser Char Address
+p_group = Group
+      <$> p_display_name
+      <*  cws
+      <*  pChar ':'
+      <*  cws
+      <*> pOptDef [] p_mailbox_list
+      <*  cws
+      <*  pChar ';'
+
+-- obs-mbox-list merged in
+p_mailbox_list :: Parser Char [Mailbox]
+p_mailbox_list = (:)
+             <$  pMany (() <$  pChar ',' <*  cws)
+             <*> p_mailbox
+             <*> pMany (    id
+                        <$  pAtLeast 1 (() <$  cws <*  pChar ',')
+                        <*  cws
+                        <*> p_mailbox)
+             <*  pMany (() <$  cws <*  pChar ',')
+
+data Mailbox = Mailbox (Maybe String) RoutedEmailAddress
+    deriving (Show, Read, Eq)
+
+p_mailbox :: Parser Char Mailbox
+p_mailbox = p_name_addr
+        <|> (Mailbox Nothing . NormalEmailAddress) <$> p_addr_spec
+
+p_name_addr :: Parser Char Mailbox
+p_name_addr = Mailbox
+          <$> pMaybe p_display_name
+          <*  cws
+          <*> p_angle_addr
+
+data EmailAddress = EmailAddress String Domain
+    deriving (Show, Read, Eq)
+
+data RoutedEmailAddress = NormalEmailAddress          EmailAddress
+                        | RoutedEmailAddress [Domain] EmailAddress
+    deriving (Show, Read, Eq)
+
+p_angle_addr :: Parser Char RoutedEmailAddress
+p_angle_addr = ($)
+           <$  pChar '<'
+           <*  cws
+           -- This next makes us also satisfy obs-angle-addr
+           <*> pOptDef NormalEmailAddress
+                       (RoutedEmailAddress <$> p_obs_route <*  cws)
+           <*> p_addr_spec
+           <*  cws
+           <*  pChar '>'
+
+get_addr_spec :: String -> Maybe EmailAddress
+get_addr_spec xs
+ = case parse p_addr_spec xs of
+       Left e -> Just e
+       Right _ -> Nothing
+
+p_addr_spec :: Parser Char EmailAddress
+p_addr_spec  = EmailAddress
+           <$> p_local_part
+           <*  cws
+           <*  pChar '@'
+           <*  cws
+           <*> p_domain
+
+p_display_name :: Parser Char String
+p_display_name = (concat . intersperse " ") <$> p_phrase
+
+p_obs_route :: Parser Char [Domain]
+p_obs_route = id <$> p_obs_domain_list <*  pChar ':'
+
+p_obs_domain_list :: Parser Char [Domain]
+p_obs_domain_list = (:)
+                <$  pChar '@'
+                <*  cws
+                <*> p_domain
+                <*> pMany (    id
+                           <$  pMaybe (() <$  cws <*  pChar ',')
+                           <*  cws
+                           <*  pChar '@'
+                           <*  cws
+                           <*> p_domain)
+
+-- Utils
+
+isAsciiPrint :: Char -> Bool
+isAsciiPrint c = isAscii c && isPrint c
+
+isAsciiAlphaNum :: Char -> Bool
+isAsciiAlphaNum c = isAscii c && isAlphaNum c
+
+box :: a -> [a]
+box x = [x]
diff --git a/testsuite/tests/perf/compiler/T17516A.hs b/testsuite/tests/perf/compiler/T17516A.hs
new file mode 100644
index 0000000000..4713dbf7ed
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T17516A.hs
@@ -0,0 +1,136 @@
+-- Reduced from Codec.MIME.String.Internal.ABNF from mime-string-0.5
+module T17516A
+      (Parser, parse,
+       pPred, pSucceed, pEOI, (<*>), (<|>), (<| ), (<!>),
+       pChar, pString, (<$>), (<$ ), (<* ),
+       pMany, pAtLeast, pOptDef, pMaybe
+      ) where
+
+import Prelude hiding ( (<*>), (<$>), (<*), (<$) )
+
+newtype Parser inp res = Parser ([(inp, Pos)] -> ParseResult inp res)
+
+data ParseResult inp res = Success res [(inp, Pos)] !Pos
+                         | Fail !Pos
+
+type Line = Integer
+type Column = Integer
+data Pos = Pos !Line !Column
+         | EOI
+    deriving (Eq, Ord)
+
+get_pos :: [(a, Pos)] -> Pos
+get_pos [] = EOI
+get_pos ((_, p):_) = p
+
+show_pos :: Pos -> String
+show_pos EOI = "End of input"
+show_pos (Pos l c) = "Line " ++ show l ++ ", column " ++ show c
+
+infixl 6 <$>, <$, <*>, <*
+infixr 3 <|>, <|
+
+posify :: String -> [(Char, Pos)]
+posify = f 1 1
+    where f _ _ []        = []
+          f l c ('\n':xs) = ('\n', Pos l c):f (l+1) 1     xs
+          f l c (x   :xs) = (x,    Pos l c):f l     (c+1) xs
+
+parse :: Parser Char a -> String -> Either a String
+parse (Parser p) xs
+ = case p $ posify xs of
+       Success res [] _ -> Left res
+       Success _ ((_, pos):_) _ ->
+           Right ("Error: Only consumed up to " ++ show_pos pos)
+       Fail pos ->
+           Right ("Error: Failed at " ++ show_pos pos)
+
+-- Primitive combinators
+
+pPred :: (inp -> Bool) -> Parser inp inp
+pPred p = Parser
+        $ \inp -> case inp of
+                      ((x, pos):inp')
+                       | p x -> Success x inp' pos
+                      _ -> Fail (get_pos inp)
+
+pSucceed :: res -> Parser a res
+pSucceed x = Parser $ \inp -> Success x inp (get_pos inp)
+
+pEOI :: Parser a ()
+pEOI = Parser $ \inp -> case inp of
+                            [] -> Success () [] EOI
+                            _ -> Fail (get_pos inp)
+
+(<*>) :: Parser inp (a -> b) -> Parser inp a -> Parser inp b
+Parser p <*> Parser q = Parser $ \inp ->
+                        case p inp of
+                            Fail pos -> Fail pos
+                            Success f inp' pos ->
+                                case q inp' of
+                                    Fail pos' -> Fail (pos `max` pos')
+                                    Success x inp'' pos' ->
+                                        Success (f x) inp'' (pos `max` pos')
+
+(<|>) :: Parser inp a -> Parser inp a -> Parser inp a
+Parser p <|> Parser q = Parser $ \inp ->
+                        case (p inp, q inp) of
+                            (Fail posp, Fail posq) -> Fail (posp `max` posq)
+                            (Fail posp, Success x inp' posq) ->
+                                Success x inp' (posp `max` posq)
+                            (Success x inp' posp, Fail posq) ->
+                                Success x inp' (posp `max` posq)
+                            (rp@(Success _ _ posp), rq@(Success _ _ posq))
+                                -> if posp >= posq then rp else rq
+
+(<| ) :: Parser inp a -> Parser inp a -> Parser inp a
+Parser p <|  Parser q = Parser $ \inp ->
+                        case p inp of
+                            Fail posp ->
+                                case q inp of
+                                    Fail posq -> Fail (posp `max` posq)
+                                    Success x inp' posq ->
+                                        Success x inp' (posp `max` posq)
+                            s -> s
+
+(<!>) :: Parser inp a -> Parser inp b -> Parser inp a
+Parser p <!> Parser q = Parser $ \inp -> case q inp of
+                                             Fail _ ->
+                                                 p inp
+                                             Success _ _ pos -> Fail pos
+
+check_fails_empty :: Parser inp a -> ()
+check_fails_empty (Parser p) = case p [] of
+                                   Fail _ -> ()
+                                   _ -> error "check_fails_empty failed"
+
+-- Derived combinators
+
+pChar :: Char -> Parser Char Char
+pChar c = pPred (c ==)
+
+pString :: String -> Parser Char String
+pString "" = pSucceed ""
+pString (c:cs) = (:) <$> pChar c <*> pString cs
+
+(<$>) :: (a -> b) -> Parser inp a -> Parser inp b
+x <$> q = pSucceed x <*> q
+
+(<$ ) :: a -> Parser inp b -> Parser inp a
+x <$  q = pSucceed x <*  q
+
+(<* ) :: Parser inp a -> Parser inp b -> Parser inp a
+p <*  q = (\x _ -> x) <$> p <*> q
+
+pMany :: Parser inp a -> Parser inp [a]
+pMany p = check_fails_empty p `seq` ((:) <$> p <*> pMany p) <|  pSucceed []
+
+pAtLeast :: Word -> Parser inp a -> Parser inp [a]
+pAtLeast 0 p = pMany p
+pAtLeast n p = (:) <$> p <*> pAtLeast (n-1) p
+
+pOptDef :: a -> Parser inp a -> Parser inp a
+pOptDef x p = p <|  pSucceed x
+
+pMaybe :: Parser inp a -> Parser inp (Maybe a)
+pMaybe p = Just <$> p <|  pSucceed Nothing
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 658cec6270..41928d2cb3 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -364,6 +364,14 @@ test('T16190',
 
 test('T16473', normal, makefile_test, ['T16473'])
 
+test('T17516',
+      [ collect_compiler_stats(),
+        extra_clean(['T17516A.hi', 'T17516A.o'])
+      ],
+      multimod_compile,
+      ['T17516', '-O -v0'])
+
+
 test ('T18304',
       [ collect_compiler_stats('bytes allocated',2)
       ],