From d56333750e8cbea2a80962744602ba4243aeb8a7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:05:40 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index a4cafb61..38cc867a 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -284,6 +284,7 @@ createProcessForeground p = do fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) fgProcess p = do + print ("fgProcess", showProc p) r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock -- Wait for the process to exit and drop the lock. @@ -297,6 +298,7 @@ bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, Co bgProcess p = do (toouth, fromouth) <- pipe (toerrh, fromerrh) <- pipe + print ("bgProcess", showProc p) let p' = p { P.std_out = rediroutput (P.std_out p) toouth , P.std_err = rediroutput (P.std_err p) toerrh @@ -318,6 +320,11 @@ bgProcess p = do | otherwise = ss #endif +showProc = go . P.cmdspec + where + go (P.ShellCommand s) = s + go (P.RawCommand s ps) = show (s, ps) + willOutput :: P.StdStream -> Bool willOutput P.Inherit = True willOutput _ = False -- cgit v1.2.3 From daaf67021cd468fecefbeb0dbfe6244ca34b3a6d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:07:41 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index 38cc867a..b3ae588c 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -291,6 +291,7 @@ fgProcess p = do asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h dropOutputLock + print ("fgProcess done", showProc p) return (toConcurrentProcessHandle r) #ifndef mingw32_HOST_OS -- cgit v1.2.3 From a06da5b738efd95c6772b5e4a1b510f1de2d7912 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:16:27 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index b3ae588c..f38c63c3 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -290,8 +290,8 @@ fgProcess p = do -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h - dropOutputLock print ("fgProcess done", showProc p) + dropOutputLock return (toConcurrentProcessHandle r) #ifndef mingw32_HOST_OS -- cgit v1.2.3 From ed710fc09905a2b85916f19d6d4f5ec2bffeecae Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:19:49 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index f38c63c3..ea4534fd 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -284,13 +284,13 @@ createProcessForeground p = do fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) fgProcess p = do - print ("fgProcess", showProc p) + hPutStrLn stderr $ show ("fgProcess", showProc p) r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h - print ("fgProcess done", showProc p) + hPutStrLn stderr $ show ("fgProcess done", showProc p) dropOutputLock return (toConcurrentProcessHandle r) @@ -299,7 +299,7 @@ bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, Co bgProcess p = do (toouth, fromouth) <- pipe (toerrh, fromerrh) <- pipe - print ("bgProcess", showProc p) + hPutStrLn stderr $ show ("bgProcess", showProc p) let p' = p { P.std_out = rediroutput (P.std_out p) toouth , P.std_err = rediroutput (P.std_err p) toerrh -- cgit v1.2.3 From 3371befc6a3fd7451c3c5c01b7c2f6efb05eedaf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:29:12 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index ea4534fd..4f3a5e32 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -310,7 +310,7 @@ bgProcess p = do asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh - void $ async $ bufferWriter [outbuf, errbuf] + void $ async $ bufferWriter p [outbuf, errbuf] return (toConcurrentProcessHandle r) where pipe = do @@ -402,12 +402,14 @@ unregisterOutputThread = do -- -- If end is reached before lock is taken, instead add the command's -- buffers to the global outputBuffer and errorBuffer. -bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () -bufferWriter ts = do +bufferWriter :: P.CreateProcess -> [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () +bufferWriter p ts = do activitysig <- atomically newEmptyTMVar worker1 <- async $ lockOutput $ ifM (atomically $ tryPutTMVar activitysig ()) - ( void $ mapConcurrently displaybuf ts + ( do + hPutStrLn stderr $ show ("bufferWriter calling displaybuf", showProc p) + void $ mapConcurrently displaybuf ts , noop -- buffers already moved to global ) worker2 <- async $ void $ globalbuf activitysig @@ -437,6 +439,7 @@ bufferWriter ts = do mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts return ok when ok $ do + hPutStrLn stderr $ show ("bufferWriter saving in global buffer", showProc p) -- add all of the command's buffered output to the -- global output buffer, atomically bs <- forM ts $ \(outh, buf, _bufsig, _bufend) -> -- cgit v1.2.3 From 862e7c1263cb77e744b494eba43ecb2877a3c73f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:35:19 -0400 Subject: remove debug --- src/System/Console/Concurrent/Internal.hs | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index 4f3a5e32..a4cafb61 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -284,13 +284,11 @@ createProcessForeground p = do fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) fgProcess p = do - hPutStrLn stderr $ show ("fgProcess", showProc p) r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h - hPutStrLn stderr $ show ("fgProcess done", showProc p) dropOutputLock return (toConcurrentProcessHandle r) @@ -299,7 +297,6 @@ bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, Co bgProcess p = do (toouth, fromouth) <- pipe (toerrh, fromerrh) <- pipe - hPutStrLn stderr $ show ("bgProcess", showProc p) let p' = p { P.std_out = rediroutput (P.std_out p) toouth , P.std_err = rediroutput (P.std_err p) toerrh @@ -310,7 +307,7 @@ bgProcess p = do asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh - void $ async $ bufferWriter p [outbuf, errbuf] + void $ async $ bufferWriter [outbuf, errbuf] return (toConcurrentProcessHandle r) where pipe = do @@ -321,11 +318,6 @@ bgProcess p = do | otherwise = ss #endif -showProc = go . P.cmdspec - where - go (P.ShellCommand s) = s - go (P.RawCommand s ps) = show (s, ps) - willOutput :: P.StdStream -> Bool willOutput P.Inherit = True willOutput _ = False @@ -402,14 +394,12 @@ unregisterOutputThread = do -- -- If end is reached before lock is taken, instead add the command's -- buffers to the global outputBuffer and errorBuffer. -bufferWriter :: P.CreateProcess -> [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () -bufferWriter p ts = do +bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () +bufferWriter ts = do activitysig <- atomically newEmptyTMVar worker1 <- async $ lockOutput $ ifM (atomically $ tryPutTMVar activitysig ()) - ( do - hPutStrLn stderr $ show ("bufferWriter calling displaybuf", showProc p) - void $ mapConcurrently displaybuf ts + ( void $ mapConcurrently displaybuf ts , noop -- buffers already moved to global ) worker2 <- async $ void $ globalbuf activitysig @@ -439,7 +429,6 @@ bufferWriter p ts = do mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts return ok when ok $ do - hPutStrLn stderr $ show ("bufferWriter saving in global buffer", showProc p) -- add all of the command's buffered output to the -- global output buffer, atomically bs <- forM ts $ \(outh, buf, _bufsig, _bufend) -> -- cgit v1.2.3 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') 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 From 30f91cb5490f9cf40e5570e061c4bfedb1ae2ee4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:45:54 -0400 Subject: debugging --- src/System/Console/Concurrent/Internal.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index 985bc130..5b9cf454 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -31,6 +31,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Control.Applicative import Prelude +import System.Log.Logger import Utility.Monad import Utility.Exception @@ -286,18 +287,30 @@ fgProcess p = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock registerOutputThread + debug ["fgProcess", showProc p] -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h unregisterOutputThread dropOutputLock + debug ["fgProcess done", showProc p] return (toConcurrentProcessHandle r) + +debug :: [String] -> IO () +debug = debugM "concurrent-output" . unwords + +showProc :: P.CreateProcess -> String +showProc = go . P.cmdspec + where + go (P.ShellCommand s) = s + go (P.RawCommand c ps) = show (c, ps) #ifndef mingw32_HOST_OS bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) bgProcess p = do (toouth, fromouth) <- pipe (toerrh, fromerrh) <- pipe + debug ["bgProcess", showProc p] let p' = p { P.std_out = rediroutput (P.std_out p) toouth , P.std_err = rediroutput (P.std_err p) toerrh -- cgit v1.2.3 From e80c94b262870db031fd6714113dca7a19f29671 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:54:28 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index 5b9cf454..ada55e83 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -297,7 +297,7 @@ fgProcess p = do return (toConcurrentProcessHandle r) debug :: [String] -> IO () -debug = debugM "concurrent-output" . unwords +debug = hPutStrLn stderr . unwords showProc :: P.CreateProcess -> String showProc = go . P.cmdspec -- cgit v1.2.3 From 9e748e9f0d879bd58618f8a9ec48bd1c2e25ab65 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 15:54:52 -0400 Subject: back --- src/System/Console/Concurrent/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index ada55e83..5b9cf454 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -297,7 +297,7 @@ fgProcess p = do return (toConcurrentProcessHandle r) debug :: [String] -> IO () -debug = hPutStrLn stderr . unwords +debug = debugM "concurrent-output" . unwords showProc :: P.CreateProcess -> String showProc = go . P.cmdspec -- cgit v1.2.3