From 6477878cedfe9f96b35c81299ffda1d140c025b7 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 2 Feb 2022 14:53:34 +0000 Subject: Rewrite CallerCC parser using ReadP This allows us to remove the dependency on parsec and hence transitively on text. Also added some simple unit tests for the parser and fixed two small issues in the documentation. Fixes #21033 --- compiler/GHC/Core/Opt/CallerCC.hs | 25 +++++++------- compiler/ghc.cabal.in | 1 - docs/users_guide/profiling.rst | 4 +-- .../should_run/caller-cc/CallerCcParser.hs | 38 ++++++++++++++++++++++ .../should_run/caller-cc/CallerCcParser.stdout | 5 +++ .../tests/profiling/should_run/caller-cc/all.T | 4 +++ 6 files changed, 63 insertions(+), 14 deletions(-) create mode 100644 testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs create mode 100644 testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.stdout diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs index 8808296126..e8ac5a7cff 100644 --- a/compiler/GHC/Core/Opt/CallerCC.hs +++ b/compiler/GHC/Core/Opt/CallerCC.hs @@ -10,19 +10,19 @@ -- flag. module GHC.Core.Opt.CallerCC ( addCallerCostCentres - , CallerCcFilter + , CallerCcFilter(..) + , NamePattern(..) , parseCallerCcFilter ) where -import Data.Bifunctor import Data.Word (Word8) import Data.Maybe -import qualified Text.Parsec as P import Control.Applicative import GHC.Utils.Monad.State.Strict import Data.Either import Control.Monad +import qualified Text.ParserCombinators.ReadP as P import GHC.Prelude import GHC.Utils.Outputable as Outputable @@ -42,6 +42,7 @@ import GHC.Core import GHC.Core.Opt.Monad import GHC.Utils.Panic import qualified GHC.Utils.Binary as B +import Data.Char addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do @@ -171,17 +172,17 @@ occNameMatches pat = go pat . occNameString = go rest s || go (PWildcard rest) (tail s) go _ _ = False -type Parser = P.Parsec String () +type Parser = P.ReadP parseNamePattern :: Parser NamePattern parseNamePattern = pattern where - pattern = star <|> wildcard <|> char <|> end + pattern = star P.<++ wildcard P.<++ char P.<++ end star = PChar '*' <$ P.string "\\*" <*> pattern wildcard = do void $ P.char '*' PWildcard <$> pattern - char = PChar <$> P.anyChar <*> pattern + char = PChar <$> P.get <*> pattern end = PEnd <$ P.eof data CallerCcFilter @@ -200,8 +201,10 @@ instance B.Binary CallerCcFilter where put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y parseCallerCcFilter :: String -> Either String CallerCcFilter -parseCallerCcFilter = - first show . P.parse parseCallerCcFilter' "caller-CC filter" +parseCallerCcFilter inp = + case P.readP_to_S parseCallerCcFilter' inp of + ((result, ""):_) -> Right result + _ -> Left $ "parse error on " ++ inp parseCallerCcFilter' :: Parser CallerCcFilter parseCallerCcFilter' = @@ -218,8 +221,8 @@ parseCallerCcFilter' = moduleName :: Parser String moduleName = do - c <- P.upper - cs <- some $ P.upper <|> P.lower <|> P.digit <|> P.oneOf "_" - rest <- optional $ P.try $ P.char '.' >> fmap ('.':) moduleName + c <- P.satisfy isUpper + cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_') + rest <- optional $ P.char '.' >> fmap ('.':) moduleName return $ c : (cs ++ fromMaybe "" rest) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ff90538a0f..0f1abca002 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -74,7 +74,6 @@ Library hpc == 0.6.*, transformers == 0.5.*, exceptions == 0.10.*, - parsec, stm, ghc-boot == @ProjectVersionMunged@, ghc-heap == @ProjectVersionMunged@, diff --git a/docs/users_guide/profiling.rst b/docs/users_guide/profiling.rst index 0aa437a4dc..a1b1de819f 100644 --- a/docs/users_guide/profiling.rst +++ b/docs/users_guide/profiling.rst @@ -386,9 +386,9 @@ compiled program. * ``Data.List.map`` * ``*.map`` * ``*.parse*`` - * ``*.<\\*>`` + * ``*.<\*>`` - The ``*`` character can be used literally by escaping (e.g. ``\\*``). + The ``*`` character can be used literally by escaping (e.g. ``\*``). .. ghc-flag:: -fprof-auto :shortdesc: Auto-add ``SCC``\\ s to all bindings not marked INLINE diff --git a/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs b/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs new file mode 100644 index 0000000000..a6f160a5e3 --- /dev/null +++ b/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs @@ -0,0 +1,38 @@ +-- Unit tests for the CallerCcParser +{-# LANGUAGE StandaloneDeriving #-} +module Main where + +import GHC.Core.Opt.CallerCC +import GHC.Unit.Module.Name + +deriving instance Eq CallerCcFilter +deriving instance Show CallerCcFilter +deriving instance Eq NamePattern +deriving instance Show NamePattern + +runTest :: String -> Maybe CallerCcFilter -> IO () +runTest filter exp = putStrLn $ + case parseCallerCcFilter filter of + Left err -> case exp of + Nothing -> "Expected failure: " ++ filter ++ " " ++ err + Just exp -> "Unexpected failure: " ++ filter ++ " " ++ err + Right res -> + case exp of + Nothing -> "Unexpected parse: " ++ filter ++ " " ++ show res + Just exp | exp == res -> "Expected parse: " ++ filter ++ " " ++ show res + | otherwise -> "Unexpected parse: " ++ filter ++ show res ++ show exp + +mkPattern :: String -> NamePattern +mkPattern s = foldr PChar PEnd s + +mkPattern_ :: String -> NamePattern -> NamePattern +mkPattern_ s e = foldr PChar e s + +main = do + runTest "*.map" (Just (CallerCcFilter Nothing (mkPattern "map"))) + runTest "*.parse*" (Just (CallerCcFilter Nothing (mkPattern_ "parse" (PWildcard PEnd)))) + runTest "Data.List.map" (Just (CallerCcFilter (Just (mkModuleName "Data.List")) (mkPattern "map"))) + runTest "*.<\\*>" (Just (CallerCcFilter Nothing (mkPattern "<*>"))) + runTest "as.b" Nothing + + diff --git a/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.stdout b/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.stdout new file mode 100644 index 0000000000..4c60714103 --- /dev/null +++ b/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.stdout @@ -0,0 +1,5 @@ +Expected parse: *.map CallerCcFilter {ccfModuleName = Nothing, ccfFuncName = PChar 'm' (PChar 'a' (PChar 'p' PEnd))} +Expected parse: *.parse* CallerCcFilter {ccfModuleName = Nothing, ccfFuncName = PChar 'p' (PChar 'a' (PChar 'r' (PChar 's' (PChar 'e' (PWildcard PEnd)))))} +Expected parse: Data.List.map CallerCcFilter {ccfModuleName = Just (ModuleName "Data.List"), ccfFuncName = PChar 'm' (PChar 'a' (PChar 'p' PEnd))} +Expected parse: *.<\*> CallerCcFilter {ccfModuleName = Nothing, ccfFuncName = PChar '<' (PChar '*' (PChar '>' PEnd))} +Expected failure: as.b parse error on as.b diff --git a/testsuite/tests/profiling/should_run/caller-cc/all.T b/testsuite/tests/profiling/should_run/caller-cc/all.T index 2b8837aa07..db9979b67d 100644 --- a/testsuite/tests/profiling/should_run/caller-cc/all.T +++ b/testsuite/tests/profiling/should_run/caller-cc/all.T @@ -1,3 +1,7 @@ +test('CallerCcParser', normal, + compile_and_run, + ['-package ghc']) + setTestOpts(req_profiling) setTestOpts(extra_ways(['prof', 'ghci-ext-prof'])) setTestOpts(only_ways(prof_ways)) -- cgit v1.2.1