System/Event/Thread.hs

   1 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
   2
   3 module System.Event.Thread
   4     (
   5       ensureIOManagerIsRunning
   6     , threadWaitRead
   7     , threadWaitWrite
   8     , closeFd
   9     , threadDelay
  10     , registerDelay
  11     ) where
  12
  13 import Control.Exception (SomeException, catch, throw)
  14 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
  15 import Data.Maybe (Maybe(..))
  16 import Foreign.C.Error (eBADF, errnoToIOError)
  17 import Foreign.Ptr (Ptr)
  18 import GHC.Base
  19 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
  20                       labelThread, modifyMVar_, newTVar, sharedCAF,
  21                       threadStatus, writeTVar)
  22 import GHC.IO.Exception (ioError)
  23 import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
  24 import GHC.Real (fromIntegral)
  25 import System.Event.Internal (eventIs, evtClose)
  26 import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
  27                              new, registerFd, unregisterFd_, registerTimeout)
  28 import qualified System.Event.Manager as M
  29 import System.IO.Unsafe (unsafePerformIO)
  30 import System.Posix.Types (Fd)
  31
  32 -- | Suspends the current thread for a given number of microseconds
  33 -- (GHC only).
  34 --
  35 -- There is no guarantee that the thread will be rescheduled promptly
  36 -- when the delay has expired, but the thread will never continue to
  37 -- run /earlier/ than specified.
  38 threadDelay :: Int -> IO ()
  39 threadDelay usecs = do
  40   Just mgr <- readIORef eventManager
  41   m <- newEmptyMVar
  42   reg <- registerTimeout mgr usecs (putMVar m ())
  43   takeMVar m `catch` \(e::SomeException) ->
  44     M.unregisterTimeout mgr reg >> throw e
  45
  46 -- | Set the value of returned TVar to True after a given number of
  47 -- microseconds. The caveats associated with threadDelay also apply.
  48 --
  49 registerDelay :: Int -> IO (TVar Bool)
  50 registerDelay usecs = do
  51   t <- atomically $ newTVar False
  52   Just mgr <- readIORef eventManager
  53   _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
  54   return t
  55
  56 -- | Block the current thread until data is available to read from the
  57 -- given file descriptor.
  58 --
  59 -- This will throw an 'IOError' if the file descriptor was closed
  60 -- while this thread is blocked.
  61 threadWaitRead :: Fd -> IO ()
  62 threadWaitRead = threadWait evtRead
  63 {-# INLINE threadWaitRead #-}
  64
  65 -- | Block the current thread until the given file descriptor can
  66 -- accept data to write.
  67 --
  68 -- This will throw an 'IOError' if the file descriptor was closed
  69 -- while this thread is blocked.
  70 threadWaitWrite :: Fd -> IO ()
  71 threadWaitWrite = threadWait evtWrite
  72 {-# INLINE threadWaitWrite #-}
  73
  74 -- | Close a file descriptor in a concurrency-safe way.
  75 --
  76 -- Any threads that are blocked on the file descriptor via
  77 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
  78 -- IO exceptions thrown.
  79 closeFd :: (Fd -> IO ())        -- ^ Action that performs the close.
  80         -> Fd                   -- ^ File descriptor to close.
  81         -> IO ()
  82 closeFd close fd = do
  83   Just mgr <- readIORef eventManager
  84   M.closeFd mgr close fd
  85
  86 threadWait :: Event -> Fd -> IO ()
  87 threadWait evt fd = do
  88   m <- newEmptyMVar
  89   Just mgr <- readIORef eventManager
  90   reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
  91   evt' <- takeMVar m `catch` \(e::SomeException) ->
  92             unregisterFd_ mgr reg >> throw e
  93   if evt' `eventIs` evtClose
  94     then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
  95     else return ()
  96
  97 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
  98     getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
  99
 100 eventManager :: IORef (Maybe EventManager)
 101 eventManager = unsafePerformIO $ do
 102     em <- newIORef Nothing
 103     sharedCAF em getOrSetSystemEventThreadEventManagerStore
 104 {-# NOINLINE eventManager #-}
 105
 106 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
 107     getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
 108
 109 {-# NOINLINE ioManager #-}
 110 ioManager :: MVar (Maybe ThreadId)
 111 ioManager = unsafePerformIO $ do
 112    m <- newMVar Nothing
 113    sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
 114
 115 ensureIOManagerIsRunning :: IO ()
 116 ensureIOManagerIsRunning
 117   | not threaded = return ()
 118   | otherwise = modifyMVar_ ioManager $ \old -> do
 119   let create = do
 120         !mgr <- new
 121         writeIORef eventManager $ Just mgr
 122         !t <- forkIO $ loop mgr
 123         labelThread t "IOManager"
 124         return $ Just t
 125   case old of
 126     Nothing            -> create
 127     st@(Just t) -> do
 128       s <- threadStatus t
 129       case s of
 130         ThreadFinished -> create
 131         ThreadDied     -> create
 132         _other         -> return st
 133
 134 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool