[Haskell-cafe] Faster timeout but is it correct?

[Bas van Dijk]

I made a slight modification and now it runs 16 times faster than the original:

timeout :: Int -> IO a -> IO (Maybe a)
timeout n f
    | n <  0    = fmap Just f
    | n == 0    = return Nothing
    | otherwise = do
        myTid <- myThreadId
        timeoutEx  <- fmap Timeout newUnique
        uninterruptibleMask $ \restore -> do
          tid <- restore $ forkIO $ threadDelay n >> throwTo myTid timeoutEx
          (restore (fmap Just f) >>= \mb -> killThread tid >> return mb)
            `catch` \e ->
                case fromException e of
                  Just timeoutEx' | timeoutEx' == timeoutEx -> return Nothing
                  _ -> killThread tid >> throwIO e

However I may have noticed a deadlock in the previous version (maybe
this version has it also). The deadlock occurred when running the
externalException benchmark:

externalException = do
  (tid, wait) <- fork $ timeout oneSec (threadDelay oneSec)
  threadDelay 500
  throwTo tid MyException
  r <- wait
  case r of
    Left e | Just MyException <- fromException e -> return ()
    _ -> error "MyException should have been thrown!"

data MyException = MyException deriving (Show, Typeable)
instance Exception MyException

-- Fork a thread and return a computation that waits for its result.
-- Equivalent to forkIO from the threads package.
fork :: IO a -> IO (ThreadId, IO (Either SomeException a))
fork a = do
  res <- newEmptyMVar
  tid <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res
  return (tid, readMVar res)

So please review this carefully.

Bas