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

2 files changed, 55 insertions, 44 deletions

diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 0a19feb2ce..3d16124d72 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 ce378bf643..03892714c7 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']),