darcs patch: forkChild, waitForChild, parIO, timeout

[Peter Simons]

Einar Karttunen writes:

 > The difference was quite large in very concurrent situations
 > when I did benchmarking earlier between my two implementations
 > [...]

I see you point. It is obvious that an implementation with two
forkIOs is probably slower than an implementation with one. I
would love to implement timeout the way you did, but my problem
is that it doesn't feel right to depend on Data.Typeable in
Control.Concurrent. I don't want to define a new dynamic
exception type in that module.

One solution could be to move timeout to a different module. Do
you have a suggestion? Where would you put your code?

Arguably, a timeout implementation that depends on asynchronous
exceptions could just as well expose the fact and signal timeouts
with said asynchronous exception. In that case, the signature
could be even simpler:

  data TimeoutError = TimeoutError deriving (Show, Typeable)
  type Microseconds = Int

  timeout :: Microseconds -> IO a -> IO a

Assuming that a timeout is a rare event which most probably
constitutes a fatal error condition for the I/O context, this
function is more comfortable to use.

The signature my implementation has right now,

  timeout :: Microseconds -> IO a -> IO (Maybe a)

..., forces the programmer to deal with a timeout condition
in-place. My impression is that code reliability is furthered by
making error conditions explicit, so I tend to prefer that kind
of signature. It is not a strong preference, however.

How do others feel about this topic?

By the way, I have created Trac ticket #980 for this proposal.

I have also had an interesting insight into the child thread
problem. I took exception forwarding out of the code because the
notion of child and parent threads felt insufficiently well
defined. Just because a thread started another one, it doesn't
mean that this particular thread is necessarily the correct error
handler for the child thread.

Now I realize: the thread responsible for handling the child
thread's errors is the one who accesses the child's return value.

This is one of the rare occasions where significant functionality
can be added by making the code simpler. :-)

  type AsyncMVar a = MVar (Either Exception a)

  data Async a = Child ThreadId (AsyncMVar a)

  forkAsync' :: IO a -> AsyncMVar a -> IO (Async a)
  forkAsync' f mv = fmap (\p -> Child p mv) (forkIO f')
    where
      f' = block (try f >>= tryPutMVar mv >> return ())

  forkAsync :: IO a -> IO (Async a)
  forkAsync f = newEmptyMVar >>= forkAsync' f

  throwToAsync :: Async a -> Exception -> IO ()
  throwToAsync (Child pid _) = throwTo pid

  killAsync :: Async a -> IO ()
  killAsync (Child pid _) = killThread pid

  isReadyAsync :: Async a -> IO Bool
  isReadyAsync (Child _ mv) = fmap not (isEmptyMVar mv)

  waitForAsync :: Async a -> IO a
  waitForAsync (Child _ sync) = fmap (either throw id) (readMVar sync)

  -- Run both computations in parallel and return the @a@ value
  -- of the computation that terminates first. An exception in
  -- either of the two computations aborts the entire parIO
  -- computation.

  parIO :: IO a -> IO a -> IO a
  parIO f g = do
    sync <- newEmptyMVar
    bracket
      (forkAsync' f sync)
      (killAsync)
      (\_ -> bracket
               (forkAsync' g sync)
               (killAsync)
               (waitForAsync))

  type MicroSeconds = Int

  timeout :: MicroSeconds -> IO a -> IO (Maybe a)
  timeout n f
    | n < 0     = fmap Just f
    | n == 0    = return Nothing
    | otherwise = (fmap Just f) `parIO` (threadDelay n >> return Nothing)

The need for "a" to be a Monoid is gone, and exceptions propagate
nicely too.

Peter