以下、timeout の抜粋です。
最近の timeout は、TimeManagerを使い「時間切れのどきだけ」スレッドが作られます(forkIOWithUnmask)。
(gitでlog を読むと高野さんのアイディアらしい。)
handleTimeoutで作られるこのスレッドは、どこにもブロックする箇所がないので、すぐに消滅しそうです。
しかし、cleanupTimeoutでわざわざkillThreadしています。
このkillThreadは必要なのでしょうか？
最近の timeout は、TimeManagerを使い「時間切れのどきだけ」スレッドが作られます(forkIOWithUnmask)。
(gitでlog を読むと高野さんのアイディアらしい。)
handleTimeoutで作られるこのスレッドは、どこにもブロックする箇所がないので、すぐに消滅しそうです。
しかし、cleanupTimeoutでわざわざkillThreadしています。
このkillThreadは必要なのでしょうか？
Haskell
timeout :: Int -> IO a -> IO (Maybe a)
timeout n f
| n < 0 = fmap Just f
| n == 0 = return Nothing
| otherwise = do
-- In the threaded RTS, we use the Timer Manager to delay the
-- (fairly expensive) 'forkIO' call until the timeout has expired.
--
-- An additional thread is required for the actual delivery of
-- the Timeout exception because killThread (or another throwTo)
-- is the only way to reliably interrupt a throwTo in flight.
pid <- myThreadId
ex <- fmap Timeout newUnique
tm <- getSystemTimerManager
-- 'lock' synchronizes the timeout handler and the main thread:
-- * the main thread can disable the handler by writing to 'lock';
-- * the handler communicates the spawned thread's id through 'lock'.
-- These two cases are mutually exclusive.
lock <- newEmptyMVar
let handleTimeout = do
v <- isEmptyMVar lock
when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do
v2 <- tryPutMVar lock =<< myThreadId
when v2 $ throwTo pid ex
cleanupTimeout key = uninterruptibleMask_ $ do
v <- tryPutMVar lock undefined
if v then unregisterTimeout tm key
else takeMVar lock >>= killThread
handleJust (\e -> if e == ex then Just () else Nothing)
(\_ -> return Nothing)
(bracket (registerTimeout tm n handleTimeout)
cleanupTimeout
(\_ -> fmap Just f))