GHC/Event/Thread.hs

   1 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
   2
   3 module GHC.Event.Thread
   4     ( getSystemEventManager
   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.Event.Internal (eventIs, evtClose)
  25 import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
  26                              new, registerFd, unregisterFd_, registerTimeout)
  27 import qualified GHC.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 = mask_ $ do
  39   Just mgr <- getSystemEventManager
  40   m <- newEmptyMVar
  41   reg <- registerTimeout mgr usecs (putMVar m ())
  42   takeMVar m `onException` M.unregisterTimeout mgr reg
  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 <- getSystemEventManager
  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 was blocked.  To safely close a file descriptor
  59 -- that has been used with 'threadWaitRead', use 'closeFdWith'.
  60 threadWaitRead :: Fd -> IO ()
  61 threadWaitRead = threadWait evtRead
  62 {-# INLINE threadWaitRead #-}
  63
  64 -- | Block the current thread until the given file descriptor can
  65 -- accept data to write.
  66 --
  67 -- This will throw an 'IOError' if the file descriptor was closed
  68 -- while this thread was blocked.  To safely close a file descriptor
  69 -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
  70 threadWaitWrite :: Fd -> IO ()
  71 threadWaitWrite = threadWait evtWrite
  72 {-# INLINE threadWaitWrite #-}
  73
  74 -- | Close a file descriptor in a concurrency-safe way.
  75 --
  76 -- Any threads that are blocked on the file descriptor via
  77 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
  78 -- IO exceptions thrown.
  79 closeFdWith :: (Fd -> IO ())        -- ^ Action that performs the close.
  80             -> Fd                   -- ^ File descriptor to close.
  81             -> IO ()
  82 closeFdWith close fd = do
  83   Just mgr <- getSystemEventManager
  84   M.closeFd mgr close fd
  85
  86 threadWait :: Event -> Fd -> IO ()
  87 threadWait evt fd = mask_ $ do
  88   m <- newEmptyMVar
  89   Just mgr <- getSystemEventManager
  90   reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
  91   evt' <- takeMVar m `onException` unregisterFd_ mgr reg
  92   if evt' `eventIs` evtClose
  93     then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
  94     else return ()
  95
  96 -- | Retrieve the system event manager.
  97 --
  98 -- This function always returns 'Just' the system event manager when using the
  99 -- threaded RTS and 'Nothing' otherwise.
 100 getSystemEventManager :: IO (Maybe EventManager)
 101 getSystemEventManager = readIORef eventManager
 102
 103 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
 104     getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
 105
 106 eventManager :: IORef (Maybe EventManager)
 107 eventManager = unsafePerformIO $ do
 108     em <- newIORef Nothing
 109     sharedCAF em getOrSetSystemEventThreadEventManagerStore
 110 {-# NOINLINE eventManager #-}
 111
 112 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
 113     getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
 114
 115 {-# NOINLINE ioManager #-}
 116 ioManager :: MVar (Maybe ThreadId)
 117 ioManager = unsafePerformIO $ do
 118    m <- newMVar Nothing
 119    sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
 120
 121 ensureIOManagerIsRunning :: IO ()
 122 ensureIOManagerIsRunning
 123   | not threaded = return ()
 124   | otherwise = modifyMVar_ ioManager $ \old -> do
 125   let create = do
 126         !mgr <- new
 127         writeIORef eventManager $ Just mgr
 128         !t <- forkIO $ loop mgr
 129         labelThread t "IOManager"
 130         return $ Just t
 131   case old of
 132     Nothing            -> create
 133     st@(Just t) -> do
 134       s <- threadStatus t
 135       case s of
 136         ThreadFinished -> create
 137         ThreadDied     -> do
 138           -- Sanity check: if the thread has died, there is a chance
 139           -- that event manager is still alive. This could happend during
 140           -- the fork, for example. In this case we should clean up
 141           -- open pipes and everything else related to the event manager.
 142           -- See #4449
 143           mem <- readIORef eventManager
 144           _ <- case mem of
 145                  Nothing -> return ()
 146                  Just em -> M.cleanup em
 147           create
 148         _other         -> return st
 149
 150 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool