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