[Haskell] Safe forking question

[Chris Kuklewicz]

In response to question by Cat Dancer <cat at catdancer.ws> I wrote a few tests of
sending asynchronous signal to a thread using GHC 6.6

The goal was to run a child thread via forkIO and use handle or finally to respond
to the thread's demise.

Unfortunately, it seems that there is an irreducible window where this fails.  The
forkIO returns but any exception handlers such as block/handle/catch/finally are
not in place yet.

So this fails:

> module Main where
> 
> import Control.Exception
> import Control.Concurrent
> import Control.Concurrent.STM
> 
> forever x = x >> forever x
> 
> count tv = do
>   val <- takeTMVar tv
>   putTMVar tv $! (succ val)
>   return val
> 
> -- Capture idiom of notifying a new MVar when a thread is finished
> fork todo = do
>   doneMVar <- newEmptyMVar
>   tid <- block $ forkIO $ block $ handle (\e -> print ("Exception",e) >> throw e)
>                                          (finally (unblock todo) 
>                                                   (print "dying!" >> putMVar doneMVar ()))
>   return (doneMVar,tid)
> 
> spawn = do
>   tv <- atomically (newTMVar 0)
>   fork . forever $ atomically (count tv) >>= print
> 
> kill (mv,tid) = do
>   -- yield
>   print "killing.."
>   killThread tid
>   print "..checking corpse.."
>   readMVar mv
>   print "..confirmed dead"
> 
> main = spawn >>= kill

On my system, the above sends the killThread and destroys the thread before the
handle or finally are setup, so the child thread never prints anything and never
runs the "putMVar doneMVar ()".

If I uncomment the yield statement then the child thread does start executing and
the handle and finally work as desired.

This makes it impossible to reliably do anything with the child thread.  I cannot
discern between a living and dead child thread at all, as there is way to know if
it is waiting to be scheduled or if it has been killed waiting to be scheduled.

The get/setUncaughtExceptionHandler does not seem to be inherited by the child thread,
so this was not a useful guard.

The best thing I can come up with is the ugly code:

> fork todo = block $ do
>   doneVar <- atomically (newEmptyTMVar)
>   let putStarted = atomically (putTMVar doneVar False)
>       putStopped = atomically (tryTakeTMVar doneVar >> putTMVar doneVar True)
>   tid <- forkIO $ block $ (finally (putStarted >> unblock todo) putStopped)
>   yield
>   atomically $ do
>     value <- takeTMVar doneVar
>     when value (putTMVar doneVar True)
>   return (doneVar,tid)

This does not return the ThreadId until the finally clause has started running.  But if
the thread is killed by any external force before getting that far then the main thread
will hang on the "takeTMVar doneVar".

Is there any remotely better way of forking a child with an exception handler?

-- 
Chris