GHC/Event/Thread.hs

   1 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
   2
   3 module GHC.Event.Thread
   4     (
   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 <- readIORef eventManager
  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 <- 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 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 <- readIORef eventManager
  84   M.closeFd mgr close fd
  85
  86 threadWait :: Event -> Fd -> IO ()
  87 threadWait evt fd = mask_ $ do
  88   m <- newEmptyMVar
  89   Just mgr <- readIORef eventManager
  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 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
  97     getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
  98
  99 eventManager :: IORef (Maybe EventManager)
 100 eventManager = unsafePerformIO $ do
 101     em <- newIORef Nothing
 102     sharedCAF em getOrSetSystemEventThreadEventManagerStore
 103 {-# NOINLINE eventManager #-}
 104
 105 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
 106     getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
 107
 108 {-# NOINLINE ioManager #-}
 109 ioManager :: MVar (Maybe ThreadId)
 110 ioManager = unsafePerformIO $ do
 111    m <- newMVar Nothing
 112    sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
 113
 114 ensureIOManagerIsRunning :: IO ()
 115 ensureIOManagerIsRunning
 116   | not threaded = return ()
 117   | otherwise = modifyMVar_ ioManager $ \old -> do
 118   let create = do
 119         !mgr <- new
 120         writeIORef eventManager $ Just mgr
 121         !t <- forkIO $ loop mgr
 122         labelThread t "IOManager"
 123         return $ Just t
 124   case old of
 125     Nothing            -> create
 126     st@(Just t) -> do
 127       s <- threadStatus t
 128       case s of
 129         ThreadFinished -> create
 130         ThreadDied     -> do
 131           -- Sanity check: if the thread has died, there is a chance
 132           -- that event manager is still alive. This could happend during
 133           -- the fork, for example. In this case we should clean up
 134           -- open pipes and everything else related to the event manager.
 135           -- See #4449
 136           mem <- readIORef eventManager
 137           _ <- case mem of
 138                  Nothing -> return ()
 139                  Just em -> M.cleanup em
 140           create
 141         _other         -> return st
 142
 143 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool