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 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 was blocked.  To safely close a file descriptor
  61 -- that has been used with 'threadWaitRead', use 'closeFdWith'.
  62 threadWaitRead :: Fd -> IO ()
  63 threadWaitRead = threadWait evtRead
  64 {-# INLINE threadWaitRead #-}
  65
  66 -- | Block the current thread until the given file descriptor can
  67 -- accept data to write.
  68 --
  69 -- This will throw an 'IOError' if the file descriptor was closed
  70 -- while this thread was blocked.  To safely close a file descriptor
  71 -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
  72 threadWaitWrite :: Fd -> IO ()
  73 threadWaitWrite = threadWait evtWrite
  74 {-# INLINE threadWaitWrite #-}
  75
  76 -- | Close a file descriptor in a concurrency-safe way.
  77 --
  78 -- Any threads that are blocked on the file descriptor via
  79 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
  80 -- IO exceptions thrown.
  81 closeFdWith :: (Fd -> IO ())        -- ^ Action that performs the close.
  82             -> Fd                   -- ^ File descriptor to close.
  83             -> IO ()
  84 closeFdWith close fd = do
  85   Just mgr <- readIORef eventManager
  86   M.closeFd mgr close fd
  87
  88 threadWait :: Event -> Fd -> IO ()
  89 threadWait evt fd = do
  90   m <- newEmptyMVar
  91   Just mgr <- readIORef eventManager
  92   reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
  93   evt' <- takeMVar m `catch` \(e::SomeException) ->
  94             unregisterFd_ mgr reg >> throw e
  95   if evt' `eventIs` evtClose
  96     then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
  97     else return ()
  98
  99 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
 100     getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
 101
 102 eventManager :: IORef (Maybe EventManager)
 103 eventManager = unsafePerformIO $ do
 104     em <- newIORef Nothing
 105     sharedCAF em getOrSetSystemEventThreadEventManagerStore
 106 {-# NOINLINE eventManager #-}
 107
 108 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
 109     getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
 110
 111 {-# NOINLINE ioManager #-}
 112 ioManager :: MVar (Maybe ThreadId)
 113 ioManager = unsafePerformIO $ do
 114    m <- newMVar Nothing
 115    sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
 116
 117 ensureIOManagerIsRunning :: IO ()
 118 ensureIOManagerIsRunning
 119   | not threaded = return ()
 120   | otherwise = modifyMVar_ ioManager $ \old -> do
 121   let create = do
 122         !mgr <- new
 123         writeIORef eventManager $ Just mgr
 124         !t <- forkIO $ loop mgr
 125         labelThread t "IOManager"
 126         return $ Just t
 127   case old of
 128     Nothing            -> create
 129     st@(Just t) -> do
 130       s <- threadStatus t
 131       case s of
 132         ThreadFinished -> create
 133         ThreadDied     -> create
 134         _other         -> return st
 135
 136 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool