{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , MagicHash
           , UnboxedTuples
  #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.Conc.IO
-- Copyright   :  (c) The University of Glasgow, 1994-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  ghc-devs@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC extensions)
--
-- Basic concurrency stuff.
--
-- /The API of this module is unstable and not meant to be consumed by the general public./
-- If you absolutely must depend on it, make sure to use a tight upper
-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can
-- change rapidly without much warning.
--
-----------------------------------------------------------------------------

-- 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.Internal.Conc.IO
        ( ensureIOManagerIsRunning
        , ioManagerCapabilitiesChanged
        , interruptIOManager

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

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

        , asyncReadBA
        , asyncWriteBA

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

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

#if defined(mingw32_HOST_OS)
import qualified GHC.Internal.Conc.Windows as Windows
import GHC.Internal.IO.SubSystem
import GHC.Internal.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA,
                         asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler,
                         toWin32ConsoleEvent)
#elif !defined(javascript_HOST_ARCH)
import qualified GHC.Internal.Event.Thread as Event
#endif

#if defined(wasm32_HOST_ARCH)
import qualified GHC.Internal.Wasm.Prim.Conc as Wasm
import qualified GHC.Internal.Wasm.Prim.Flag as Wasm
#endif

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

-- | Interrupts the current wait of the I/O manager if it is currently blocked.
-- This instructs it to re-read how much it should wait and to process any
-- pending events.
--
-- @since base-4.15
interruptIOManager :: IO ()
#if !defined(mingw32_HOST_OS)
interruptIOManager :: IO ()
interruptIOManager = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
interruptIOManager = Windows.interruptIOManager
#endif

ioManagerCapabilitiesChanged :: IO ()
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
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
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
  | 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
$ \State# RealWorld
s ->
        case Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd of { I# Int#
fd# ->
        case Int# -> State# RealWorld -> State# RealWorld
forall d. Int# -> State# d -> State# d
waitRead# Int#
fd# State# RealWorld
s of { 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
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
  | 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
$ \State# RealWorld
s ->
        case Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd of { I# Int#
fd# ->
        case Int# -> State# RealWorld -> State# RealWorld
forall d. Int# -> State# d -> State# d
waitWrite# Int#
fd# State# RealWorld
s of { 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
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
  | Bool
threaded  = Fd -> IO (STM (), IO ())
Event.threadWaitReadSTM Fd
fd
#endif
  | Bool
otherwise = do
      m <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
Sync.newTVarIO Bool
False
      t <- Sync.forkIO $ do
        threadWaitRead fd
        Sync.atomically $ Sync.writeTVar m True
      let waitAction = do b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
Sync.readTVar TVar Bool
m
                          if b then return () else retry
      let killAction = ThreadId -> IO ()
Sync.killThread ThreadId
t
      return (waitAction, 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
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
  | Bool
threaded  = Fd -> IO (STM (), IO ())
Event.threadWaitWriteSTM Fd
fd
#endif
  | Bool
otherwise = do
      m <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
Sync.newTVarIO Bool
False
      t <- Sync.forkIO $ do
        threadWaitWrite fd
        Sync.atomically $ Sync.writeTVar m True
      let waitAction = do b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
Sync.readTVar TVar Bool
m
                          if b then return () else retry
      let killAction = ThreadId -> IO ()
Sync.killThread ThreadId
t
      return (waitAction, 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 Fd -> IO ()
close Fd
fd
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
  | 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.
--
-- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
-- 2147483647 μs, less than 36 minutes.
-- Consider using @Control.Concurrent.Thread.Delay.delay@ from @unbounded-delays@ package.
threadDelay :: Int -> IO ()
threadDelay :: Int -> IO ()
threadDelay Int
time
#if defined(mingw32_HOST_OS)
  | isWindowsNativeIO = Windows.threadDelay time
  | threaded          = Windows.threadDelay time
#elif defined(wasm32_HOST_ARCH)
  | Wasm.isJSFFIUsed  = Wasm.threadDelay time
#elif !defined(javascript_HOST_ARCH)
  | 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
$ \State# RealWorld
s ->
        case Int
time of { I# Int#
time# ->
        case Int# -> State# RealWorld -> State# RealWorld
forall d. Int# -> State# d -> State# d
delay# Int#
time# State# RealWorld
s of { 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.
--
-- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
-- 2147483647 μs, less than 36 minutes.
--
registerDelay :: Int -> IO (TVar Bool)
registerDelay :: Int -> IO (TVar Bool)
registerDelay Int
_usecs
#if defined(mingw32_HOST_OS)
  | isWindowsNativeIO = Windows.registerDelay _usecs
  | threaded          = Windows.registerDelay _usecs
#elif !defined(javascript_HOST_ARCH)
  | Bool
threaded          = Int -> IO (TVar Bool)
Event.registerDelay Int
_usecs
#endif
  | Bool
otherwise         = [Char] -> IO (TVar Bool)
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"registerDelay: requires -threaded"

#if !defined(javascript_HOST_ARCH)
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
#endif