summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Core/Opt/CallerCC.hs25
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--docs/users_guide/profiling.rst4
-rw-r--r--testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs38
-rw-r--r--testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.stdout5
-rw-r--r--testsuite/tests/profiling/should_run/caller-cc/all.T4
6 files changed, 63 insertions, 14 deletions
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))
View Lorry Controller Status