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