Commit ce416997 authored by Alexis King's avatar Alexis King Committed by Herbert Valerio Riedel

Add INLINABLE pragmas to most overloaded combinators

This adds INLINABLE pragmas to most exported combinators, which enables
cross-module specialization of the Stream constraint (which can in turn
enable further optimizations). This improves performance of these
combinators in scenarios where GHC chooses not to inline them, since
they may still be specialized instead.

This change is primarily in response to a performance regression
discovered by the GHC performance test suite when running haddock (since
haddock uses parsec). The full discussion is available here:

    ghc/ghc!3041

The gist is that, without these pragmas, performance relies too heavily
on inlining heuristics working out in our favor, and subtle changes in
the optimizer can cause regressions.

The GHC performance tests suggest this patch reliably reduces runtime of
haddock on base by 7–9% and allocation by 3–5%. Pretty good for doing
something so simple!
parent 6bcde810
......@@ -30,6 +30,7 @@ import Control.Applicative ((*>))
-- > vowel = oneOf "aeiou"
oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
{-# INLINABLE oneOf #-}
oneOf cs = satisfy (\c -> elem c cs)
-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current
......@@ -39,28 +40,33 @@ oneOf cs = satisfy (\c -> elem c cs)
-- > consonant = noneOf "aeiou"
noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
{-# INLINABLE noneOf #-}
noneOf cs = satisfy (\c -> not (elem c cs))
-- | Skips /zero/ or more white space characters. See also 'skipMany'.
spaces :: (Stream s m Char) => ParsecT s u m ()
{-# INLINABLE spaces #-}
spaces = skipMany space <?> "white space"
-- | Parses a white space character (any character which satisfies 'isSpace')
-- Returns the parsed character.
space :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE space #-}
space = satisfy isSpace <?> "space"
-- | Parses a newline character (\'\\n\'). Returns a newline character.
newline :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE newline #-}
newline = char '\n' <?> "lf new-line"
-- | Parses a carriage return character (\'\\r\') followed by a newline character (\'\\n\').
-- Returns a newline character.
crlf :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE crlf #-}
crlf = char '\r' *> char '\n' <?> "crlf new-line"
-- | Parses a CRLF (see 'crlf') or LF (see 'newline') end-of-line.
......@@ -70,23 +76,27 @@ crlf = char '\r' *> char '\n' <?> "crlf new-line"
--
endOfLine :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE endOfLine #-}
endOfLine = newline <|> crlf <?> "new-line"
-- | Parses a tab character (\'\\t\'). Returns a tab character.
tab :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE tab #-}
tab = char '\t' <?> "tab"
-- | Parses an upper case letter (according to 'isUpper').
-- Returns the parsed character.
upper :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE upper #-}
upper = satisfy isUpper <?> "uppercase letter"
-- | Parses a lower case character (according to 'isLower').
-- Returns the parsed character.
lower :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE lower #-}
lower = satisfy isLower <?> "lowercase letter"
-- | Parses a alphabetic or numeric Unicode characters
......@@ -97,6 +107,7 @@ lower = satisfy isLower <?> "lowercase letter"
-- but not by 'digit'.
alphaNum :: (Stream s m Char => ParsecT s u m Char)
{-# INLINABLE alphaNum #-}
alphaNum = satisfy isAlphaNum <?> "letter or digit"
-- | Parses an alphabetic Unicode characters (lower-case, upper-case and title-case letters,
......@@ -104,23 +115,27 @@ alphaNum = satisfy isAlphaNum <?> "letter or digit"
-- Returns the parsed character.
letter :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE letter #-}
letter = satisfy isAlpha <?> "letter"
-- | Parses an ASCII digit. Returns the parsed character.
digit :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE digit #-}
digit = satisfy isDigit <?> "digit"
-- | Parses a hexadecimal digit (a digit or a letter between \'a\' and
-- \'f\' or \'A\' and \'F\'). Returns the parsed character.
hexDigit :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE hexDigit #-}
hexDigit = satisfy isHexDigit <?> "hexadecimal digit"
-- | Parses an octal digit (a character between \'0\' and \'7\'). Returns
-- the parsed character.
octDigit :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE octDigit #-}
octDigit = satisfy isOctDigit <?> "octal digit"
-- | @char c@ parses a single character @c@. Returns the parsed
......@@ -129,11 +144,13 @@ octDigit = satisfy isOctDigit <?> "octal digit"
-- > semiColon = char ';'
char :: (Stream s m Char) => Char -> ParsecT s u m Char
{-# INLINABLE char #-}
char c = satisfy (==c) <?> show [c]
-- | This parser succeeds for any character. Returns the parsed character.
anyChar :: (Stream s m Char) => ParsecT s u m Char
{-# INLINABLE anyChar #-}
anyChar = satisfy (const True)
-- | The parser @satisfy f@ succeeds for any character for which the
......@@ -144,6 +161,7 @@ anyChar = satisfy (const True)
-- > oneOf cs = satisfy (\c -> c `elem` cs)
satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
{-# INLINABLE satisfy #-}
satisfy f = tokenPrim (\c -> show [c])
(\pos c _cs -> updatePosChar pos c)
(\c -> if f c then Just c else Nothing)
......@@ -155,4 +173,5 @@ satisfy f = tokenPrim (\c -> show [c])
-- > <|> string "mod"
string :: (Stream s m Char) => String -> ParsecT s u m String
{-# INLINABLE string #-}
string s = tokens show updatePosString s
......@@ -51,6 +51,7 @@ import Debug.Trace (trace)
-- parser.
choice :: (Stream s m t) => [ParsecT s u m a] -> ParsecT s u m a
{-# INLINABLE choice #-}
choice ps = foldr (<|>) mzero ps
-- | @option x p@ tries to apply parser @p@. If @p@ fails without
......@@ -62,6 +63,7 @@ choice ps = foldr (<|>) mzero ps
-- > })
option :: (Stream s m t) => a -> ParsecT s u m a -> ParsecT s u m a
{-# INLINABLE option #-}
option x p = p <|> return x
-- | @optionMaybe p@ tries to apply parser @p@. If @p@ fails without
......@@ -69,6 +71,7 @@ option x p = p <|> return x
-- 'Just' the value returned by @p@.
optionMaybe :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (Maybe a)
{-# INLINABLE optionMaybe #-}
optionMaybe p = option Nothing (liftM Just p)
-- | @optional p@ tries to apply parser @p@. It will parse @p@ or nothing.
......@@ -76,6 +79,7 @@ optionMaybe p = option Nothing (liftM Just p)
-- of @p@.
optional :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()
{-# INLINABLE optional #-}
optional p = do{ _ <- p; return ()} <|> return ()
-- | @between open close p@ parses @open@, followed by @p@ and @close@.
......@@ -85,6 +89,7 @@ optional p = do{ _ <- p; return ()} <|> return ()
between :: (Stream s m t) => ParsecT s u m open -> ParsecT s u m close
-> ParsecT s u m a -> ParsecT s u m a
{-# INLINABLE between #-}
between open close p
= do{ _ <- open; x <- p; _ <- close; return x }
......@@ -92,6 +97,7 @@ between open close p
-- its result.
skipMany1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()
{-# INLINABLE skipMany1 #-}
skipMany1 p = do{ _ <- p; skipMany p }
{-
skipMany p = scan
......@@ -105,6 +111,7 @@ skipMany p = scan
-- > word = many1 letter
many1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a]
{-# INLINABLE many1 #-}
many1 p = do{ x <- p; xs <- many p; return (x:xs) }
{-
many p = scan id
......@@ -122,12 +129,14 @@ many p = scan id
-- > commaSep p = p `sepBy` (symbol ",")
sepBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
{-# INLINABLE sepBy #-}
sepBy p sep = sepBy1 p sep <|> return []
-- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated
-- by @sep@. Returns a list of values returned by @p@.
sepBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
{-# INLINABLE sepBy1 #-}
sepBy1 p sep = do{ x <- p
; xs <- many (sep >> p)
; return (x:xs)
......@@ -139,6 +148,7 @@ sepBy1 p sep = do{ x <- p
-- returned by @p@.
sepEndBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
{-# INLINABLE sepEndBy1 #-}
sepEndBy1 p sep = do{ x <- p
; do{ _ <- sep
; xs <- sepEndBy p sep
......@@ -154,6 +164,7 @@ sepEndBy1 p sep = do{ x <- p
-- > haskellStatements = haskellStatement `sepEndBy` semi
sepEndBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
{-# INLINABLE sepEndBy #-}
sepEndBy p sep = sepEndBy1 p sep <|> return []
......@@ -161,6 +172,7 @@ sepEndBy p sep = sepEndBy1 p sep <|> return []
-- and ended by @sep@. Returns a list of values returned by @p@.
endBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
{-# INLINABLE endBy1 #-}
endBy1 p sep = many1 (do{ x <- p; _ <- sep; return x })
-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated
......@@ -169,6 +181,7 @@ endBy1 p sep = many1 (do{ x <- p; _ <- sep; return x })
-- > cStatements = cStatement `endBy` semi
endBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
{-# INLINABLE endBy #-}
endBy p sep = many (do{ x <- p; _ <- sep; return x })
-- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or
......@@ -176,6 +189,7 @@ endBy p sep = many (do{ x <- p; _ <- sep; return x })
-- @n@ values returned by @p@.
count :: (Stream s m t) => Int -> ParsecT s u m a -> ParsecT s u m [a]
{-# INLINABLE count #-}
count n p | n <= 0 = return []
| otherwise = sequence (replicate n p)
......@@ -186,6 +200,7 @@ count n p | n <= 0 = return []
-- returned.
chainr :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a
{-# INLINABLE chainr #-}
chainr p op x = chainr1 p op <|> return x
-- | @chainl p op x@ parses /zero/ or more occurrences of @p@,
......@@ -195,6 +210,7 @@ chainr p op x = chainr1 p op <|> return x
-- returned.
chainl :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a
{-# INLINABLE chainl #-}
chainl p op x = chainl1 p op <|> return x
-- | @chainl1 p op@ parses /one/ or more occurrences of @p@,
......@@ -214,6 +230,7 @@ chainl p op x = chainl1 p op <|> return x
-- > <|> do{ symbol "-"; return (-) }
chainl1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
{-# INLINABLE chainl1 #-}
chainl1 p op = do{ x <- p; rest x }
where
rest x = do{ f <- op
......@@ -228,6 +245,7 @@ chainl1 p op = do{ x <- p; rest x }
-- by @p@.
chainr1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
{-# INLINABLE chainr1 #-}
chainr1 p op = scan
where
scan = do{ x <- p; rest x }
......@@ -245,6 +263,7 @@ chainr1 p op = scan
-- used to implement 'eof'. Returns the accepted token.
anyToken :: (Stream s m t, Show t) => ParsecT s u m t
{-# INLINABLE anyToken #-}
anyToken = tokenPrim show (\pos _tok _toks -> pos) Just
-- | This parser only succeeds at the end of the input. This is not a
......@@ -253,6 +272,7 @@ anyToken = tokenPrim show (\pos _tok _toks -> pos) Just
-- > eof = notFollowedBy anyToken <?> "end of input"
eof :: (Stream s m t, Show t) => ParsecT s u m ()
{-# INLINABLE eof #-}
eof = notFollowedBy anyToken <?> "end of input"
-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser
......@@ -279,6 +299,7 @@ eof = notFollowedBy anyToken <?> "end of input"
-- for more details.
notFollowedBy :: (Stream s m t, Show a) => ParsecT s u m a -> ParsecT s u m ()
{-# INLINABLE notFollowedBy #-}
notFollowedBy p = try (do{ c <- try p; unexpected (show c) }
<|> return ()
)
......@@ -295,6 +316,7 @@ notFollowedBy p = try (do{ c <- try p; unexpected (show c) }
-- therefore the use of the 'try' combinator.
manyTill :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
{-# INLINABLE manyTill #-}
manyTill p end = scan
where
scan = do{ _ <- end; return [] }
......@@ -311,6 +333,7 @@ manyTill p end = scan
--
-- @since 3.1.12.0
parserTrace :: (Show t, Stream s m t) => String -> ParsecT s u m ()
{-# INLINABLE parserTrace #-}
parserTrace s = pt <|> return ()
where
pt = try $ do
......@@ -332,6 +355,7 @@ parserTrace s = pt <|> return ()
--
-- @since 3.1.12.0
parserTraced :: (Stream s m t, Show t) => String -> ParsecT s u m b -> ParsecT s u m b
{-# INLINABLE parserTraced #-}
parserTraced s p = do
parserTrace s
p <|> trace (s ++ " backtracked") (fail s)
......@@ -96,6 +96,7 @@ buildExpressionParser :: (Stream s m t)
=> OperatorTable s u m a
-> ParsecT s u m a
-> ParsecT s u m a
{-# INLINABLE buildExpressionParser #-}
buildExpressionParser operators simpleExpr
= foldl (makeParser) simpleExpr operators
where
......
......@@ -156,6 +156,7 @@ newtype ParsecT s u m a
-- | Low-level unpacking of the ParsecT type. To run your parser, please look to
-- runPT, runP, runParserT, runParser and other such functions.
runParsecT :: Monad m => ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a)))
{-# INLINABLE runParsecT #-}
runParsecT p s = unParser p s cok cerr eok eerr
where cok a s' err = return . Consumed . return $ Ok a s' err
cerr err = return . Consumed . return $ Error err
......@@ -164,6 +165,7 @@ runParsecT p s = unParser p s cok cerr eok eerr
-- | Low-level creation of the ParsecT type. You really shouldn't have to do this.
mkPT :: Monad m => (State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a
{-# INLINABLE mkPT #-}
mkPT k = ParsecT $ \s cok cerr eok eerr -> do
cons <- k s
case cons of
......@@ -586,6 +588,7 @@ token :: (Stream s Identity t)
-> (t -> SourcePos) -- ^ Computes the position of a token.
-> (t -> Maybe a) -- ^ Matching function for the token to parse.
-> Parsec s u a
{-# INLINABLE token #-}
token showToken tokpos test = tokenPrim showToken nextpos test
where
nextpos _ tok ts = case runIdentity (uncons ts) of
......@@ -698,6 +701,7 @@ manyErr = error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is a
runPT :: (Stream s m t)
=> ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)
{-# INLINABLE runPT #-}
runPT p u name s
= do res <- runParsecT p (State s (initialPos name) u)
r <- parserReply res
......
......@@ -357,6 +357,7 @@ data GenTokenParser s u m
makeTokenParser :: (Stream s m Char)
=> GenLanguageDef s u m -> GenTokenParser s u m
{-# INLINABLE makeTokenParser #-}
makeTokenParser languageDef
= TokenParser{ identifier = identifier
, reserved = reserved
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment