From e01349e3100bb7a2c6cd13594f9ac56beb6b793d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:35:31 -0400 Subject: merge from concurrent-output 1.7.2 --- src/System/Console/Concurrent/Internal.hs | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) (limited to 'src/System') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index a4cafb61..985bc130 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -114,21 +114,20 @@ withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput -- | Blocks until any processes started by `createProcessConcurrent` have --- finished, and any buffered output is displayed. +-- finished, and any buffered output is displayed. Also blocks while +-- `lockOutput` is is use. -- --- `withConcurrentOutput` calls this at the end; you can call it anytime --- you want to flush output. +-- `withConcurrentOutput` calls this at the end, so you do not normally +-- need to use this. flushConcurrentOutput :: IO () flushConcurrentOutput = do - -- Wait for all outputThreads to finish. - let v = outputThreads globalOutputHandle atomically $ do - r <- takeTMVar v + r <- takeTMVar (outputThreads globalOutputHandle) if r <= 0 - then putTMVar v r + then putTMVar (outputThreads globalOutputHandle) r else retry - -- Take output lock to ensure that nothing else is currently - -- generating output, and flush any buffered output. + -- Take output lock to wait for anything else that might be + -- currently generating output. lockOutput $ return () -- | Values that can be output. @@ -286,9 +285,11 @@ fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, Co fgProcess p = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock + registerOutputThread -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h + unregisterOutputThread dropOutputLock return (toConcurrentProcessHandle r) @@ -402,7 +403,7 @@ bufferWriter ts = do ( void $ mapConcurrently displaybuf ts , noop -- buffers already moved to global ) - worker2 <- async $ void $ globalbuf activitysig + worker2 <- async $ void $ globalbuf activitysig worker1 void $ async $ do void $ waitCatch worker1 void $ waitCatch worker2 @@ -419,7 +420,7 @@ bufferWriter ts = do case change of Right BufSig -> displaybuf v Left AtEnd -> return () - globalbuf activitysig = do + globalbuf activitysig worker1 = do ok <- atomically $ do -- signal we're going to handle it -- (returns false if the displaybuf already did) @@ -436,6 +437,9 @@ bufferWriter ts = do atomically $ forM_ bs $ \(outh, b) -> bufferOutputSTM' outh b + -- worker1 might be blocked waiting for the output + -- lock, and we've already done its job, so cancel it + cancel worker1 -- Adds a value to the OutputBuffer. When adding Output to a Handle, -- it's cheaper to combine it with any already buffered Output to that -- cgit v1.2.3