forkProcess does not acquire global handle locks

The global I/O handles (stdout, stdin, stderr) all make use an MVar wrapping a Handle__, and many I/O functions temporarily take this MVar (for instance, functions such as hPutStr include a call to wantWritableHandle, which uses withHandle_', which involves taking the MVar, executing some operation, and then putting the MVar back).

Suppose we have a program consisting of two threads A and B, where thread A is doing I/O. If thread B does a call to forkProcess then it is possible that the fork() happens at the point that A has just taken, say, the MVar for stdout. If this happens, every use of stdout in the child process will now forever deadlock.

This is not a theoretical scenario. The example code reported by Michael Snoyman a few years ago

http://www.haskell.org/pipermail/haskell-cafe/2012-October/103922.html

exhibits precisely this behaviour: the child process deadlocks (not all the the time, but very frequently), exactly because of this problem.

In forkProcess we avoid this sort of situation for all of the global RTS locks by acquiring the lock just before the call to fork(), and then releasing the lock in the parent again and re-initializing the lock in the child. But there are no provisions for Haskell-land locks such as the above MVar.

In principle we can work around this problem entirely in user-land. Here is a modified version of Michael's code that does not deadlock (at least, it never has in my tests..), that basically takes the same acquire-release*2 trick that forkProcess does for RTS locks in the lines marked (*):

import System.Posix.Process (forkProcess, getProcessID)
import Control.Concurrent (forkIO, threadDelay)
import System.IO (hFlush, stdout)
import System.Posix.Signals (signalProcess, sigKILL)
import Control.Exception (finally)

import Control.Concurrent
import GHC.IO.Handle.Types
import System.IO

main :: IO ()
main = do
    mapM_ spawnChild [1..9]

    ioLock <- lockIO -- (*)
    child <- forkProcess $ do
        unlockIO ioLock -- (*)
        putStrLn "starting child"
        hFlush stdout
        loop "child" 0
    unlockIO ioLock -- (*)

    print ("child pid", child)
    hFlush stdout

    -- I've commented out the "finally" so that the zombie process stays alive,
    -- to prove that it was actually created.
    loop "parent" 0 -- `finally` signalProcess sigKILL child

spawnChild :: Int -> IO ()
spawnChild i = do
    _ <- forkIO $ loop ("spawnChild " ++ show i) 0
    return ()

loop :: String -> Int -> IO ()
loop msg i = do
    pid <- getProcessID
    print (pid, msg, i)
    hFlush stdout
    threadDelay 1000000
    loop msg (i + 1)

--------------------------------------------------------------------------------

lockIO :: IO Handle__ 
lockIO = 
  case stdout of
    FileHandle _ m -> takeMVar m 

unlockIO :: Handle__ -> IO ()
unlockIO hout = 
  case stdout of
    FileHandle _ m -> putMVar m hout

I guess that any global MVar or TVar is suspect when using forkProcess.

Trac metadata

Trac field	Value
Version	7.8.2
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture