[commit: base] master: Implement faster System.Timeout.timeout for the threaded RTS. (31153f1)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

https://github.com/ghc/packages-base/commit/31153f1e06ad05002d1a199d9c45a36fcbbaf033

>---------------------------------------------------------------

commit 31153f1e06ad05002d1a199d9c45a36fcbbaf033
Author: Bertram Felgenhauer <int-e at gmx.de>
Date:   Thu Mar 7 02:19:28 2013 +0100

    Implement faster System.Timeout.timeout for the threaded RTS.
    
    The basic idea is to use the Timer Manager rather than spawning an
    auxilliary thread to handle timeouts; this was proposed by Bas van Dijk
    two years ago (#4963), and recently by Herbert Valerio. The key idea
    to make this work is to spawn an auxilliary thread for the delivery
    of the Timeout exception. This idea as well as most of the code is due
    to Akio Takano.

>---------------------------------------------------------------

 System/Timeout.hs |   33 +++++++++++++++++++++++++++++++++
 1 files changed, 33 insertions(+), 0 deletions(-)

diff --git a/System/Timeout.hs b/System/Timeout.hs
index be44ba3..869b85c 100644
--- a/System/Timeout.hs
+++ b/System/Timeout.hs
@@ -26,12 +26,16 @@ module System.Timeout ( timeout ) where
 
 #ifdef __GLASGOW_HASKELL__
 import Control.Concurrent
+import Control.Concurrent.MVar
+import GHC.Event           (getSystemTimerManager,
+                            registerTimeout, unregisterTimeout)
 import Control.Exception   (Exception(..), handleJust, bracket,
                             uninterruptibleMask_,
                             asyncExceptionToException,
                             asyncExceptionFromException)
 import Data.Typeable
 import Data.Unique         (Unique, newUnique)
+import Control.Monad
 
 -- An internal type that is thrown as a dynamic exception to
 -- interrupt the running IO computation when the timeout has
@@ -84,6 +88,35 @@ timeout :: Int -> IO a -> IO (Maybe a)
 timeout n f
     | n <  0    = fmap Just f
     | n == 0    = return Nothing
+    | rtsSupportsBoundThreads = 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
+                    v <- tryPutMVar lock =<< myThreadId
+                    when v $ 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))
     | otherwise = do
         pid <- myThreadId
         ex  <- fmap Timeout newUnique