{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , MagicHash
           , UnboxedTuples
  #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Conc.IO
-- Copyright   :  (c) The University of Glasgow, 1994-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC extensions)
--
-- Basic concurrency stuff.
--
-----------------------------------------------------------------------------

-- No: #hide, because bits of this module are exposed by the stm package.
-- However, we don't want this module to be the home location for the
-- bits it exports, we'd rather have Control.Concurrent and the other
-- higher level modules be the home.  Hence: #not-home

module GHC.Conc.IO
        ( ensureIOManagerIsRunning
        , ioManagerCapabilitiesChanged

        -- * Waiting
        , threadDelay
        , registerDelay
        , threadWaitRead
        , threadWaitWrite
        , threadWaitReadSTM
        , threadWaitWriteSTM
        , closeFdWith

#if defined(mingw32_HOST_OS)
        , asyncRead
        , asyncWrite
        , asyncDoProc

        , asyncReadBA
        , asyncWriteBA

        , ConsoleEvent(..)
        , win32ConsoleHandler
        , toWin32ConsoleEvent
#endif
        ) where

import Foreign
import GHC.Base
import GHC.Conc.Sync as Sync
import GHC.Real ( fromIntegral )
import System.Posix.Types

#if defined(mingw32_HOST_OS)
import qualified GHC.Conc.Windows as Windows
import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA,
                         asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler,
                         toWin32ConsoleEvent)
#else
import qualified GHC.Event.Thread as Event
#endif

ensureIOManagerIsRunning :: IO ()
#if !defined(mingw32_HOST_OS)
ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning = IO ()
Event.ensureIOManagerIsRunning
#else
ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning
#endif

ioManagerCapabilitiesChanged :: IO ()
#if !defined(mingw32_HOST_OS)
ioManagerCapabilitiesChanged :: IO ()
ioManagerCapabilitiesChanged = IO ()
Event.ioManagerCapabilitiesChanged
#else
ioManagerCapabilitiesChanged = return ()
#endif

-- | Block the current thread until data is available to read on the
-- given file descriptor (GHC only).
--
-- This will throw an 'Prelude.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 :: Fd -> IO ()
threadWaitRead fd :: Fd
fd
#if !defined(mingw32_HOST_OS)
  | Bool
threaded  = Fd -> IO ()
Event.threadWaitRead Fd
fd
#endif
  | Bool
otherwise = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \s :: State# RealWorld
s ->
        case Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd of { I# fd# :: Int#
fd# ->
        case Int# -> State# RealWorld -> State# RealWorld
forall d. Int# -> State# d -> State# d
waitRead# Int#
fd# State# RealWorld
s of { s' :: State# RealWorld
s' -> (# State# RealWorld
s', () #)
        }}

-- | Block the current thread until data can be written to the
-- given file descriptor (GHC only).
--
-- This will throw an 'Prelude.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 :: Fd -> IO ()
threadWaitWrite fd :: Fd
fd
#if !defined(mingw32_HOST_OS)
  | Bool
threaded  = Fd -> IO ()
Event.threadWaitWrite Fd
fd
#endif
  | Bool
otherwise = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \s :: State# RealWorld
s ->
        case Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd of { I# fd# :: Int#
fd# ->
        case Int# -> State# RealWorld -> State# RealWorld
forall d. Int# -> State# d -> State# d
waitWrite# Int#
fd# State# RealWorld
s of { s' :: State# RealWorld
s' -> (# State# RealWorld
s', () #)
        }}

-- | Returns an STM action that can be used to wait for data
-- to read from a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
threadWaitReadSTM fd :: Fd
fd
#if !defined(mingw32_HOST_OS)
  | Bool
threaded  = Fd -> IO (STM (), IO ())
Event.threadWaitReadSTM Fd
fd
#endif
  | Bool
otherwise = do
      TVar Bool
m <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
Sync.newTVarIO Bool
False
      ThreadId
