Rename System.Event to GHC.Event

[ghc-base.git] / GHC / Event / Thread.hs

diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs
new file mode 100644 (file)
index 0000000..dbfb14f
--- /dev/null
+++ b/GHC/Event/Thread.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
+
+module GHC.Event.Thread
+    (
+      ensureIOManagerIsRunning
+    , threadWaitRead
+    , threadWaitWrite
+    , closeFdWith
+    , threadDelay
+    , registerDelay
+    ) where
+
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.Maybe (Maybe(..))
+import Foreign.C.Error (eBADF, errnoToIOError)
+import Foreign.Ptr (Ptr)
+import GHC.Base
+import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
+                      labelThread, modifyMVar_, newTVar, sharedCAF,
+                      threadStatus, writeTVar)
+import GHC.IO (mask_, onException)
+import GHC.IO.Exception (ioError)
+import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
+import GHC.Event.Internal (eventIs, evtClose)
+import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
+                             new, registerFd, unregisterFd_, registerTimeout)
+import qualified GHC.Event.Manager as M
+import System.IO.Unsafe (unsafePerformIO)
+import System.Posix.Types (Fd)
+
+-- | Suspends the current thread for a given number of microseconds
+-- (GHC only).
+--
+-- There is no guarantee that the thread will be rescheduled promptly
+-- when the delay has expired, but the thread will never continue to
+-- run /earlier/ than specified.
+threadDelay :: Int -> IO ()
+threadDelay usecs = mask_ $ do
+  Just mgr <- readIORef eventManager
+  m <- newEmptyMVar
+  reg <- registerTimeout mgr usecs (putMVar m ())
+  takeMVar m `onException` M.unregisterTimeout mgr reg
+
+-- | Set the value of returned TVar to True after a given number of
+-- microseconds. The caveats associated with threadDelay also apply.
+--
+registerDelay :: Int -> IO (TVar Bool)
+registerDelay usecs = do
+  t <- atomically $ newTVar False
+  Just mgr <- readIORef eventManager
+  _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
+  return t
+
+-- | Block the current thread until data is available to read from the
+-- given file descriptor.
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread was blocked.  To safely close a file descriptor
+-- that has been used with 'threadWaitRead', use 'closeFdWith'.
+threadWaitRead :: Fd -> IO ()
+threadWaitRead = threadWait evtRead
+{-# INLINE threadWaitRead #-}
+
+-- | Block the current thread until the given file descriptor can
+-- accept data to write.
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread was blocked.  To safely close a file descriptor
+-- that has been used with 'threadWaitWrite', use 'closeFdWith'.
+threadWaitWrite :: Fd -> IO ()
+threadWaitWrite = threadWait evtWrite
+{-# INLINE threadWaitWrite #-}
+
+-- | Close a file descriptor in a concurrency-safe way.
+--
+-- Any threads that are blocked on the file descriptor via
+-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
+-- IO exceptions thrown.
+closeFdWith :: (Fd -> IO ())        -- ^ Action that performs the close.
+            -> Fd                   -- ^ File descriptor to close.
+            -> IO ()
+closeFdWith close fd = do
+  Just mgr <- readIORef eventManager
+  M.closeFd mgr close fd
+
+threadWait :: Event -> Fd -> IO ()
+threadWait evt fd = mask_ $ do
+  m <- newEmptyMVar
+  Just mgr <- readIORef eventManager
+  reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
+  evt' <- takeMVar m `onException` unregisterFd_ mgr reg
+  if evt' `eventIs` evtClose
+    then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
+    else return ()
+
+foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
+    getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
+
+eventManager :: IORef (Maybe EventManager)
+eventManager = unsafePerformIO $ do
+    em <- newIORef Nothing
+    sharedCAF em getOrSetSystemEventThreadEventManagerStore
+{-# NOINLINE eventManager #-}
+
+foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
+    getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
+
+{-# NOINLINE ioManager #-}
+ioManager :: MVar (Maybe ThreadId)
+ioManager = unsafePerformIO $ do
+   m <- newMVar Nothing
+   sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
+
+ensureIOManagerIsRunning :: IO ()
+ensureIOManagerIsRunning
+  | not threaded = return ()
+  | otherwise = modifyMVar_ ioManager $ \old -> do
+  let create = do
+        !mgr <- new
+        writeIORef eventManager $ Just mgr
+        !t <- forkIO $ loop mgr
+        labelThread t "IOManager"
+        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 eventManager
+          _ <- case mem of
+                 Nothing -> return ()
+                 Just em -> M.cleanup em
+          create
+        _other         -> return st
+
+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool