1 (* Copyright (C
) 2014 Matthew Fluet
.
2 * Copyright (C
) 2004-2008 Henry Cejtin
, Matthew Fluet
, Suresh
3 * Jagannathan
, and Stephen Weeks
.
5 * MLton is released under a BSD
-style license
.
6 * See the file MLton
-LICENSE for details
.
9 structure MLtonThread
:> MLTON_THREAD_EXTRA
=
12 structure Prim
= Primitive
.MLton
.Thread
14 fun die (s
: string): 'a
=
15 (PrimitiveFFI
.Stdio
.print s
16 ; PrimitiveFFI
.Posix
.Process
.exit
1
17 ; let exception DieFailed
21 val gcState
= Primitive
.MLton
.GCState
.gcState
23 structure AtomicState
=
25 datatype t
= NonAtomic | Atomic
of int
31 val atomicBegin
= atomicBegin
32 val atomicEnd
= atomicEnd
33 val atomicState
= fn () =>
34 case atomicState () of
35 0wx0
=> AtomicState
.NonAtomic
36 | w
=> AtomicState
.Atomic (Word32
.toInt w
)
40 (atomicBegin (); DynamicWind
.wind (f
, atomicEnd
))
44 | Interrupted
of Prim
.thread
46 (* In
Paused (f
, t
), f is guaranteed to not
raise an
exception. *)
47 | Paused
of ((unit
-> 'a
) -> unit
) * Prim
.thread
49 datatype 'a t
= T
of 'a thread ref
56 fun prepend (T r
: 'a t
, f
: 'b
-> 'a
): 'b t
=
60 Dead
=> raise Fail
"prepend to a Dead thread"
61 | Interrupted _
=> raise Fail
"prepend to a Interrupted thread"
62 | New g
=> New (g
o f
)
63 |
Paused (g
, t
) => Paused (fn h
=> g (f
o h
), t
)
68 fun prepare (t
: 'a t
, v
: 'a
): Runnable
.t
=
69 prepend (t
, fn () => v
)
71 fun new f
= T (ref (New f
))
75 val func
: (unit
-> unit
) option ref
= ref NONE
76 val base
: Prim
.preThread
=
78 val () = Prim
.copyCurrent ()
81 NONE
=> Prim
.savedPre gcState
83 (* This branch never returns
. *)
90 (x () handle e
=> MLtonExn
.topLevelHandler e
)
91 ; die
"Thread didn't exit properly.\n"
95 fun newThread (f
: unit
-> unit
) : Prim
.thread
=
98 val () = func
:= SOME f
103 val switching
= ref
false
105 fun 'a
atomicSwitch (f
: 'a t
-> Runnable
.t
): 'a
=
109 val () = atomicEnd ()
112 raise Fail
"nested Thread.switch"
116 val _
= switching
:= true
117 val r
: (unit
-> 'a
) ref
=
118 ref (fn () => die
"Thread.atomicSwitch didn't set r.\n")
119 val t
: 'a thread ref
=
120 ref (Paused (fn x
=> r
:= x
, Prim
.current gcState
))
121 fun fail e
= (t
:= Dead
125 val (T t
': Runnable
.t
) = f (T t
) handle e
=> fail e
127 case !t
' before t
' := Dead
of
128 Dead
=> fail (Fail
"switch to a Dead thread")
130 | New g
=> (atomicBegin (); newThread g
)
131 |
Paused (f
, t
) => (f (fn () => ()); t
)
132 val _
= switching
:= false
133 (* Atomic
1 when Paused
/Interrupted
, Atomic
2 when New
*)
134 val _
= Prim
.switchTo
primThread (* implicit
atomicEnd() *)
135 (* Atomic
0 when resuming
*)
145 fun fromPrimitive (t
: Prim
.thread
): Runnable
.t
=
146 T (ref (Interrupted t
))
148 fun toPrimitive (t
as T r
: unit t
): Prim
.thread
=
150 Dead
=> die
"Thread.toPrimitive saw Dead.\n"
156 (fn cur
: Prim
.thread t
=>
158 (prepend (t
, fn () =>
161 prepare (cur
, toPrimitive t
'))),
170 val signalHandler
: Prim
.thread option ref
= ref NONE
171 datatype state
= Normal | InHandler
172 val state
: state ref
= ref Normal
174 fun amInSignalHandler () = InHandler
= !state
176 fun setSignalHandler (f
: Runnable
.t
-> Runnable
.t
): unit
=
178 val _
= Primitive
.MLton
.installSignalHandler ()
182 val _
= state
:= InHandler
183 val t
= f (fromPrimitive (Prim
.saved gcState
))
184 val _
= state
:= Normal
185 val _
= Prim
.finishSignalHandler gcState
192 Paused (f
, _
) => f (fn () => ())
193 | _
=> raise die
"Thread.setSignalHandler saw strange thread"
196 end) (* implicit
atomicEnd () *)
202 (new (fn () => loop () handle e
=> MLtonExn
.topLevelHandler e
))
203 val _
= signalHandler
:= SOME p
205 Prim
.setSignalHandler (gcState
, p
)
208 fun switchToSignalHandler () =
211 val () = atomicBegin ()
213 val () = Prim
.startSignalHandler
gcState (* implicit
atomicBegin () *)
216 case !signalHandler
of
217 NONE
=> raise Fail
"no signal handler installed"
218 | SOME t
=> Prim
.switchTo
t (* implicit
atomicEnd() *)
226 val register
: int * (MLtonPointer
.t
-> unit
) -> unit
=
229 Array
.array (Int32
.toInt (Primitive
.MLton
.FFI
.numExports
),
230 fn _
=> raise Fail
"undefined export")
231 val worker
: (Prim
.thread
* Prim
.thread option ref
) option ref
= ref NONE
232 fun mkWorker (): Prim
.thread
* Prim
.thread option ref
=
234 val thisWorker
: (Prim
.thread
* Prim
.thread option ref
) option ref
= ref NONE
235 val savedRef
: Prim
.thread option ref
= ref NONE
239 val p
= Primitive
.MLton
.FFI
.getOpArgsResPtr ()
242 val i
= MLtonPointer
.getInt32 (MLtonPointer
.getPointer (p
, 0), 0)
244 (Array
.sub (exports
, Int32
.toInt i
) p
)
247 (TextIO.stdErr
, "Call from C to SML raised exception.\n")
248 ; MLtonExn
.topLevelHandler e
)
250 val _
= atomicBegin ()
252 val _
= worker
:= !thisWorker
253 val _
= Prim
.setSaved (gcState
, valOf (!savedRef
))
254 val _
= savedRef
:= NONE
255 val _
= Prim
.returnToC () (* implicit
atomicEnd() *)
259 val workerThread
= toPrimitive (new workerLoop
)
260 val _
= thisWorker
:= SOME (workerThread
, savedRef
)
262 (workerThread
, savedRef
)
264 fun handlerLoop (): unit
=
267 val saved
= Prim
.saved gcState
268 val (workerThread
, savedRef
) =
271 |
SOME (workerThread
, savedRef
) =>
273 ; (workerThread
, savedRef
))
274 val _
= savedRef
:= SOME saved
275 val _
= Prim
.switchTo (workerThread
) (* implicit
atomicEnd() *)
279 val handlerThread
= toPrimitive (new handlerLoop
)
280 val _
= Prim
.setCallFromCHandler (gcState
, handlerThread
)
282 fn (i
, f
) => Array
.update (exports
, i
, f
)