content: {-# LANGUAGE Trustworthy #-}
  {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
  
  module GHC.Event.Thread
      ( getSystemEventManager
      , ensureIOManagerIsRunning
      , threadWaitRead
      , threadWaitWrite
      , closeFdWith
      , threadDelay
      , registerDelay
      ) where
  
  import Data.IORef (IORef, newIORef, readIORef, writeIORef)
  import Data.Maybe (Maybe(..))
  import Foreign.C.Error (eBADF, errnoToIOError)
  import Foreign.Ptr (Ptr)
  import GHC.Base
  import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
                        labelThread, modifyMVar_, newTVar, sharedCAF,
                        threadStatus, writeTVar)
  import GHC.IO (mask_, onException)
  import GHC.IO.Exception (ioError)
  import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
  import GHC.Event.Internal (eventIs, evtClose)
  import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
                               new, registerFd, unregisterFd_, registerTimeout)
  import qualified GHC.Event.Manager as M
  import System.IO.Unsafe (unsafePerformIO)
  import System.Posix.Types (Fd)
  
  -- | Suspends the current thread for a given number of microseconds
  -- (GHC only).
  --
  -- There is no guarantee that the thread will be rescheduled promptly
  -- when the delay has expired, but the thread will never continue to
  -- run /earlier/ than specified.
  threadDelay :: Int -> IO ()
  threadDelay usecs = mask_ $ do
    Just mgr <- getSystemEventManager
    m <- newEmptyMVar
    reg <- registerTimeout mgr usecs (putMVar m ())
    takeMVar m `onException` M.unregisterTimeout mgr reg
  
  -- | Set the value of returned TVar to True after a given number of
  -- microseconds. The caveats associated with threadDelay also apply.
  --
  registerDelay :: Int -> IO (TVar Bool)
  registerDelay usecs = do
    t <- atomically $ newTVar False
    Just mgr <- getSystemEventManager
    _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
    return t
  
  -- | Block the current thread until data is available to read from the
  -- given file descriptor.
  --
  -- This will throw an 'IOError' if the file descriptor was closed
  -- while this thread was blocked.  To safely close a file descriptor
  -- that has been used with 'threadWaitRead', use 'closeFdWith'.
  threadWaitRead :: Fd -> IO ()
  threadWaitRead = threadWait evtRead
  {-# INLINE threadWaitRead #-}
  
  -- | Block the current thread until the given file descriptor can
  -- accept data to write.
  --
  -- This will throw an 'IOError' if the file descriptor was closed
  -- while this thread was blocked.  To safely close a file descriptor
  -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
  threadWaitWrite :: Fd -> IO ()
  threadWaitWrite = threadWait evtWrite
  {-# INLINE threadWaitWrite #-}
  
  -- | Close a file descriptor in a concurrency-safe way.
  --
  -- Any threads that are blocked on the file descriptor via
  -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
  -- IO exceptions thrown.
  closeFdWith :: (Fd -> IO ())        -- ^ Action that performs the close.
              -> Fd                   -- ^ File descriptor to close.
              -> IO ()
  closeFdWith close fd = do
    Just mgr <- getSystemEventManager
    M.closeFd mgr close fd
  
  threadWait :: Event -> Fd -> IO ()
  threadWait evt fd = mask_ $ do
    m <- newEmptyMVar
    Just mgr <- getSystemEventManager
    reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
    evt' <- takeMVar m `onException` unregisterFd_ mgr reg
    if evt' `eventIs` evtClose
      then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
      else return ()
  
  -- | Retrieve the system event manager.
  --
  -- This function always returns 'Just' the system event manager when using the
  -- threaded RTS and 'Nothing' otherwise.
  getSystemEventManager :: IO (Maybe EventManager)
  getSystemEventManager = readIORef eventManager
  
  foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
      getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
  
  eventManager :: IORef (Maybe EventManager)
  eventManager = unsafePerformIO $ do
      em <- newIORef Nothing
      sharedCAF em getOrSetSystemEventThreadEventManagerStore
  {-# NOINLINE eventManager #-}
  
  foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
      getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
  
  {-# NOINLINE ioManager #-}
  ioManager :: MVar (Maybe ThreadId)
  ioManager = unsafePerformIO $ do
     m <- newMVar Nothing
     sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
  
  ensureIOManagerIsRunning :: IO ()
  ensureIOManagerIsRunning
    | not threaded = return ()
    | otherwise = modifyMVar_ ioManager $ \old -> do
    let create = do
          !mgr <- new
          writeIORef eventManager $ Just mgr
          !t <- forkIO $ loop mgr
          labelThread t "IOManager"
          return $ Just t
    case old of
      Nothing            -> create
      st@(Just t) -> do
        s <- threadStatus t
        case s of
          ThreadFinished -> create
          ThreadDied     -> do 
            -- Sanity check: if the thread has died, there is a chance
            -- that event manager is still alive. This could happend during
            -- the fork, for example. In this case we should clean up
            -- open pipes and everything else related to the event manager.
            -- See #4449
            mem <- readIORef eventManager
            _ <- case mem of
                   Nothing -> return ()
                   Just em -> M.cleanup em
            create
          _other         -> return st
  
  foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
  