Skip to content

Commit 674a335

Browse files
authored
flambda-backend: Introduce an API to swap the runtime lock for a different lock. (#1365)
See caml_switch_runtime_locking_scheme in threads.h
1 parent 1ce68db commit 674a335

File tree

6 files changed

+303
-24
lines changed

6 files changed

+303
-24
lines changed

Makefile.common-jst

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -211,7 +211,7 @@ install_for_test: _install
211211
done; \
212212
ln -s _install/lib/ocaml stdlib; \
213213
mkdir runtime; \
214-
for f in ocamlrun* stdlib/caml stdlib/stublibs/*; do \
214+
for f in ocamlrun* stdlib/caml stdlib/stublibs/* runtime/caml/threads.h; do \
215215
ln -s ../$$f runtime/`basename $$f`; \
216216
done; \
217217
ln -s . lex; ln -s . yacc; \

otherlibs/systhreads/st_stubs.c

Lines changed: 106 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -37,8 +37,8 @@
3737
#include "caml/sys.h"
3838
#include "caml/memprof.h"
3939

40-
/* threads.h is *not* included since it contains the _external_ declarations for
41-
the caml_c_thread_register and caml_c_thread_unregister functions. */
40+
#define CAMLextern_libthreads
41+
#include "threads.h"
4242

4343
#ifndef NATIVE_CODE
4444
/* Initial size of bytecode stack when a thread is created (4 Ko) */
@@ -55,6 +55,23 @@
5555
#include "st_posix.h"
5656
#endif
5757

58+
/* Atomics */
59+
#if defined(__GNUC__) && __GNUC__ == 4 && __GNUC_MINOR__ == 8
60+
/* GCC 4.8 shipped with a working implementation of atomics, but no
61+
stdatomic.h header, so we need to use GCC-specific intrinsics. */
62+
63+
#define _Atomic /* GCC intrinsics work on normal variables */
64+
#define atomic_store(v, x) \
65+
__atomic_store_n((v), (x), __ATOMIC_SEQ_CST)
66+
#define atomic_load(v) \
67+
__atomic_load_n((v), __ATOMIC_SEQ_CST)
68+
#define atomic_exchange(v, x) \
69+
__atomic_exchange_n((v), (x), __ATOMIC_SEQ_CST)
70+
#else
71+
#include <stdatomic.h>
72+
#endif
73+
74+
5875
/* The ML value describing a thread (heap-allocated) */
5976

6077
struct caml_thread_descr {
@@ -111,7 +128,7 @@ static caml_thread_t all_threads = NULL;
111128
static caml_thread_t curr_thread = NULL;
112129

113130
/* The master lock protecting the OCaml runtime system */
114-
static st_masterlock caml_master_lock;
131+
static struct caml_locking_scheme* _Atomic caml_locking_scheme;
115132

116133
/* Whether the "tick" thread is already running */
117134
static int caml_tick_thread_running = 0;
@@ -143,6 +160,50 @@ extern struct longjmp_buffer caml_termination_jmpbuf;
143160
extern void (*caml_termination_hook)(void);
144161
#endif
145162

163+
/* The default locking scheme */
164+
static st_masterlock default_master_lock;
165+
166+
static int default_can_skip_yield(void* m)
167+
{
168+
return st_masterlock_waiters(m) == 0;
169+
}
170+
171+
struct caml_locking_scheme caml_default_locking_scheme =
172+
{ &default_master_lock,
173+
(void (*)(void*))&st_masterlock_acquire,
174+
(void (*)(void*))&st_masterlock_release,
175+
(void (*)(void*))&st_masterlock_init,
176+
default_can_skip_yield,
177+
(void (*)(void*))&st_thread_yield };
178+
179+
static void acquire_runtime_lock()
180+
{
181+
struct caml_locking_scheme* s;
182+
183+
/* The locking scheme may be changed by the thread that currently
184+
holds it. This means that it may change while we're waiting to
185+
acquire it, so by the time we acquire it it may no longer be the
186+
right scheme. */
187+
188+
retry:
189+
s = atomic_load(&caml_locking_scheme);
190+
s->lock(s->context);
191+
if (atomic_load(&caml_locking_scheme) != s) {
192+
/* This is no longer the right scheme. Unlock and try again */
193+
s->unlock(s->context);
194+
goto retry;
195+
}
196+
}
197+
198+
static void release_runtime_lock()
199+
{
200+
/* There is no tricky case here like in acquire, as only the holder
201+
of the lock can change it. (Here, that's us) */
202+
struct caml_locking_scheme* s;
203+
s = atomic_load(&caml_locking_scheme);
204+
s->unlock(s->context);
205+
}
206+
146207
/* Hook for scanning the stacks of the other threads */
147208

148209
static void (*prev_scan_roots_hook) (scanning_action);
@@ -182,7 +243,7 @@ static void memprof_ctx_iter(th_ctx_action f, void* data)
182243

183244
/* Saving and restoring runtime state in curr_thread */
184245

185-
Caml_inline void caml_thread_save_runtime_state(void)
246+
CAMLexport void caml_thread_save_runtime_state(void)
186247
{
187248
#ifdef NATIVE_CODE
188249
curr_thread->top_of_stack = Caml_state->top_of_stack;
@@ -208,8 +269,12 @@ Caml_inline void caml_thread_save_runtime_state(void)
208269
caml_memprof_leave_thread();
209270
}
210271

211-
Caml_inline void caml_thread_restore_runtime_state(void)
272+
CAMLexport void caml_thread_restore_runtime_state(void)
212273
{
274+
/* Update curr_thread to point to the thread descriptor corresponding
275+
to the thread currently executing */
276+
curr_thread = st_tls_get(thread_descriptor_key);
277+
213278
#ifdef NATIVE_CODE
214279
Caml_state->top_of_stack = curr_thread->top_of_stack;
215280
Caml_state->bottom_of_stack= curr_thread->bottom_of_stack;
@@ -234,6 +299,19 @@ Caml_inline void caml_thread_restore_runtime_state(void)
234299
caml_memprof_enter_thread(curr_thread->memprof_ctx);
235300
}
236301

302+
CAMLexport void caml_switch_runtime_locking_scheme(struct caml_locking_scheme* new)
303+
{
304+
struct caml_locking_scheme* old;
305+
306+
caml_thread_save_runtime_state();
307+
old = atomic_exchange(&caml_locking_scheme, new);
308+
/* We hold 'old', but it is no longer the runtime lock */
309+
old->unlock(old->context);
310+
acquire_runtime_lock();
311+
caml_thread_restore_runtime_state();
312+
}
313+
314+
237315
/* Hooks for caml_enter_blocking_section and caml_leave_blocking_section */
238316

239317

@@ -243,7 +321,7 @@ static void caml_thread_enter_blocking_section(void)
243321
of the current thread */
244322
caml_thread_save_runtime_state();
245323
/* Tell other threads that the runtime is free */
246-
st_masterlock_release(&caml_master_lock);
324+
release_runtime_lock();
247325
}
248326

249327
static void caml_thread_leave_blocking_section(void)
@@ -255,11 +333,7 @@ static void caml_thread_leave_blocking_section(void)
255333
DWORD error = GetLastError();
256334
#endif
257335
/* Wait until the runtime is free */
258-
st_masterlock_acquire(&caml_master_lock);
259-
/* Update curr_thread to point to the thread descriptor corresponding
260-
to the thread currently executing */
261-
curr_thread = st_tls_get(thread_descriptor_key);
262-
/* Restore the runtime state from the curr_thread descriptor */
336+
acquire_runtime_lock();
263337
caml_thread_restore_runtime_state();
264338
#ifdef _WIN32
265339
SetLastError(error);
@@ -419,6 +493,7 @@ static void caml_thread_remove_info(caml_thread_t th)
419493
static void caml_thread_reinitialize(void)
420494
{
421495
struct channel * chan;
496+
struct caml_locking_scheme* s;
422497

423498
/* Remove all other threads (now nonexistent)
424499
from the doubly-linked list of threads */
@@ -430,7 +505,8 @@ static void caml_thread_reinitialize(void)
430505
/* Reinitialize the master lock machinery,
431506
just in case the fork happened while other threads were doing
432507
caml_leave_blocking_section */
433-
st_masterlock_init(&caml_master_lock);
508+
s = atomic_load(&caml_locking_scheme);
509+
s->reinitialize_after_fork(s->context);
434510
/* Tick thread is not currently running in child process, will be
435511
re-created at next Thread.create */
436512
caml_tick_thread_running = 0;
@@ -454,7 +530,8 @@ CAMLprim value caml_thread_initialize(value unit) /* ML */
454530
/* OS-specific initialization */
455531
st_initialize();
456532
/* Initialize and acquire the master lock */
457-
st_masterlock_init(&caml_master_lock);
533+
st_masterlock_init(&default_master_lock);
534+
caml_locking_scheme = &caml_default_locking_scheme;
458535
/* Initialize the keys */
459536
st_tls_newkey(&thread_descriptor_key);
460537
st_tls_newkey(&last_channel_locked_key);
@@ -562,7 +639,7 @@ static void caml_thread_stop(void)
562639
/* OS-specific cleanups */
563640
st_thread_cleanup();
564641
/* Release the runtime system */
565-
st_masterlock_release(&caml_master_lock);
642+
release_runtime_lock();
566643
}
567644

568645
/* Create a thread */
@@ -658,7 +735,7 @@ CAMLexport int caml_c_thread_register(void)
658735
th->top_of_stack = (char *) &err;
659736
#endif
660737
/* Take master lock to protect access to the chaining of threads */
661-
st_masterlock_acquire(&caml_master_lock);
738+
acquire_runtime_lock();
662739
/* Add thread info block to the list of threads */
663740
if (all_threads == NULL) {
664741
th->next = th;
@@ -673,7 +750,7 @@ CAMLexport int caml_c_thread_register(void)
673750
/* Associate the thread descriptor with the thread */
674751
st_tls_set(thread_descriptor_key, (void *) th);
675752
/* Release the master lock */
676-
st_masterlock_release(&caml_master_lock);
753+
release_runtime_lock();
677754
/* Now we can re-enter the run-time system and heap-allocate the descriptor */
678755
caml_leave_blocking_section();
679756
th->descr = caml_thread_new_descriptor(Val_unit); /* no closure */
@@ -694,7 +771,7 @@ CAMLexport int caml_c_thread_unregister(void)
694771
/* Not registered? */
695772
if (th == NULL) return 0;
696773
/* Wait until the runtime is available */
697-
st_masterlock_acquire(&caml_master_lock);
774+
acquire_runtime_lock();
698775
/* Forget the thread descriptor */
699776
st_tls_set(thread_descriptor_key, NULL);
700777
/* Remove thread info block from list of threads, and free it */
@@ -703,7 +780,7 @@ CAMLexport int caml_c_thread_unregister(void)
703780
so that it does not prevent the whole process from exiting (#9971) */
704781
if (all_threads == NULL) caml_thread_cleanup(Val_unit);
705782
/* Release the runtime */
706-
st_masterlock_release(&caml_master_lock);
783+
release_runtime_lock();
707784
return 1;
708785
}
709786

@@ -771,7 +848,11 @@ CAMLprim value caml_thread_exit(value unit) /* ML */
771848

772849
CAMLprim value caml_thread_yield(value unit) /* ML */
773850
{
774-
if (st_masterlock_waiters(&caml_master_lock) == 0) return Val_unit;
851+
struct caml_locking_scheme* s;
852+
853+
s = atomic_load(&caml_locking_scheme);
854+
if (s->can_skip_yield != NULL && s->can_skip_yield(s->context))
855+
return Val_unit;
775856

776857
/* Do all the parts of a blocking section enter/leave except lock
777858
manipulation, which we'll do more efficiently in st_thread_yield. (Since
@@ -781,8 +862,12 @@ CAMLprim value caml_thread_yield(value unit) /* ML */
781862
caml_raise_async_if_exception(caml_process_pending_signals_exn(),
782863
"signal handler");
783864
caml_thread_save_runtime_state();
784-
st_thread_yield(&caml_master_lock);
785-
curr_thread = st_tls_get(thread_descriptor_key);
865+
s->yield(s->context);
866+
if (atomic_load(&caml_locking_scheme) != s) {
867+
/* The lock we have is no longer the runtime lock */
868+
s->unlock(s->context);
869+
acquire_runtime_lock();
870+
}
786871
caml_thread_restore_runtime_state();
787872
caml_raise_async_if_exception(caml_process_pending_signals_exn(),
788873
"signal handler");

otherlibs/systhreads/threads.h

Lines changed: 41 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -50,8 +50,12 @@ CAMLextern void caml_leave_blocking_section (void);
5050
use the runtime system (typically, a blocking I/O operation).
5151
*/
5252

53-
CAMLextern int caml_c_thread_register(void);
54-
CAMLextern int caml_c_thread_unregister(void);
53+
/* These functions are defined in the threads library, not the runtime */
54+
#ifndef CAMLextern_libthreads
55+
#define CAMLextern_libthreads CAMLextern
56+
#endif
57+
CAMLextern_libthreads int caml_c_thread_register(void);
58+
CAMLextern_libthreads int caml_c_thread_unregister(void);
5559

5660
/* If a thread is created by C code (instead of by OCaml itself),
5761
it must be registered with the OCaml runtime system before
@@ -61,6 +65,41 @@ CAMLextern int caml_c_thread_unregister(void);
6165
Both functions return 1 on success, 0 on error.
6266
*/
6367

68+
struct caml_locking_scheme {
69+
void* context;
70+
void (*lock)(void*);
71+
void (*unlock)(void*);
72+
73+
/* Called after fork().
74+
The lock should be held after this function returns. */
75+
void (*reinitialize_after_fork)(void*);
76+
77+
/* can_skip_yield and yield are both called with the lock held,
78+
and expect it held on return */
79+
int (*can_skip_yield)(void*);
80+
void (*yield)(void*);
81+
};
82+
83+
extern struct caml_locking_scheme caml_default_locking_scheme;
84+
85+
/* Switch to a new runtime locking scheme.
86+
87+
The old runtime lock must be held (i.e. not in a blocking section),
88+
and the new runtime lock must not be held. After this function
89+
returns, the old lock is released and the new one is held.
90+
91+
There is a period during this function when neither lock is held,
92+
so context-switches may occur. */
93+
CAMLextern_libthreads
94+
void caml_switch_runtime_locking_scheme(struct caml_locking_scheme*);
95+
96+
CAMLextern_libthreads
97+
void caml_thread_save_runtime_state(void);
98+
99+
CAMLextern_libthreads
100+
void caml_thread_restore_runtime_state(void);
101+
102+
64103
#ifdef __cplusplus
65104
}
66105
#endif
Lines changed: 42 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
(* TEST
2+
modules = "swapgil_stubs.c"
3+
* hassysthreads
4+
include systhreads
5+
** hasunix
6+
*** native
7+
*)
8+
9+
let counter = ref 0
10+
11+
external blocking_section : unit -> unit = "blocking_section"
12+
13+
type c_thread
14+
external create_c_thread : (unit -> unit) -> c_thread = "create_c_thread"
15+
external join_c_thread : c_thread -> unit = "join_c_thread"
16+
17+
external swap_gil : unit -> unit = "swap_gil"
18+
19+
let threadfn () =
20+
for i = 1 to 1_000 do
21+
incr counter;
22+
let junk = Sys.opaque_identity (ref !counter) in
23+
ignore junk;
24+
match i mod 100, i mod 10 with
25+
| _, 0 -> Thread.yield ()
26+
| _, 1 -> blocking_section ()
27+
| 22, _ -> Gc.minor ()
28+
| _, 3 -> swap_gil ()
29+
| _ -> ()
30+
done
31+
32+
let () =
33+
let open Either in
34+
let threads =
35+
List.init 40 (fun i ->
36+
if i land 1 = 0 then
37+
Left (Thread.create threadfn ())
38+
else
39+
Right (create_c_thread threadfn))
40+
in
41+
List.iter (function Left th -> Thread.join th | Right ct -> join_c_thread ct) threads;
42+
Printf.printf "%d\n" !counter
Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
40000

0 commit comments

Comments
 (0)