flambda-backend: Extend caml_locking_scheme with callbacks for thread…

… start/stop (#1411)

otherlibs/systhreads/st_stubs.c

@@ -172,6 +172,8 @@ struct caml_locking_scheme caml_default_locking_scheme =
   { &default_master_lock,
     (void (*)(void*))&st_masterlock_acquire,
     (void (*)(void*))&st_masterlock_release,
+    NULL,
+    NULL,
     (void (*)(void*))&st_masterlock_init,
     default_can_skip_yield,
     (void (*)(void*))&st_thread_yield };
@@ -649,6 +651,7 @@ static ST_THREAD_FUNCTION caml_thread_start(void * arg)
   caml_thread_t th = (caml_thread_t) arg;
   value clos;
   void * signal_stack;
+  struct caml_locking_scheme* sch;
 #ifdef NATIVE_CODE
   struct longjmp_buffer termination_buf;
   char tos;
@@ -659,6 +662,9 @@ static ST_THREAD_FUNCTION caml_thread_start(void * arg)
   /* Associate the thread descriptor with the thread */
   st_tls_set(thread_descriptor_key, (void *) th);
   st_thread_set_id(Ident(th->descr));
+  sch = atomic_load(&caml_locking_scheme);
+  if (sch->thread_start != NULL)
+    sch->thread_start(sch->context, Thread_type_caml);
   /* Acquire the global mutex */
   caml_leave_blocking_section();
   st_thread_set_id(Ident(th->descr));
@@ -673,6 +679,9 @@ static ST_THREAD_FUNCTION caml_thread_start(void * arg)
     caml_modify(&(Start_closure(th->descr)), Val_unit);
     caml_callback_exn(clos, Val_unit);
     caml_thread_stop();
+    sch = atomic_load(&caml_locking_scheme);
+    if (sch->thread_stop != NULL)
+      sch->thread_stop(sch->context, Thread_type_caml);
 #ifdef NATIVE_CODE
   }
 #endif
@@ -722,10 +731,15 @@ CAMLprim value caml_thread_new(value clos)          /* ML */
 CAMLexport int caml_c_thread_register(void)
 {
   caml_thread_t th;
+  struct caml_locking_scheme* sch;
 #ifdef NATIVE_CODE
   st_retcode err;
 #endif
 
+  sch = atomic_load(&caml_locking_scheme);
+  if (sch->thread_start != NULL)
+    sch->thread_start(sch->context, Thread_type_c_registered);
+
   /* Already registered? */
   if (st_tls_get(thread_descriptor_key) != NULL) return 0;
   /* Create a thread info block */
@@ -767,6 +781,7 @@ CAMLexport int caml_c_thread_register(void)
 
 CAMLexport int caml_c_thread_unregister(void)
 {
+  struct caml_locking_scheme* sch;
   caml_thread_t th = st_tls_get(thread_descriptor_key);
   /* Not registered? */
   if (th == NULL) return 0;
@@ -781,6 +796,9 @@ CAMLexport int caml_c_thread_unregister(void)
   if (all_threads == NULL) caml_thread_cleanup(Val_unit);
   /* Release the runtime */
   release_runtime_lock();
+  sch = atomic_load(&caml_locking_scheme);
+  if (sch->thread_stop != NULL)
+    sch->thread_stop(sch->context, Thread_type_c_registered);
   return 1;
 }
 

otherlibs/systhreads/threads.h

@@ -65,11 +65,19 @@ CAMLextern_libthreads int caml_c_thread_unregister(void);
    Both functions return 1 on success, 0 on error.
 */
 
+enum caml_thread_type { Thread_type_caml, Thread_type_c_registered };
 struct caml_locking_scheme {
   void* context;
   void (*lock)(void*);
   void (*unlock)(void*);
 
+  /* If non-NULL, these functions are called when threads start and stop.
+     For threads created by OCaml, that's at creation and termination.
+     For threads created by C, that's at caml_c_thread_register/unregister.
+     The lock is not held when these functions are called. */
+  void (*thread_start)(void*, enum caml_thread_type);
+  void (*thread_stop)(void*, enum caml_thread_type);
+
   /* Called after fork().
      The lock should be held after this function returns. */
   void (*reinitialize_after_fork)(void*);

testsuite/tests/lib-systhreads/swapgil.ml

@@ -6,6 +6,9 @@ include systhreads
 *** native
 *)
 
+external setup : unit -> unit = "swap_gil_setup"
+let () = setup ()
+
 let counter = ref 0
 
 external blocking_section : unit -> unit = "blocking_section"

testsuite/tests/lib-systhreads/swapgil_stubs.c

@@ -24,13 +24,18 @@ struct c_thread {
   pthread_t thread;
 };
 
+static __thread enum caml_thread_type thread_ty = Thread_type_caml;
+static __thread int started = 0;
 void* threadfn(struct c_thread* th)
 {
+  thread_ty = Thread_type_c_registered;
   caml_c_thread_register();
   caml_leave_blocking_section();
   caml_callback(th->callback, Val_unit);
   caml_enter_blocking_section();
+  if (!started) abort();
   caml_c_thread_unregister();
+  if (started) abort();
   return NULL;
 }
 
@@ -60,16 +65,19 @@ static void runtime_lock(void* m)
   timeout.tv_sec = 0;
   timeout.tv_usec = 1;
   select(0, NULL, NULL, NULL, &timeout);
+  if (!started) abort();
   if (pthread_mutex_lock(m) != 0) abort();
 }
 
 static void runtime_unlock(void* m)
 {
+  if (!started) abort();
   if (pthread_mutex_unlock(m) != 0) abort();
 }
 
 static void runtime_yield(void* m)
 {
+  if (!started) abort();
   if (pthread_mutex_unlock(m) != 0) abort();
 #ifdef __linux__
   /* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */
@@ -84,12 +92,31 @@ static void runtime_yield(void* m)
   if (pthread_mutex_lock(m) != 0) abort();
 }
 
+static void runtime_thread_start(void* m, enum caml_thread_type ty)
+{
+  if (ty != thread_ty) abort();
+  started = 1;
+}
+
+static void runtime_thread_stop(void* m, enum caml_thread_type ty)
+{
+  if (ty != thread_ty) abort();
+  started = 0;
+}
+
 static void runtime_reinitialize(void* m)
 {
   /* This test doesn't fork, so this never runs. */
   abort();
 }
 
+value swap_gil_setup(value unused)
+{
+  caml_default_locking_scheme.thread_start = runtime_thread_start;
+  caml_default_locking_scheme.thread_stop = runtime_thread_stop;
+  started = 1;
+}
+
 value swap_gil(value unused)
 {
   struct caml_locking_scheme* s;
@@ -104,6 +131,8 @@ value swap_gil(value unused)
   s->context = m;
   s->lock = runtime_lock;
   s->unlock = runtime_unlock;
+  s->thread_start = runtime_thread_start;
+  s->thread_stop = runtime_thread_stop;
   s->reinitialize_after_fork = runtime_reinitialize;
   s->can_skip_yield = NULL;
   s->yield = runtime_yield;