[Git][ghc/ghc][master] 2 commits: Make filter functionality for system tools line-based
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Dec 14 09:32:21 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b339e7c3 by Simon Hengel at 2024-12-14T04:31:47-05:00
Make filter functionality for system tools line-based
This is more efficient as:
- All existing filter functions were line-based anyway. They broke up
the input into lines and then joined it back together.
- We already break up the output from system tools into lines when
processing it.
Splitting up the output of system tools once and then filtering and
processing it reduces both code and runtime complexity.
- - - - -
39669077 by Simon Hengel at 2024-12-14T04:31:47-05:00
Refactoring: Don't use a `Chan` when parsing SysTools output
- - - - -
4 changed files:
- compiler/GHC/Driver/Config/Linker.hs
- compiler/GHC/Linker/Config.hs
- compiler/GHC/SysTools/Process.hs
- compiler/GHC/SysTools/Tasks.hs
Changes:
=====================================
compiler/GHC/Driver/Config/Linker.hs
=====================================
@@ -27,9 +27,8 @@ initLinkerConfig dflags =
ld_filter = case platformOS (targetPlatform dflags) of
OSSolaris2 -> sunos_ld_filter
_ -> id
- sunos_ld_filter :: String -> String
- sunos_ld_filter = unlines . sunos_ld_filter' . lines
- sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
+ sunos_ld_filter :: [String] -> [String]
+ sunos_ld_filter x = if (undefined_found x && ld_warning_found x)
then (ld_prefix x) ++ (ld_postfix x)
else x
breakStartsWith x y = break (isPrefixOf x) y
=====================================
compiler/GHC/Linker/Config.hs
=====================================
@@ -22,6 +22,6 @@ data LinkerConfig = LinkerConfig
, linkerOptionsPre :: [Option] -- ^ Linker options (before user options)
, linkerOptionsPost :: [Option] -- ^ Linker options (after user options)
, linkerTempDir :: TempDir -- ^ Temporary directory to use
- , linkerFilter :: String -> String -- ^ Output filter
+ , linkerFilter :: [String] -> [String] -- ^ Output filter
}
=====================================
compiler/GHC/SysTools/Process.hs
=====================================
@@ -149,7 +149,7 @@ runSomethingResponseFile
:: Logger
-> TmpFs
-> TempDir
- -> (String->String)
+ -> ([String] -> [String])
-> String
-> String
-> [Option]
@@ -195,7 +195,7 @@ runSomethingResponseFile logger tmpfs tmp_dir filter_fn phase_name pgm args mb_e
]
runSomethingFiltered
- :: Logger -> (String->String) -> String -> String -> [Option]
+ :: Logger -> ([String] -> [String]) -> String -> String -> [Option]
-> Maybe FilePath -> Maybe [(String,String)] -> IO ()
runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env =
@@ -235,7 +235,7 @@ withPipe = bracket createPipe $ \ (readEnd, writeEnd) -> do
hClose readEnd
hClose writeEnd
-builderMainLoop :: Logger -> (String -> String) -> FilePath
+builderMainLoop :: Logger -> ([String] -> [String]) -> FilePath
-> [String] -> Maybe FilePath -> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (readEnd, writeEnd) -> do
@@ -245,13 +245,11 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
associateHandle' =<< handleToHANDLE readEnd
#endif
- chan <- newChan
-
-- We use a mask here rather than a bracket because we want
-- to distinguish between cleaning up with and without an
-- exception. This is to avoid calling terminateProcess
-- unless an exception was raised.
- let safely inner = mask $ \restore -> do
+ mask $ \restore -> do
-- acquire
-- On Windows due to how exec is emulated the old process will exit and
-- a new process will be created. This means waiting for termination of
@@ -282,9 +280,9 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
getLocaleEncoding >>= hSetEncoding readEnd
hSetNewlineMode readEnd nativeNewlineMode
hSetBuffering readEnd LineBuffering
- let make_reader_proc h = forkIO $ readerProc chan h filter_fn
- bracketOnError (make_reader_proc readEnd) killThread $ \_ ->
- inner hProcess
+ messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd
+ mapM_ processBuildMessage messages
+ waitForProcess hProcess
hClose hStdIn
case r of
Left (SomeException e) -> do
@@ -292,70 +290,55 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
throw e
Right s -> do
return s
- safely $ \h -> do
- processBuildMessages chan
- waitForProcess h
where
- processBuildMessages :: Chan BuildMessage -> IO ()
- processBuildMessages chan = do
- msg <- readChan chan
+ processBuildMessage :: BuildMessage -> IO ()
+ processBuildMessage msg = do
case msg of
BuildMsg msg -> do
logInfo logger $ withPprStyle defaultUserStyle msg
- processBuildMessages chan
BuildError loc msg -> do
logMsg logger errorDiagnostic (mkSrcSpan loc loc)
$ withPprStyle defaultUserStyle msg
- processBuildMessages chan
- EOF ->
- return ()
-
-readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
-readerProc chan hdl filter_fn =
- (do str <- hGetContents hdl
- loop (lines (filter_fn str)) Nothing)
- `finally`
- writeChan chan EOF
- -- ToDo: check errors more carefully
- -- ToDo: in the future, the filter should be implemented as
- -- a stream transformer.
+
+parseBuildMessages :: [String] -> [BuildMessage]
+parseBuildMessages str = loop str Nothing
where
- loop [] Nothing = return ()
- loop [] (Just err) = writeChan chan err
+ loop :: [String] -> Maybe BuildMessage -> [BuildMessage]
+ loop [] Nothing = []
+ loop [] (Just err) = [err]
loop (l:ls) in_err =
case in_err of
Just err@(BuildError srcLoc msg)
| leading_whitespace l ->
loop ls (Just (BuildError srcLoc (msg $$ text l)))
- | otherwise -> do
- writeChan chan err
- checkError l ls
+ | otherwise ->
+ err : checkError l ls
Nothing ->
checkError l ls
- _ -> panic "readerProc/loop"
+ _ -> panic "parseBuildMessages/loop"
+ checkError :: String -> [String] -> [BuildMessage]
checkError l ls
= case parseError l of
- Nothing -> do
- writeChan chan (BuildMsg (text l))
- loop ls Nothing
- Just (file, lineNum, colNum, msg) -> do
- let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
+ Nothing ->
+ BuildMsg (text l) : loop ls Nothing
+ Just (srcLoc, msg) -> do
loop ls (Just (BuildError srcLoc (text msg)))
+ leading_whitespace :: String -> Bool
leading_whitespace [] = False
leading_whitespace (x:_) = isSpace x
-parseError :: String -> Maybe (String, Int, Int, String)
+parseError :: String -> Maybe (SrcLoc, String)
parseError s0 = case breakColon s0 of
Just (filename, s1) ->
case breakIntColon s1 of
Just (lineNum, s2) ->
case breakIntColon s2 of
Just (columnNum, s3) ->
- Just (filename, lineNum, columnNum, s3)
+ Just (mkSrcLoc (mkFastString filename) lineNum columnNum, s3)
Nothing ->
- Just (filename, lineNum, 0, s2)
+ Just (mkSrcLoc (mkFastString filename) lineNum 0, s2)
Nothing -> Nothing
Nothing -> Nothing
@@ -385,4 +368,3 @@ breakIntColon xs = case break (':' ==) xs of
data BuildMessage
= BuildMsg !SDoc
| BuildError !SrcLoc !SDoc
- | EOF
=====================================
compiler/GHC/SysTools/Tasks.hs
=====================================
@@ -63,8 +63,8 @@ augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirecto
augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)
-- | Discard some harmless warnings from gcc that we can't turn off
-cc_filter :: String -> String
-cc_filter = unlines . doFilter . lines where
+cc_filter :: [String] -> [String]
+cc_filter = doFilter where
{-
gcc gives warnings in chunks like so:
In file included from /foo/bar/baz.h:11,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/62a2b25f6cd1947c85a7d847a8f88bb0de5d80fd...3966907789043f731a6b15f73594ca148505b0a0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/62a2b25f6cd1947c85a7d847a8f88bb0de5d80fd...3966907789043f731a6b15f73594ca148505b0a0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241214/1763adef/attachment-0001.html>
More information about the ghc-commits
mailing list