fix tricky race

Race between 2 calls to takeOutputLock'. The first call empties the
TMVar, and does some work to check it. Meanwhile, the second call could
sneak in, see it was empty, and call waitlock. Since waitlock used
tryTakeTMVar, that would not block it, and it would think it had the lock,
filling the TMVar. In the meantime, the first call could decide it had to
lock and go on to possibly cause trouble.

1 files changed, 6 insertions, 15 deletions

diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs
index 5535066f..3c072cf4 100644
--- a/src/Utility/ConcurrentOutput.hs
+++ b/src/Utility/ConcurrentOutput.hs
@@ -74,7 +74,7 @@ withLock a = do
 takeOutputLock' :: Bool -> IO Bool
 takeOutputLock' block = go =<< withLock tryTakeTMVar
   where
-	go Nothing = whenblock waitlock
+	go Nothing = whenblock waitlockchange
 	-- Something has the lock. It may be stale, so check it.
 	-- We must always be sure to fill the TMVar back with Just or Nothing.
 	go (Just orig) = case orig of
@@ -85,11 +85,7 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar
 				( havelock
 				, if block
 					then do
-						hPutStr stderr "WAITFORPROCESS in lock"
-						hFlush stderr
 						void $ P.waitForProcess h
-						hPutStr stderr "WAITFORPROCESS in lock done"
-						hFlush stderr
 						havelock
 					else do
 						withLock (`putTMVar` orig)
@@ -97,21 +93,16 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar
 				)
 		(Just GeneralLock) -> do
 			withLock (`putTMVar` orig)
-			whenblock waitlock
+			whenblock waitlockchange
 
 	havelock = do
 		withLock (`putTMVar` Just GeneralLock)
 		return True
 	
-	-- Wait for current lock holder (if any) to relinquish
-	-- it and take the lock for ourselves.
-	waitlock = withLock $ \l -> do
-		v <- tryTakeTMVar l
-		case v of
-			Just (Just _) -> retry
-			_ -> do
-				putTMVar l (Just GeneralLock)
-				return True
+	-- Wait for the lock to change, and try again.
+	waitlockchange = do
+		void $ withLock readTMVar
+		takeOutputLock' block
 	
 	whenblock a = if block then a else return False