summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSebastian Graf <sebastian.graf@kit.edu>2021-03-28 21:26:24 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-04-26 23:53:56 -0400
commitd38397fa26acb2588253ffd704e212dbf55b2bf4 (patch)
tree9fe24a5d104655114e27e2d8d76ce5cdf855be8f
parent0015f019f72ddd2ca4a46e987bf17acaf0ce59d2 (diff)
downloadhaskell-d38397fa26acb2588253ffd704e212dbf55b2bf4.tar.gz
Parser: Unbox `ParseResult`
Using `UnliftedNewtypes`, unboxed tuples and sums and a few pattern synonyms, we can make `ParseResult` completely allocation-free. Part of #19263.
-rw-r--r--compiler/GHC/Parser/Lexer.x40
1 files changed, 26 insertions, 14 deletions
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index c813ab33e2..2864e2998e 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -45,6 +45,10 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnliftedNewtypes #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -53,7 +57,7 @@ module GHC.Parser.Lexer (
Token(..), lexer, lexerDbg,
ParserOpts(..), mkParserOpts,
PState (..), initParserState, initPragState,
- P(..), ParseResult(..),
+ P(..), ParseResult(POk, PFailed),
allocateComments, allocatePriorComments, allocateFinalComments,
MonadP(..),
getRealSrcLoc, getPState,
@@ -2273,17 +2277,25 @@ data LayoutContext
deriving Show
-- | The result of running a parser.
-data ParseResult a
- = POk -- ^ The parser has consumed a (possibly empty) prefix
- -- of the input and produced a result. Use 'getMessages'
- -- to check for accumulated warnings and non-fatal errors.
- PState -- ^ The resulting parsing state. Can be used to resume parsing.
- a -- ^ The resulting value.
- | PFailed -- ^ The parser has consumed a (possibly empty) prefix
- -- of the input and failed.
- PState -- ^ The parsing state right before failure, including the fatal
- -- parse error. 'getMessages' and 'getErrorMessages' must return
- -- a non-empty bag of errors.
+newtype ParseResult a = PR (# (# PState, a #) | PState #)
+
+-- | The parser has consumed a (possibly empty) prefix of the input and produced
+-- a result. Use 'getMessages' to check for accumulated warnings and non-fatal
+-- errors.
+--
+-- The carried parsing state can be used to resume parsing.
+pattern POk :: PState -> a -> ParseResult a
+pattern POk s a = PR (# (# s , a #) | #)
+
+-- | The parser has consumed a (possibly empty) prefix of the input and failed.
+--
+-- The carried parsing state can be used to resume parsing. It is the state
+-- right before failure, including the fatal parse error. 'getMessages' and
+-- 'getErrorMessages' must return a non-empty bag of errors.
+pattern PFailed :: PState -> ParseResult a
+pattern PFailed s = PR (# | s #)
+
+{-# COMPLETE POk, PFailed #-}
-- | Test whether a 'WarningFlag' is set
warnopt :: WarningFlag -> ParserOpts -> Bool
@@ -3024,7 +3036,7 @@ srcParseErr
srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc
where
token = lexemeToString (offsetBytes (-len) buf) len
- pattern = decodePrevNChars 8 buf
+ pattern_ = decodePrevNChars 8 buf
last100 = decodePrevNChars 100 buf
doInLast100 = "do" `isInfixOf` last100
mdoInLast100 = "mdo" `isInfixOf` last100
@@ -3036,7 +3048,7 @@ srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc
sug_rdo = sug (token == "<-" && mdoInLast100) SuggestRecursiveDo
sug_do = sug (token == "<-" && not mdoInLast100) SuggestDo
sug_let = sug (token == "=" && doInLast100) SuggestLetInDo -- #15849
- sug_pat = sug (not ps_enabled && pattern == "pattern ") SuggestPatternSynonyms -- #12429
+ sug_pat = sug (not ps_enabled && pattern_ == "pattern ") SuggestPatternSynonyms -- #12429
suggests
| null token = []
| otherwise = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat]