{-# 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 (pure)
import GHC.Internal.Err (error)
import GHC.Internal.Conc.Sync (ThreadId)
import GHC.Internal.Types (Bool(..), IO)

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.Classes (Eq(..))
import GHC.Internal.Err (undefined)
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 (otherwise, return, when, ($), (++), (>>=), (>>))
import GHC.Internal.Conc.Sync
import GHC.Internal.IO
import GHC.Internal.Exception
import GHC.Internal.IORef
import GHC.Internal.MVar
import GHC.Internal.Prim (isCurrentThreadBound#, (/=#))
import GHC.Internal.Types (Bool(..), isTrue#)

-- | '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



failNonThreaded :: IO a
failNonThreaded :: forall a. IO a
failNonThreaded = String -> IO a
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
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)"

#if defined(wasm32_HOST_ARCH)

forkOS _ = failNonThreaded

#else

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

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
#endif

-- | 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
(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