From 0d721d5c34f98a7ea8fe3a44a883100d2d6f27a3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 1 Nov 2015 17:13:56 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) (limited to 'src/System') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index ef308f7d..55290921 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -179,32 +179,24 @@ waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode waitForProcessConcurrent (ConcurrentProcessHandle h) = checkexit where checkexit = maybe waitsome return =<< P.getProcessExitCode h - waitsome = maybe checkexit return =<< bracket lock unlock go + waitsome = maybe checkexit return =<< bracket_ lock unlock go + lock = atomically $ putTMVar lck () + unlock = atomically $ takeTMVar lck lck = waitForProcessLock globalOutputHandle - lock = atomically $ tryPutTMVar lck () - unlock True = atomically $ takeTMVar lck - unlock False = return () - go True = do + go = do let v = processWaiters globalOutputHandle l <- atomically $ readTMVar v if null l -- Avoid waitAny [] which blocks forever; then Just <$> P.waitForProcess h else do - -- Wait for any of the running + -- Wait for the first of all the running -- processes to exit. It may or may not -- be the one corresponding to the -- ProcessHandle. If it is, -- getProcessExitCode will succeed. void $ tryIO $ waitAny l return Nothing - go False = do - -- Another thread took the lck first. Wait for that thread to - -- wait for one of the running processes to exit. - atomically $ do - putTMVar lck () - takeTMVar lck - return Nothing -- Registers an action that waits for a process to exit, -- adding it to the processWaiters list, and removing it once the action -- cgit v1.2.3