Is this a concurrency bug in base?

[Jean-Marie Gaillourdet]

Hi, 

I've continued my search for a proper workaround. Again, I did find some unexpected results. See below.

On 09.10.2011, at 17:56, wagnerdm at seas.upenn.edu wrote:

> Quoting Jean-Marie Gaillourdet <jmg at gaillourdet.net>:
> 
>> That sounds plausible. Do you see any workaround? Perhaps repeatedly evaluating typeOf?
> 
> If there's a concurrency bug, surely the workaround is to protect calls to the non-thread-safe function with a lock.
> 
>  typeOfWorkaround lock v = do
>      () <- takeMVar lock
>      x <- evaluate (typeOf v)
>      putMVar lock ()
>      return x
> 
> ~d

This is my previous program with your workaround, it is also attached as TypeRepEqLock.hs

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Typeable
import System.IO.Unsafe

main :: IO ()
main =
do { fin1 <- newEmptyMVar
  ; fin2 <- newEmptyMVar

  ; forkIO $ typeOf' () >>= putMVar fin1 
  ; forkIO $ typeOf' () >>= putMVar fin2 

  ; t1 <- takeMVar fin1
  ; t2 <- takeMVar fin2
  ; if (t1 /= t2)
      then putStrLn $ "typeOf " ++ show t1 ++ " /= typeOf " ++ show t2
      else putStrLn "Ok"
  }


{-# NOINLINE lock #-}
lock :: MVar ()
lock = unsafePerformIO $ newMVar ()

-- Ugly workaround to http://hackage.haskell.org/trac/ghc/ticket/5540
typeOf' :: Typeable a => a -> IO TypeRep
typeOf' x =
do { () <- takeMVar lock
  ; t <- evaluate $ typeOf x
  ; putMVar lock ()
  ; return t
  }


Compile and execute:

$ ghc-7.0.3 -threaded -rtsopts TypeRepEqLock.hs
<snip>
$ while true ; do ./TypeRepEqLock +RTS -N ; done
Ok
Ok
Ok
Ok
Ok
Ok
Ok
Ok
Ok
TypeRepEqLock: thread blocked indefinitely in an MVar operation
Ok
Ok
Ok
^C^C

I'm sorry but I don't see how this program could ever deadlock, unless there is some more locking in typeOf and (==) on TypeReps. 

On the other side, my admittedly ugly workaround works fine for hours and hours.

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Typeable

main :: IO ()
main =
do { fin1 <- newEmptyMVar
  ; fin2 <- newEmptyMVar

  ; forkIO $ return (typeOf' ()) >>= evaluate >>= putMVar fin1 
  ; forkIO $ return (typeOf' ()) >>= evaluate >>= putMVar fin2 

  ; t1 <- takeMVar fin1
  ; t2 <- takeMVar fin2
  ; if (t1 /= t2)
      then putStrLn $ "typeOf " ++ show t1 ++ " /= typeOf " ++ show t2
      else putStrLn "Ok"
  }

typeOf' val
  | t1 == t2 = t1
  | otherwise = typeOf' val
where
  t1 = typeOf'' val
  t2 = typeOf''' val
{-# NOINLINE typeOf' #-}


typeOf'' x = typeOf x
{-# NOINLINE typeOf'' #-}
typeOf''' x = typeOf x
{-# NOINLINE typeOf''' #-}


$ ghc-7.0.3 -threaded -rtsopts TypeRepEq.hs
<snip>
$ while true ; do ./TypeRepEq +RTS -N ; done
Ok
Ok
Ok
Ok
Ok
Ok
…

Any hints how to avoid the "thread blocked indefinitely in an MVar operation" exception?

Cheers,
Jean


-------------- next part --------------
A non-text attachment was scrubbed...
Name: TypeRepEqLock.hs
Type: application/octet-stream
Size: 765 bytes
Desc: not available
URL: <http://www.haskell.org/pipermail/glasgow-haskell-users/attachments/20111012/9d8d3271/attachment.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: TypeRepEq.hs
Type: application/octet-stream
Size: 730 bytes
Desc: not available
URL: <http://www.haskell.org/pipermail/glasgow-haskell-users/attachments/20111012/9d8d3271/attachment-0001.obj>