[GHC] #10241: BlockedIndefinitelyOnMVar thrown to the thread which is not blocked indefinitely

[GHC]

#10241: BlockedIndefinitelyOnMVar thrown to the thread which is not blocked
indefinitely
-------------------------------------+-------------------------------------
              Reporter:  asukamirai  |             Owner:  simonmar
                  Type:  bug         |            Status:  new
              Priority:  normal      |         Milestone:
             Component:  Runtime     |           Version:  7.8.3
  System                             |  Operating System:  Unknown/Multiple
              Keywords:              |   Type of failure:  Incorrect result
          Architecture:  x86_64      |  at runtime
  (amd64)                            |        Blocked By:
             Test Case:              |   Related Tickets:
              Blocking:              |
Differential Revisions:              |
-------------------------------------+-------------------------------------
 BlockedIndefinatelyOnMVar exception is thrown to the main thread in below
 source code although the thread is not blocked indefinitely.

 {{{#!hs
 module Main where

 import qualified Control.Concurrent.MVar as MV
 import qualified Control.Concurrent      as CC
 import qualified Control.Exception       as E

 main :: IO ()
 main = do
     -- call this thread "threadA"
     mvar1 <- MV.newEmptyMVar :: IO (MV.MVar ())
     mvar2 <- MV.newEmptyMVar :: IO (MV.MVar ())
     _ <- CC.forkIO $ do
         -- call this thread "threadB"
         MV.takeMVar mvar1 `E.catch` errorHandler1
         putStrLn "after error catch"
         CC.threadDelay 1000000
         MV.putMVar mvar2 ()
         putStrLn "after putMVar"
     MV.readMVar mvar2 `E.catch` errorHandler2
     putStrLn "after readMVar"
     CC.threadDelay 5000000
     where
         errorHandler1 :: E.BlockedIndefinitelyOnMVar -> IO ()
         errorHandler1 e = putStrLn $ "errorHandler1 : " ++ show e
         errorHandler2 :: E.BlockedIndefinitelyOnMVar -> IO ()
         errorHandler2 e = putStrLn $ "errorHandler2 : " ++ show e
 }}}

 Save above as "mvar.hs" and run by ghc as below.

 {{{
 > runhaskell mvar.hs
 errorHandler1 : thread blocked indefinitely in an MVar operation
 errorHandler2 : thread blocked indefinitely in an MVar operation
 after error catch
 after readMVar
 after putMVar
 }}}

 BlockedIndefinitelyOnMVar thrown for mvar1 is correct. It will be caught
 by errorHandler1 and "threadB" can continue to put the value to mvar2. It
 means that "threadA" can wait for the value of mvar2 and it is not blocked
 indefinately.
 However, BlockedIndefinitelyOnMVar is thrown for mvar2 on "threadA" before
 "threadB" puts value to the mvar2. I think it is incorrect.

 ----

 I tested another case that adding "CC.threadDelay 10000000" before
 "readMVar" as below.

 {{{#!hs
 module Main where

 import qualified Control.Concurrent.MVar as MV
 import qualified Control.Concurrent      as CC
 import qualified Control.Exception       as E

 main :: IO ()
 main = do
     -- call this thread "threadA"
     mvar1 <- MV.newEmptyMVar :: IO (MV.MVar ())
     mvar2 <- MV.newEmptyMVar :: IO (MV.MVar ())
     _ <- CC.forkIO $ do
         -- call this thread "threadB"
         MV.takeMVar mvar1 `E.catch` errorHandler1
         putStrLn "after error catch"
         CC.threadDelay 1000000
         MV.putMVar mvar2 ()
         putStrLn "after putMVar"
     CC.threadDelay 10000000 -- <-- this line is added
     MV.readMVar mvar2 `E.catch` errorHandler2
     putStrLn "after readMVar"
     CC.threadDelay 5000000
     where
         errorHandler1 :: E.BlockedIndefinitelyOnMVar -> IO ()
         errorHandler1 e = putStrLn $ "errorHandler1 : " ++ show e
         errorHandler2 :: E.BlockedIndefinitelyOnMVar -> IO ()
         errorHandler2 e = putStrLn $ "errorHandler2 : " ++ show e
 }}}

 And it will run correctly (BlockedIndefinitelyOnMVar is not thrown for
 mvar2).

 {{{
 > runhaskell mvar.hs
 errorHandler1 : thread blocked indefinitely in an MVar operation
 after error catch
 after putMVar
 after readMVar
 }}}

 ----

 I found this behavior is same on STM / BlockedIndefinitelyOnSTM.

 {{{#!hs
 module Main where

 import qualified Control.Concurrent.STM as STM
 import qualified Control.Concurrent     as CC
 import qualified Control.Exception      as E

 main :: IO ()
 main = do
     tmv1 <- STM.newEmptyTMVarIO :: IO (STM.TMVar ())
     tmv2 <- STM.newEmptyTMVarIO :: IO (STM.TMVar ())
     _ <- CC.forkIO $ do
         STM.atomically (STM.takeTMVar tmv1) `E.catch` errorHandler1
         putStrLn "after error catch"
         CC.threadDelay 1000000
         STM.atomically $ STM.putTMVar tmv2 ()
         putStrLn "after putTMVar"
     STM.atomically (STM.readTMVar tmv2) `E.catch` errorHandler2
     putStrLn "after readTMVar"
     CC.threadDelay 5000000
     where
         errorHandler1 :: E.BlockedIndefinitelyOnSTM -> IO ()
         errorHandler1 e = putStrLn $ "errorHandler1 : " ++ show e
         errorHandler2 :: E.BlockedIndefinitelyOnSTM -> IO ()
         errorHandler2 e = putStrLn $ "errorHandler2 : " ++ show e
 }}}

 {{{
 > runhaskell stm.hs
 errorHandler1 : thread blocked indefinitely in an STM transaction
 errorHandler2 : thread blocked indefinitely in an STM transaction
 after error catch
 after readTMVar
 after putTMVar
 }}}

 ----

 I tested this in below versions/OSs and got same result (exception thrown
 for mvar2/tmv2).

 ghc7.8.3 on Windows7
 ghc7.8.3 on lubuntu14.04 on VirtualBox on Windows7
 ghc7.8.4 on lubuntu14.04 on VirtualBox on Windows7
 ghc7.10.1 on lubuntu14.04 on VirtualBox on Windows7

 Similar report https://ghc.haskell.org/trac/ghc/ticket/8804 found but not
 the same.
 (In this case, the reference to the MVar is not weak)

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/10241>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler