Permalink
Fetching contributors…
Cannot retrieve contributors at this time
133 lines (105 sloc) 4.72 KB
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI,
UnliftedFFITypes, DeriveDataTypeable, MagicHash
#-}
{- | GHCJS has two types of threads. Regular, asynchronous threads are
started with `h$run`, are managed by the scheduler and run in the
background. `h$run` returns immediately.
Synchronous threads are started with `h$runSync`, which returns
when the thread has run to completion. When a synchronous thread
does an operation that would block, like accessing an MVar or
an asynchronous FFI call, it cannot continue synchronously.
There are two ways this can be resolved, depending on the
second argument of the `h$runSync` call:
* The action is aborted and the thread receives a 'WouldBlockException'
* The thread continues asynchronously, `h$runSync` returns
Note: when a synchronous thread encounters a black hole from
another thread, it tries to steal the work from that thread
to avoid blocking. In some cases that might not be possible,
for example when the data accessed is produced by a lazy IO
operation. This is resolved the same way as blocking on an IO
action would be.
-}
module GHCJS.Concurrent ( isThreadSynchronous
, isThreadContinueAsync
, OnBlocked(..)
, WouldBlockException(..)
, withoutPreemption
, synchronously
) where
import GHCJS.Prim
import Control.Applicative
import Control.Concurrent
import qualified Control.Exception as Ex
import GHC.Exts (ThreadId#)
import GHC.Conc.Sync (ThreadId(..))
import Data.Bits (testBit)
import Data.Data
import Data.Typeable
import Unsafe.Coerce
{- |
The runtime tries to run synchronous threads to completion. Sometimes it's
not possible to continue running a thread, for example when the thread
tries to take an empty 'MVar'. The runtime can then either throw a
'WouldBlockException', aborting the blocking action, or continue the
thread asynchronously.
-}
data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked
| ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked
deriving (Data, Typeable, Enum, Show, Eq, Ord)
{- |
Run the action without the scheduler preempting the thread. When a blocking
action is encountered, the thread is still suspended and will continue
without preemption when it's woken up again.
When the thread encounters a black hole from another thread, the scheduler
will attempt to clear it by temporarily switching to that thread.
-}
withoutPreemption :: IO a -> IO a
withoutPreemption x = Ex.mask $ \restore -> do
oldS <- js_setNoPreemption True
if oldS
then restore x
else restore x `Ex.finally` js_setNoPreemption False
{-# INLINE withoutPreemption #-}
{- |
Run the action synchronously, which means that the thread will not
be preempted by the scheduler. If the thread encounters a blocking
operation, the runtime throws a WouldBlock exception.
When the thread encounters a black hole from another thread, the scheduler
will attempt to clear it by temporarily switching to that thread.
-}
synchronously :: IO a -> IO a
synchronously x = Ex.mask $ \restore -> do
oldS <- js_setSynchronous True
if oldS
then restore x
else restore x `Ex.finally` js_setSynchronous False
{-# INLINE synchronously #-}
{- | Returns whether the 'ThreadId' is a synchronous thread
-}
isThreadSynchronous :: ThreadId -> IO Bool
isThreadSynchronous = fmap (`testBit` 0) . syncThreadState
{- |
Returns whether the 'ThreadId' will continue running async. Always
returns 'True' when the thread is not synchronous.
-}
isThreadContinueAsync :: ThreadId -> IO Bool
isThreadContinueAsync = fmap (`testBit` 1) . syncThreadState
{- |
Returns whether the 'ThreadId' is not preemptible. Always
returns 'True' when the thread is synchronous.
-}
isThreadNonPreemptible :: ThreadId -> IO Bool
isThreadNonPreemptible = fmap (`testBit` 2) . syncThreadState
syncThreadState :: ThreadId-> IO Int
syncThreadState (ThreadId tid) = js_syncThreadState tid
-- ----------------------------------------------------------------------------
foreign import javascript unsafe "h$syncThreadState($1)"
js_syncThreadState :: ThreadId# -> IO Int
foreign import javascript unsafe
"$r = h$currentThread.noPreemption;\
\h$currentThread.noPreemption = $1;"
js_setNoPreemption :: Bool -> IO Bool;
foreign import javascript unsafe
"$r = h$currentThread.isSynchronous;\
\h$currentThread.isSynchronous = $1;"
js_setSynchronous :: Bool -> IO Bool