System/Event/Thread.hs

   1 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
   2
   3 module System.Event.Thread
   4     (
   5       ensureIOManagerIsRunning
   6     , threadWaitRead
   7     , threadWaitWrite
   8     , closeFdWith
   9     , threadDelay
  10     , registerDelay
  11     ) where
  12
  13 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
  14 import Data.Maybe (Maybe(..))
  15 import Foreign.C.Error (eBADF, errnoToIOError)
  16 import Foreign.Ptr (Ptr)
  17 import GHC.Base
  18 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
  19                       labelThread, modifyMVar_, newTVar, sharedCAF,
  20                       threadStatus, writeTVar)
  21 import GHC.IO (mask_, onException)
  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 = mask_ $ do
  40   Just mgr <- readIORef eventManager
  41   m <- newEmptyMVar
  42   reg <- registerTimeout mgr usecs (putMVar m ())
  43   takeMVar m `onException` M.unregisterTimeout mgr reg
  44
  45 -- | Set the value of returned TVar to True after a given number of
  46 -- microseconds. The caveats associated with threadDelay also apply.
  47 --
  48 registerDelay :: Int -> IO (TVar Bool)
  49 registerDelay usecs = do
  50   t <- atomically $ newTVar False
  51   Just mgr <- readIORef eventManager
  52   _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
  53   return t
  54
  55 -- | Block the current thread until data is available to read from the
  56 -- given file descriptor.
  57 --
  58 -- This will throw an 'IOError' if the file descriptor was closed
  59 -- while this thread was blocked.  To safely close a file descriptor
  60 -- that has been used with 'threadWaitRead', use 'closeFdWith'.
  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 was blocked.  To safely close a file descriptor
  70 -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
  71 threadWaitWrite :: Fd -> IO ()
  72 threadWaitWrite = threadWait evtWrite
  73 {-# INLINE threadWaitWrite #-}
  74
  75 -- | Close a file descriptor in a concurrency-safe way.
  76 --
  77 -- Any threads that are blocked on the file descriptor via
  78 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
  79 -- IO exceptions thrown.
  80 closeFdWith :: (Fd -> IO ())        -- ^ Action that performs the close.
  81             -> Fd                   -- ^ File descriptor to close.
  82             -> IO ()
  83 closeFdWith close fd = do
  84   Just mgr <- readIORef eventManager
  85   M.closeFd mgr close fd
  86
  87 threadWait :: Event -> Fd -> IO ()
  88 threadWait evt fd = mask_ $ do
  89   m <- newEmptyMVar
  90   Just mgr <- readIORef eventManager
  91   reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
  92   evt' <- takeMVar m `onException` unregisterFd_ mgr reg
  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