    {-# LANGUAGE CPP #-}
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE UnboxedTuples #-}
    {-# LANGUAGE UnliftedFFITypes #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE KindSignatures #-}
    {-# LANGUAGE Unsafe #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  GHC.Internal.Conc.Bound
    -- Copyright   :  (c) The University of Glasgow 2001
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  stable
    -- Portability :  non-portable (concurrency)
    --
    -- Bound thread support.
    --
    -----------------------------------------------------------------------------

    module GHC.Internal.Conc.Bound
        ( forkOS
        , forkOSWithUnmask
        , isCurrentThreadBound
        , runInBoundThread
        , runInUnboundThread
        , rtsSupportsBoundThreads
        ) where
    --
    -- JavaScript platform doesn't support bound threads
    #if !defined(javascript_HOST_ARCH)
    #define SUPPORT_BOUND_THREADS
    #endif

    #if !defined(SUPPORT_BOUND_THREADS)

    import GHC.Internal.Base
    import GHC.Internal.Conc.Sync (ThreadId)

    forkOS :: IO () -> IO ThreadId
    forkOS _ = error "forkOS not supported on this architecture"

    forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
    forkOSWithUnmask _ = error "forkOS not supported on this architecture"

    isCurrentThreadBound :: IO Bool
    isCurrentThreadBound = pure False

    runInBoundThread :: IO a -> IO a
    runInBoundThread action = action

    runInUnboundThread :: IO a -> IO a
    runInUnboundThread action = action

    rtsSupportsBoundThreads :: Bool
    rtsSupportsBoundThreads = False

    #else

    import GHC.Internal.Foreign.StablePtr
    import GHC.Internal.Foreign.C.Types
    import GHC.Internal.Control.Monad.Fail
    import GHC.Internal.Data.Either
    import qualified GHC.Internal.Control.Exception.Base as Exception
    import GHC.Internal.Base
    import GHC.Internal.Conc.Sync
    import GHC.Internal.IO
    import GHC.Internal.Exception
    import GHC.Internal.IORef
    import GHC.Internal.MVar

    -- | 'True' if bound threads are supported.
    -- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'
    -- will always return 'False' and both 'forkOS' and 'runInBoundThread' will
    -- fail.
    foreign import ccall unsafe rtsSupportsBoundThreads :: Bool

    {- |
    Like 'forkIO', this sparks off a new thread to run the 'IO'
    computation passed as the first argument, and returns the 'ThreadId'
    of the newly created thread.

    However, 'forkOS' creates a /bound/ thread, which is necessary if you
    need to call foreign (non-Haskell) libraries that make use of
    thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads").

    Using 'forkOS' instead of 'forkIO' makes no difference at all to the
    scheduling behaviour of the Haskell runtime system.  It is a common
    misconception that you need to use 'forkOS' instead of 'forkIO' to
    avoid blocking all the Haskell threads when making a foreign call;
    this isn't the case.  To allow foreign calls to be made without
    blocking all the Haskell threads (with GHC), it is only necessary to
    use the @-threaded@ option when linking your program, and to make sure
    the foreign import is not marked @unsafe@.
    -}

    forkOS :: IO () -> IO ThreadId

    foreign export ccall forkOS_entry
        :: StablePtr (IO ()) -> IO ()

    foreign import ccall "forkOS_entry" forkOS_entry_reimported
        :: StablePtr (IO ()) -> IO ()

    forkOS_entry :: StablePtr (IO ()) -> IO ()
    forkOS_entry :: StablePtr (IO ()) -> IO ()
    forkOS_entry StablePtr (IO ())
    stableAction = do
            action <- StablePtr (IO ()) -> IO (IO ())
    forall a. StablePtr a -> IO a
    deRefStablePtr StablePtr (IO ())
    stableAction
            action

    foreign import ccall forkOS_createThread
        :: StablePtr (IO ()) -> IO CInt

    failNonThreaded :: IO a
    failNonThreaded :: forall a. IO a
    failNonThreaded = String -> IO a
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> IO a) -> String -> IO a
    forall a b. (a -> b) -> a -> b
    $ String
    "RTS doesn't support multiple OS threads "
                           String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "(use ghc -threaded when linking)"

    forkOS :: IO () -> IO ThreadId
    forkOS IO ()
    action0
        | Bool
    rtsSupportsBoundThreads = do
            mv <- IO (MVar ThreadId)
    forall a. IO (MVar a)
    newEmptyMVar
            b <- Exception.getMaskingState
            let
                -- async exceptions are masked in the child if they are masked
                -- in the parent, as for forkIO (see #1048). forkOS_createThread
                -- creates a thread with exceptions masked by default.
                action1 = case MaskingState
    b of
                            MaskingState
    Unmasked -> IO () -> IO ()
    forall a. IO a -> IO a
    unsafeUnmask IO ()
    action0
                            MaskingState
    MaskedInterruptible -> IO ()
    action0
                            MaskingState
    MaskedUninterruptible -> IO () -> IO ()
    forall a. IO a -> IO a
    uninterruptibleMask_ IO ()
    action0

                action_plus = IO () -> (SomeException -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catch IO ()
    action1 SomeException -> IO ()
    childHandler

            entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
            err <- forkOS_createThread entry
            when (err /= 0) $ fail "Cannot create OS thread."
            tid <- takeMVar mv
            freeStablePtr entry
            return tid
        | Bool
    otherwise = IO ThreadId
    forall a. IO a
    failNonThreaded

    -- | Like 'forkIOWithUnmask', but the child thread is a bound thread,
    -- as with 'forkOS'.
    forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
    forkOSWithUnmask :: ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
    forkOSWithUnmask (forall a. IO a -> IO a) -> IO ()
    io = IO () -> IO ThreadId
    forkOS ((forall a. IO a -> IO a) -> IO ()
    io IO a -> IO a
    forall a. IO a -> IO a
    unsafeUnmask)

    -- | Returns 'True' if the calling thread is /bound/, that is, if it is
    -- safe to use foreign libraries that rely on thread-local state from the
    -- calling thread.
    isCurrentThreadBound :: IO Bool
    isCurrentThreadBound :: IO Bool
    isCurrentThreadBound = (State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    IO ((State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool)
    -> (State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ \ State# RealWorld
    s# ->
        case State# RealWorld -> (# State# RealWorld, Int# #)
    isCurrentThreadBound# State# RealWorld
    s# of
            (# State# RealWorld
    s2#, Int#
    flg #) -> (# State# RealWorld
    s2#, Int# -> Bool
    isTrue# (Int#
    flg Int# -> Int# -> Int#
    /=# Int#
    0#) #)

    {- |
    Run the 'IO' computation passed as the first argument. If the calling thread
    is not /bound/, a bound thread is created temporarily. @runInBoundThread@
    doesn't finish until the 'IO' computation finishes.

    You can wrap a series of foreign function calls that rely on thread-local state
    with @runInBoundThread@ so that you can use them without knowing whether the
    current thread is /bound/.
    -}
    runInBoundThread :: IO a -> IO a

    runInBoundThread :: forall a. IO a -> IO a
    runInBoundThread IO a
    action
        | Bool
    rtsSupportsBoundThreads = do
            bound <- IO Bool
    isCurrentThreadBound
            if bound
                then action
                else do
                    ref <- newIORef undefined
                    let action_plus = IO a -> IO (Either SomeException a)
    forall e a. Exception e => IO a -> IO (Either e a)
    Exception.try IO a
    action IO (Either SomeException a)
    -> (Either SomeException a -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= IORef (Either SomeException a) -> Either SomeException a -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef (Either SomeException a)
    ref
                    bracket (newStablePtr action_plus)
                            freeStablePtr
                            (\StablePtr (IO ())
    cEntry -> StablePtr (IO ()) -> IO ()
    forkOS_entry_reimported StablePtr (IO ())
    cEntry IO () -> IO (Either SomeException a) -> IO (Either SomeException a)
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IORef (Either SomeException a) -> IO (Either SomeException a)
    forall a. IORef a -> IO a
    readIORef IORef (Either SomeException a)
    ref) >>=
                      unsafeResult
        | Bool
    otherwise = IO a
    forall a. IO a
    failNonThreaded

    {- |
    Run the 'IO' computation passed as the first argument. If the calling thread
    is /bound/, an unbound thread is created temporarily using 'forkIO'.
    @runInBoundThread@ doesn't finish until the 'IO' computation finishes.

    Use this function /only/ in the rare case that you have actually observed a
    performance loss due to the use of bound threads. A program that
    doesn't need its main thread to be bound and makes /heavy/ use of concurrency
    (e.g. a web server), might want to wrap its @main@ action in
    @runInUnboundThread@.

    Note that exceptions which are thrown to the current thread are thrown in turn
    to the thread that is executing the given computation. This ensures there's
    always a way of killing the forked thread.
    -}
    runInUnboundThread :: IO a -> IO a

    runInUnboundThread :: forall a. IO a -> IO a
    runInUnboundThread IO a
    action = do
      bound <- IO Bool
    isCurrentThreadBound
      if bound
        then do
          mv <- newEmptyMVar
          mask $ \forall a. IO a -> IO a
    restore -> do
            tid <- IO () -> IO ThreadId
    forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
    forall a b. (a -> b) -> a -> b
    $ IO a -> IO (Either SomeException a)
    forall e a. Exception e => IO a -> IO (Either e a)
    Exception.try (IO a -> IO a
    forall a. IO a -> IO a
    restore IO a
    action) IO (Either SomeException a)
    -> (Either SomeException a -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MVar (Either SomeException a) -> Either SomeException a -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Either SomeException a)
    mv
            let wait = MVar (Either SomeException a) -> IO (Either SomeException a)
    forall a. MVar a -> IO a
    takeMVar MVar (Either SomeException a)
    mv IO (Either SomeException a)
    -> (SomeException -> IO (Either SomeException a))
    -> IO (Either SomeException a)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `catchException` \(SomeException
    e :: SomeException) ->
                         ThreadId -> SomeException -> IO ()
    forall e. Exception e => ThreadId -> e -> IO ()
    Exception.throwTo ThreadId
    tid SomeException
    e IO () -> IO (Either SomeException a) -> IO (Either SomeException a)
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO (Either SomeException a)
    wait
            wait >>= unsafeResult
        else action

    unsafeResult :: Either SomeException a -> IO a
    unsafeResult :: forall a. Either SomeException a -> IO a
    unsafeResult = (SomeException -> IO a)
    -> (a -> IO a) -> Either SomeException a -> IO a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either SomeException -> IO a
    forall e a. (HasCallStack, Exception e) => e -> IO a
    Exception.throwIO a -> IO a
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    #endif