t <- IO () -> IO ThreadId
Sync.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        Fd -> IO ()
threadWaitRead Fd
fd
        STM () -> IO ()
forall a. STM a -> IO a
Sync.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
Sync.writeTVar TVar Bool
m Bool
True
      let waitAction :: STM ()
waitAction = do Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
Sync.readTVar TVar Bool
m
                          if Bool
b then () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else STM ()
forall a. STM a
retry
      let killAction :: IO ()
killAction = ThreadId -> IO ()
Sync.killThread ThreadId
t
      (STM (), IO ()) -> IO (STM (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (STM ()
waitAction, IO ()
killAction)

-- | Returns an STM action that can be used to wait until data
-- can be written to a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM fd :: Fd
fd
#if !defined(mingw32_HOST_OS)
  | Bool
threaded  = Fd -> IO (STM (), IO ())
Event.threadWaitWriteSTM Fd
fd
#endif
  | Bool
otherwise = do
      TVar Bool
m <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
Sync.newTVarIO Bool
False
      ThreadId
t <- IO () -> IO ThreadId
Sync.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        Fd -> IO ()
threadWaitWrite Fd
fd
        STM () -> IO ()
forall a. STM a -> IO a
Sync.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
Sync.writeTVar TVar Bool
m Bool
True
      let waitAction :: STM ()
waitAction = do Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
Sync.readTVar TVar Bool
m
                          if Bool
b then () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else STM ()
forall a. STM a
retry
      let killAction :: IO ()
killAction = ThreadId -> IO ()
Sync.killThread ThreadId
t
      (STM (), IO ()) -> IO (STM (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (STM ()
waitAction, IO ()
killAction)

-- | Close a file descriptor in a concurrency-safe way (GHC only).  If
-- you are using 'threadWaitRead' or 'threadWaitWrite' to perform
-- blocking I\/O, you /must/ use this function to close file
-- descriptors, or blocked threads may not be woken.
--
-- Any threads that are blocked on the file descriptor via
-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
-- IO exceptions thrown.
closeFdWith :: (Fd -> IO ()) -- ^ Low-level action that performs the real close.
            -> Fd            -- ^ File descriptor to close.
            -> IO ()
closeFdWith :: (Fd -> IO ()) -> Fd -> IO ()
closeFdWith close :: Fd -> IO ()
close fd :: Fd
fd
#if !defined(mingw32_HOST_OS)
  | Bool
threaded  = (Fd -> IO ()) -> Fd -> IO ()
Event.closeFdWith Fd -> IO ()
close Fd
fd
#endif
  | Bool
otherwise = Fd -> IO ()
close Fd
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 :: Int -> IO ()
threadDelay time :: Int
time
#if defined(mingw32_HOST_OS)
  | threaded  = Windows.threadDelay time
#else
  | Bool
threaded  = Int -> IO ()
Event.threadDelay Int
time
#endif
  | Bool
otherwise = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \s :: State# RealWorld
s ->
        case Int
time of { I# time# :: Int#
time# ->
        case Int# -> State# RealWorld -> State# RealWorld
forall d. Int# -> State# d -> State# d
delay# Int#
time# State# RealWorld
s of { s' :: State# RealWorld
s' -> (# State# RealWorld
s', () #)
        }}

-- | Switch the value of returned 'TVar' from initial value 'False' to 'True'
-- after a given number of microseconds. The caveats associated with
-- 'threadDelay' also apply.
--
registerDelay :: Int -> IO (TVar Bool)
registerDelay :: Int -> IO (TVar Bool)
registerDelay usecs :: Int
usecs
#if defined(mingw32_HOST_OS)
  | threaded = Windows.registerDelay usecs
#else
  | Bool
threaded = Int -> IO (TVar Bool)
Event.registerDelay Int
usecs
#endif
  | Bool
otherwise = [Char] -> IO (TVar Bool)
forall a. [Char] -> a
errorWithoutStackTrace "registerDelay: requires -threaded"

foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool