System/Event/Thread.hs

   1 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
   2
   3 module System.Event.Thread
   4     (
   5       ensureIOManagerIsRunning
   6     , threadWaitRead
   7     , threadWaitWrite
   8     , threadDelay
   9     , registerDelay
  10     ) where
  11
  12 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
  13 import Data.Maybe (Maybe(..))
  14 import Foreign.Ptr (Ptr)
  15 import GHC.Base
  16 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
  17                       labelThread, modifyMVar_, newTVar, sharedCAF,
  18                       threadStatus, writeTVar)
  19 import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
  20 import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
  21                              new, registerFd, unregisterFd_, registerTimeout)
  22 import System.IO.Unsafe (unsafePerformIO)
  23 import System.Posix.Types (Fd)
  24
  25 -- | Suspends the current thread for a given number of microseconds
  26 -- (GHC only).
  27 --
  28 -- There is no guarantee that the thread will be rescheduled promptly
  29 -- when the delay has expired, but the thread will never continue to
  30 -- run /earlier/ than specified.
  31 threadDelay :: Int -> IO ()
  32 threadDelay usecs = do
  33   Just mgr <- readIORef eventManager
  34   m <- newEmptyMVar
  35   _ <- registerTimeout mgr usecs (putMVar m ())
  36   takeMVar m
  37
  38 -- | Set the value of returned TVar to True after a given number of
  39 -- microseconds. The caveats associated with threadDelay also apply.
  40 --
  41 registerDelay :: Int -> IO (TVar Bool)
  42 registerDelay usecs = do
  43   t <- atomically $ newTVar False
  44   Just mgr <- readIORef eventManager
  45   _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
  46   return t
  47
  48 -- | Block the current thread until data is available to read from the
  49 -- given file descriptor.
  50 threadWaitRead :: Fd -> IO ()
  51 threadWaitRead = threadWait evtRead
  52 {-# INLINE threadWaitRead #-}
  53
  54 -- | Block the current thread until the given file descriptor can
  55 -- accept data to write.
  56 threadWaitWrite :: Fd -> IO ()
  57 threadWaitWrite = threadWait evtWrite
  58 {-# INLINE threadWaitWrite #-}
  59
  60 threadWait :: Event -> Fd -> IO ()
  61 threadWait evt fd = do
  62   m <- newEmptyMVar
  63   Just mgr <- readIORef eventManager
  64   _ <- registerFd mgr (\reg _ -> unregisterFd_ mgr reg >> putMVar m ()) fd evt
  65   takeMVar m
  66
  67 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
  68     getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
  69
  70 eventManager :: IORef (Maybe EventManager)
  71 eventManager = unsafePerformIO $ do
  72     em <- newIORef Nothing
  73     sharedCAF em getOrSetSystemEventThreadEventManagerStore
  74 {-# NOINLINE eventManager #-}
  75
  76 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
  77     getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
  78
  79 {-# NOINLINE ioManager #-}
  80 ioManager :: MVar (Maybe ThreadId)
  81 ioManager = unsafePerformIO $ do
  82    m <- newMVar Nothing
  83    sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
  84
  85 ensureIOManagerIsRunning :: IO ()
  86 ensureIOManagerIsRunning
  87   | not threaded = return ()
  88   | otherwise = modifyMVar_ ioManager $ \old -> do
  89   let create = do
  90         !mgr <- new
  91         writeIORef eventManager $ Just mgr
  92         !t <- forkIO $ loop mgr
  93         labelThread t "IOManager"
  94         return $ Just t
  95   case old of
  96     Nothing            -> create
  97     st@(Just t) -> do
  98       s <- threadStatus t
  99       case s of
 100         ThreadFinished -> create
 101         ThreadDied     -> create
 102         _other         -> return st
 103
 104 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool