summaryrefslogtreecommitdiff
path: root/src/System/Console/Concurrent/Internal.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/System/Console/Concurrent/Internal.hs')
-rw-r--r--src/System/Console/Concurrent/Internal.hs26
1 files changed, 15 insertions, 11 deletions
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