[commit: base] master: Separated the IO manager into a timer manager and a file IO manager. (d1461b2)

[Johan Tibell]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/d1461b2a8772392b258c2f532b25ce5d08186281

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

commit d1461b2a8772392b258c2f532b25ce5d08186281
Author: Andreas Voellmy <andreas.voellmy at gmail.com>
Date:   Thu Dec 20 00:41:00 2012 -0500

    Separated the IO manager into a timer manager and a file IO manager.
    
    This is a preliminary patch; ultimately the single file IO manager will be replaced by per-capability managers.

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

 GHC/Event.hs        |    3 +-
 GHC/Event/Thread.hs |   64 ++++++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 63 insertions(+), 4 deletions(-)

diff --git a/GHC/Event.hs b/GHC/Event.hs
index 257412f..0510409 100644
--- a/GHC/Event.hs
+++ b/GHC/Event.hs
@@ -14,6 +14,7 @@ module GHC.Event
 
       -- * Creation
     , getSystemEventManager
+    , getSystemTimerManager
 
       -- * Registering interest in I/O events
     , Event
@@ -36,5 +37,5 @@ module GHC.Event
     ) where
 
 import GHC.Event.Manager
-import GHC.Event.Thread (getSystemEventManager)
+import GHC.Event.Thread (getSystemEventManager, getSystemTimerManager)
 
diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs
index e685108..3cdbdd3 100644
--- a/GHC/Event/Thread.hs
+++ b/GHC/Event/Thread.hs
@@ -3,6 +3,7 @@
 
 module GHC.Event.Thread
     ( getSystemEventManager
+    , getSystemTimerManager
     , ensureIOManagerIsRunning
     , threadWaitRead
     , threadWaitWrite
@@ -13,6 +14,7 @@ module GHC.Event.Thread
     , registerDelay
     ) where
 
+import Control.Exception (finally)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (Maybe(..))
 import Foreign.C.Error (eBADF, errnoToIOError)
@@ -39,7 +41,7 @@ import System.Posix.Types (Fd)
 -- run /earlier/ than specified.
 threadDelay :: Int -> IO ()
 threadDelay usecs = mask_ $ do
-  mgr <- getSystemEventManager
+  mgr <- getSystemTimerManager
   m <- newEmptyMVar
   reg <- registerTimeout mgr usecs (putMVar m ())
   takeMVar m `onException` M.unregisterTimeout mgr reg
@@ -50,7 +52,7 @@ threadDelay usecs = mask_ $ do
 registerDelay :: Int -> IO (TVar Bool)
 registerDelay usecs = do
   t <- atomically $ newTVar False
-  mgr <- getSystemEventManager
+  mgr <- getSystemTimerManager
   _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
   return t
 
@@ -164,16 +166,40 @@ ioManager = unsafePerformIO $ do
    m <- newMVar Nothing
    sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
 
+getSystemTimerManager :: IO EventManager
+getSystemTimerManager = do 
+  Just mgr <- readIORef timerManager
+  return mgr
+
+foreign import ccall unsafe "getOrSetSystemTimerThreadEventManagerStore"
+    getOrSetSystemTimerThreadEventManagerStore :: Ptr a -> IO (Ptr a)
+
+timerManager :: IORef (Maybe EventManager)
+timerManager = unsafePerformIO $ do
+    em <- newIORef Nothing
+    sharedCAF em getOrSetSystemTimerThreadEventManagerStore
+{-# NOINLINE timerManager #-}
+
+foreign import ccall unsafe "getOrSetSystemTimerThreadIOManagerThreadStore"
+    getOrSetSystemTimerThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
+
+{-# NOINLINE timerManagerThreadVar #-}
+timerManagerThreadVar :: MVar (Maybe ThreadId)
+timerManagerThreadVar = unsafePerformIO $ do
+   m <- newMVar Nothing
+   sharedCAF m getOrSetSystemTimerThreadIOManagerThreadStore
+
 ensureIOManagerIsRunning :: IO ()
 ensureIOManagerIsRunning
   | not threaded = return ()
   | otherwise = do
       startIOManagerThread
+      startTimerManagerThread
 
 startIOManagerThread :: IO ()
 startIOManagerThread = modifyMVar_ ioManager $ \old -> do
   let create = do
-        !mgr <- new True
+        !mgr <- new False
         writeIORef eventManager $ Just mgr
         !t <- forkIO $ loop mgr
         labelThread t "IOManager"
@@ -197,4 +223,36 @@ startIOManagerThread = modifyMVar_ ioManager $ \old -> do
           create
         _other         -> return st
 
+startTimerManagerThread :: IO ()
+startTimerManagerThread = modifyMVar_ timerManagerThreadVar $ \old -> do
+  let shutdownEM = do
+        mem <- readIORef eventManager
+        case mem of
+          Nothing -> return ()
+          Just em -> M.shutdown em
+  let create = do
+        !mgr <- new True
+        writeIORef timerManager $ Just mgr
+        !t <- forkIO $ loop mgr `finally` shutdownEM
+        labelThread t "TimerManager"
+        return $ Just t
+  case old of
+    Nothing            -> create
+    st@(Just t) -> do
+      s <- threadStatus t
+      case s of
+        ThreadFinished -> create
+        ThreadDied     -> do 
+          -- Sanity check: if the thread has died, there is a chance
+          -- that event manager is still alive. This could happend during
+          -- the fork, for example. In this case we should clean up
+          -- open pipes and everything else related to the event manager.
+          -- See #4449
+          mem <- readIORef timerManager
+          _ <- case mem of
+                 Nothing -> return ()
+                 Just em -> M.cleanup em
+          create
+        _other         -> return st
+
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool