-
Notifications
You must be signed in to change notification settings - Fork 67
/
Concurrent.hs
119 lines (94 loc) · 4.26 KB
/
Concurrent.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
{-# 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 GHC.JS.Prim
import GHC.JS.Foreign.Callback (OnBlocked(..))
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
{- |
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"
js_syncThreadState :: ThreadId# -> IO Int
foreign import javascript unsafe
"((x) => { var r = h$currentThread.noPreemption; h$currentThread.noPreemption = x; return r; })"
js_setNoPreemption :: Bool -> IO Bool;
foreign import javascript unsafe
"((x) => { var r = h$currentThread.isSynchronous; h$currentThread.isSynchronous = x; return r; })"
js_setSynchronous :: Bool -> IO Bool