Commit 194384f1 authored by Douglas Wilson's avatar Douglas Wilson Committed by Ben Gamari
Browse files

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
parent a85a5959
......@@ -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 =
......
......@@ -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']),
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment