Deadlock in the threaded RTS

The following program deadlocks with high probability:

-- ghc -rtsopts -threaded -debug performGC.hs 
-- ./performGC 1000 +RTS -qg -N2

-- -qg turns off parallel GC, needed to trigger the bug
-- -N2 or greater is needed

module Main (main) where

import System.Environment
import Control.Concurrent
import Control.Exception
import Control.Monad
import System.Random
import System.Mem
import qualified Data.Set as Set

main = do
  [n] <- getArgs
  forkIO $ doSomeWork
  forM [1..read n] $ \n -> do print n; threadDelay 1000; performMinorGC

doSomeWork :: IO ()
doSomeWork = forever $ do
  ns <- replicateM 10000 randomIO :: IO [Int]
  ms <- replicateM 1000 randomIO
  let set = Set.fromList ns
      elems = filter (`Set.member` set) ms
 evaluate $ sum elems

There are a few ways that this bug can be triggered:

• At shutdown, when there are other threads still running. This is how we first encountered it.
• Using performGC, as above. I think it's necessary to call it from a bound thread (e.g. the main thread) to get bad things to happen.
• I think forkProcess might also trigger it, but I haven't observed it.

I'm working on a fix.

Trac metadata

Trac field	Value
Version	7.10.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	highest
Resolution	Unresolved
Component	Runtime System
Test case
Differential revisions
BlockedBy
Related
Blocking
CC	niteria, simonmar
Operating system
Architecture