{-# 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.-------------------------------------------------------------------------------moduleGHC.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)
importGHC.Internal.BaseimportGHC.Internal.Conc.Sync(ThreadId)forkOS::IO()->IOThreadIdforkOS_=error"forkOS not supported on this architecture"forkOSWithUnmask::((foralla.IOa->IOa)->IO())->IOThreadIdforkOSWithUnmask_=error"forkOS not supported on this architecture"isCurrentThreadBound::IOBoolisCurrentThreadBound=pureFalserunInBoundThread::IOa->IOarunInBoundThreadaction=actionrunInUnboundThread::IOa->IOarunInUnboundThreadaction=actionrtsSupportsBoundThreads::BoolrtsSupportsBoundThreads=False
#else
importGHC.Internal.Foreign.StablePtr importGHC.Internal.Foreign.C.Types importGHC.Internal.Control.Monad.Fail importGHC.Internal.Data.Either importqualifiedGHC.Internal.Control.Exception.Base asExceptionimportGHC.Internal.Base importGHC.Internal.Conc.Sync importGHC.Internal.IO importGHC.Internal.Exception importGHC.Internal.IORef importGHC.Internal.MVar -- | 'True' if bound threads are supported.-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will-- fail.foreignimportccallunsafertsSupportsBoundThreads ::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 foreignexportccallforkOS_entry ::StablePtr (IO ())->IO ()foreignimportccall"forkOS_entry"forkOS_entry_reimported ::StablePtr (IO ())->IO ()forkOS_entry ::StablePtr (IO ())->IO ()forkOS_entry :: StablePtr (IO ()) -> IO ()
forkOS_entry StablePtr (IO ())
stableAction =doaction <-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. 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)"
#if defined(wasm32_HOST_ARCH)
forkOS_=failNonThreaded
#else
foreignimportccallforkOS_createThread ::StablePtr (IO ())->IO CInt forkOS :: IO () -> IO ThreadId
forkOS IO ()
action0 |Bool
rtsSupportsBoundThreads =domv <-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 =caseMaskingState
b ofMaskingState
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 ::((foralla .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# ->caseState# 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 =dobound <-IO Bool
isCurrentThreadBound ifbound thenaction elsedoref <-newIORef undefined letaction_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 =dobound <-IO Bool
isCurrentThreadBound ifbound thendomv <-newEmptyMVar mask $ \forall a. IO a -> IO a
restore ->dotid <-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 letwait =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 elseaction 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