[commit: ghc] master: Fix busy-wait in SysTools.builderMainLoop (194384f)
git at git.haskell.org
git at git.haskell.org
Thu Jul 20 16:05:03 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/194384f1318e0553e0c5ce621ca0903b55862eb3/ghc
>---------------------------------------------------------------
commit 194384f1318e0553e0c5ce621ca0903b55862eb3
Author: Douglas Wilson <douglas.wilson at gmail.com>
Date: Thu Jul 20 08:48:12 2017 -0400
Fix busy-wait in SysTools.builderMainLoop
Test T13701 was failing sporadically. The problem manifested while the
test was run on a system under load. Profiling showed the increased
allocations were in SysTools.builderMainLoop.loop, during calls to the
assembler. This was due to loop effectively busy-waiting from when both
stdin and stderr handles were closed, until getProcessExitCode
succeeded.
This is fixed by removing exit code handling from loop. We now wait for
loop to finish, then read the exit code with waitForProcess.
Some exception safety is added: the readerProc threads will now be
killed and the handles will be closed if an exception is thrown.
A TODO saying that threads dying is not accounted for is removed. I
believe that this case is handled by readerProc sending EOF in a finally
clause.
Test Plan:
Replicate test failures using procedure on the ticket, verify that they
do not occur with this patch.
Reviewers: austin, bgamari
Reviewed By: bgamari
Subscribers: rwbarton, thomie
GHC Trac Issues: #13987
Differential Revision: https://phabricator.haskell.org/D3748
>---------------------------------------------------------------
194384f1318e0553e0c5ce621ca0903b55862eb3
compiler/main/SysTools.hs | 96 ++++++++++++++++++++-----------------
testsuite/tests/perf/compiler/all.T | 3 +-
2 files changed, 55 insertions(+), 44 deletions(-)
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 0a19feb..3d16124 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -1134,50 +1134,60 @@ builderMainLoop :: DynFlags -> (String -> String) -> FilePath
-> IO ExitCode
builderMainLoop dflags filter_fn pgm real_args mb_env = do
chan <- newChan
- (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
-
- -- and run a loop piping the output from the compiler to the log_action in DynFlags
- hSetBuffering hStdOut LineBuffering
- hSetBuffering hStdErr LineBuffering
- _ <- forkIO (readerProc chan hStdOut filter_fn)
- _ <- forkIO (readerProc chan hStdErr filter_fn)
- -- we don't want to finish until 2 streams have been completed
- -- (stdout and stderr)
- -- nor until 1 exit code has been retrieved.
- rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
- -- after that, we're done here.
- hClose hStdIn
- hClose hStdOut
- hClose hStdErr
- return rc
+
+ -- 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
+ -- acquire
+ (hStdIn, hStdOut, hStdErr, hProcess) <- restore $
+ runInteractiveProcess pgm real_args Nothing mb_env
+ let cleanup_handles = do
+ hClose hStdIn
+ hClose hStdOut
+ hClose hStdErr
+ r <- try $ restore $ do
+ hSetBuffering hStdOut LineBuffering
+ hSetBuffering hStdErr LineBuffering
+ let make_reader_proc h = forkIO $ readerProc chan h filter_fn
+ bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
+ bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
+ inner hProcess
+ case r of
+ -- onException
+ Left (SomeException e) -> do
+ terminateProcess hProcess
+ cleanup_handles
+ throw e
+ -- cleanup when there was no exception
+ Right s -> do
+ cleanup_handles
+ return s
+ safely $ \h -> do
+ -- we don't want to finish until 2 streams have been complete
+ -- (stdout and stderr)
+ log_loop chan (2 :: Integer)
+ -- after that, we wait for the process to finish and return the exit code.
+ waitForProcess h
where
- -- status starts at zero, and increments each time either
- -- a reader process gets EOF, or the build proc exits. We wait
- -- for all of these to happen (status==3).
- -- ToDo: we should really have a contingency plan in case any of
- -- the threads dies, such as a timeout.
- loop _ _ 0 0 exitcode = return exitcode
- loop chan hProcess t p exitcode = do
- mb_code <- if p > 0
- then getProcessExitCode hProcess
- else return Nothing
- case mb_code of
- Just code -> loop chan hProcess t (p-1) code
- Nothing
- | t > 0 -> do
- msg <- readChan chan
- case msg of
- BuildMsg msg -> do
- putLogMsg dflags NoReason SevInfo noSrcSpan
- (defaultUserStyle dflags) msg
- loop chan hProcess t p exitcode
- BuildError loc msg -> do
- putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
- (defaultUserStyle dflags) msg
- loop chan hProcess t p exitcode
- EOF ->
- loop chan hProcess (t-1) p exitcode
- | otherwise -> loop chan hProcess t p exitcode
+ -- t starts at the number of streams we're listening to (2) decrements each
+ -- time a reader process sends EOF. We are safe from looping forever if a
+ -- reader thread dies, because they send EOF in a finally handler.
+ log_loop _ 0 = return ()
+ log_loop chan t = do
+ msg <- readChan chan
+ case msg of
+ BuildMsg msg -> do
+ putLogMsg dflags NoReason SevInfo noSrcSpan
+ (defaultUserStyle dflags) msg
+ log_loop chan t
+ BuildError loc msg -> do
+ putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
+ (defaultUserStyle dflags) msg
+ log_loop chan t
+ EOF ->
+ log_loop chan (t-1)
readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
readerProc chan hdl filter_fn =
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index ce378bf..0389271 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -1132,11 +1132,12 @@ test('MultiLayerModules',
test('T13701',
[ compiler_stats_num_field('bytes allocated',
[(platform('x86_64-apple-darwin'), 2217187888, 10),
- (platform('x86_64-unknown-linux'), 2412223768, 10),
+ (platform('x86_64-unknown-linux'), 2133380768, 10),
# initial: 2511285600
# 2017-06-23: 2188045288 treat banged variable bindings as FunBinds
# 2017-07-11: 2187920960
# 2017-07-12: 2412223768 inconsistency between Ben's machine and Harbormaster?
+ # 2017-07-17: 2133380768 Resolved the issue causing the inconsistencies in this test
]),
pre_cmd('./genT13701'),
extra_files(['genT13701']),
More information about the ghc-commits
mailing list