Merge pull request ocaml#11272 from gadmm/caml_try_get_caml_state3

Make `Caml_state` `NULL` while the domain lock is not held

(cherry picked from commit bc36f00)

Changes

@@ -128,6 +128,13 @@ OCaml 5.0
   Guillaume Munch-Maccagnoni, additional discussions with Stephen
   Dolan and Luc Maranget)
 
+- #5299, #4787, #11138, #11272: `Caml_state` is `NULL` when the domain lock is
+  not held. This allows to test if the current thread holds the lock of its
+  domain, and it makes it simpler to debug when one forgets to acquire
+  the lock.
+  (Guillaume Munch-Maccagnoni, review by Sadiq Jaffer, Xavier Leroy and
+  Gabriel Scherer)
+
 ### Code generation and optimizations:
 
 - #10972: ARM64 multicore support: OCaml & C stack separation;

manual/src/cmds/intf-c.etex

@@ -2500,6 +2500,10 @@ CAMLprim stub_gethostbyname(value vname)
 }
 \end{verbatim}
 
+During the time the domain lock is released, the thread-local variable
+"Caml_state" is set to "NULL". This can be used to determine if the
+thread currently holds its domain lock.
+
 Callbacks from C to OCaml must be performed while holding the master
 lock to the OCaml run-time system.  This is naturally the case if the
 callback is performed by a C primitive that did not release the

otherlibs/systhreads/st_pthreads.h

@@ -113,6 +113,11 @@ static void st_masterlock_init(st_masterlock * m)
   return;
 };
 
+static uintnat st_masterlock_waiters(st_masterlock * m)
+{
+  return atomic_load_acq(&m->waiters);
+}
+
 static void st_bt_lock_acquire(st_masterlock *m) {
 
   /* We do not want to signal the backup thread is it is not "working"
@@ -132,7 +137,7 @@ static void st_bt_lock_release(st_masterlock *m) {
   /* Here we do want to signal the backup thread iff there's
      no thread waiting to be scheduled, and the backup thread is currently
      idle. */
-  if (atomic_load_acq(&m->waiters) == 0 &&
+  if (st_masterlock_waiters(m) == 0 &&
       caml_bt_is_in_blocking_section() == 0) {
     caml_bt_exit_ocaml();
   }
@@ -179,15 +184,13 @@ static void st_masterlock_release(st_masterlock * m)
 */
 Caml_inline void st_thread_yield(st_masterlock * m)
 {
-  uintnat waiters;
-
   pthread_mutex_lock(&m->lock);
   /* We must hold the lock to call this. */
 
   /* We already checked this without the lock, but we might have raced--if
      there's no waiter, there's nothing to do and no one to wake us if we did
      wait, so just keep going. */
-  waiters = atomic_load_acq(&m->waiters);
+  uintnat waiters = st_masterlock_waiters(m);
 
   if (waiters == 0) {
     pthread_mutex_unlock(&m->lock);

otherlibs/systhreads/st_stubs.c

@@ -106,14 +106,25 @@ struct caml_thread_table {
 /* thread_table instance, up to Max_domains */
 static struct caml_thread_table thread_table[Max_domains];
 
+#define Thread_lock(dom_id) &thread_table[dom_id].thread_lock
+
+static void thread_lock_acquire(int dom_id)
+{
+  st_masterlock_acquire(Thread_lock(dom_id));
+}
+
+static void thread_lock_release(int dom_id)
+{
+  st_masterlock_release(Thread_lock(dom_id));
+}
+
+/* The remaining fields are accessed while holding the domain lock */
+
 /* The descriptor for the currently executing thread for this domain;
    also the head of a circular list of thread descriptors for this
    domain. */
 #define Active_thread thread_table[Caml_state->id].active_thread
 
-/* The master lock protecting this domain's thread chaining */
-#define Thread_main_lock thread_table[Caml_state->id].thread_lock
-
 /* Whether the "tick" thread is already running for this domain */
 #define Tick_thread_running thread_table[Caml_state->id].tick_thread_running
 
@@ -205,17 +216,18 @@ static void caml_thread_enter_blocking_section(void)
      of the current thread */
   caml_thread_save_runtime_state();
   /* Tell other threads that the runtime is free */
-  st_masterlock_release(&Thread_main_lock);
+  thread_lock_release(Caml_state->id);
 }
 
 static void caml_thread_leave_blocking_section(void)
 {
+  caml_thread_t th = st_tls_get(caml_thread_key);
   /* Wait until the runtime is free */
-  st_masterlock_acquire(&Thread_main_lock);
+  thread_lock_acquire(th->domain_id);
   /* Update Active_thread to point to the thread descriptor corresponding to
      the thread currently executing */
-  Active_thread = st_tls_get(caml_thread_key);
-  /* Restore the runtime state from the curr_thread descriptor */
+  Active_thread = th;
+  /* Restore the runtime state from the Active_thread descriptor */
   caml_thread_restore_runtime_state();
 }
 
@@ -342,7 +354,7 @@ static void caml_thread_reinitialize(void)
   /* The master lock needs to be initialized again. This process will also be
      the effective owner of the lock. So there is no need to run
      st_masterlock_acquire (busy = 1) */
-  st_masterlock_init(&Thread_main_lock);
+  st_masterlock_init(Thread_lock(Caml_state->id));
 }
 
 CAMLprim value caml_thread_join(value th);
@@ -381,11 +393,12 @@ CAMLprim value caml_thread_initialize_domain(value v)
   /* OS-specific initialization */
   st_initialize();
 
-  st_masterlock_init(&Thread_main_lock);
+  st_masterlock_init(Thread_lock(Caml_state->id));
 
   new_thread =
     (caml_thread_t) caml_stat_alloc(sizeof(struct caml_thread_struct));
 
+  new_thread->domain_id = Caml_state->id;
   new_thread->descr = caml_thread_new_descriptor(Val_unit);
   new_thread->next = new_thread;
   new_thread->prev = new_thread;
@@ -484,22 +497,24 @@ static void caml_thread_stop(void)
      so that it does not prevent the whole process from exiting (#9971) */
   if (Active_thread == NULL) caml_thread_cleanup(Val_unit);
 
-  st_masterlock_release(&Thread_main_lock);
+  thread_lock_release(Caml_state->id);
 }
 
 /* Create a thread */
 
+/* the thread lock is not held when entering */
 static void * caml_thread_start(void * v)
 {
   caml_thread_t th = (caml_thread_t) v;
+  int dom_id = th->domain_id;
   value clos;
 
-  caml_init_domain_self(th->domain_id);
+  caml_init_domain_self(dom_id);
 
   st_tls_set(caml_thread_key, th);
 
-  st_masterlock_acquire(&Thread_main_lock);
-  Active_thread = st_tls_get(caml_thread_key);
+  thread_lock_acquire(dom_id);
+  Active_thread = th;
   caml_thread_restore_runtime_state();
 
 #ifdef POSIX_SIGNALS
@@ -595,23 +610,24 @@ CAMLprim value caml_thread_new(value clos)
 
 /* Register a thread already created from C */
 
+#define Dom_c_threads 0
+
+/* the thread lock is not held when entering */
 CAMLexport int caml_c_thread_register(void)
 {
-  caml_thread_t th;
-  st_retcode err;
-
   /* Already registered? */
-  if (Caml_state == NULL) {
-    caml_init_domain_self(0);
-  };
   if (st_tls_get(caml_thread_key) != NULL) return 0;
+
+  CAMLassert(Caml_state == NULL);
+  caml_init_domain_self(Dom_c_threads);
+
   /* Take master lock to protect access to the runtime */
-  st_masterlock_acquire(&Thread_main_lock);
+  thread_lock_acquire(Dom_c_threads);
   /* Create a thread info block */
-  th = caml_thread_new_info();
+  caml_thread_t th = caml_thread_new_info();
   /* If it fails, we release the lock and return an error. */
   if (th == NULL) {
-    st_masterlock_release(&Thread_main_lock);
+    thread_lock_release(Dom_c_threads);
     return 0;
   }
   /* Add thread info block to the list of threads */
@@ -631,31 +647,28 @@ CAMLexport int caml_c_thread_register(void)
   th->descr = caml_thread_new_descriptor(Val_unit);  /* no closure */
 
   if (! Tick_thread_running) {
-    err = create_tick_thread();
+    st_retcode err = create_tick_thread();
     sync_check_error(err, "caml_register_c_thread");
     Tick_thread_running = 1;
   }
 
   /* Release the master lock */
-  st_masterlock_release(&Thread_main_lock);
+  thread_lock_release(Dom_c_threads);
   return 1;
 }
 
 /* Unregister a thread that was created from C and registered with
    the function above */
 
+/* the thread lock is not held when entering */
 CAMLexport int caml_c_thread_unregister(void)
 {
-  caml_thread_t th;
-
-  /* If Caml_state is not set, this thread was likely not registered */
-  if (Caml_state == NULL) return 0;
+  caml_thread_t th = st_tls_get(caml_thread_key);
 
-  th = st_tls_get(caml_thread_key);
-  /* Not registered? */
+  /* If this thread is not set, then it was not registered */
   if (th == NULL) return 0;
   /* Wait until the runtime is available */
-  st_masterlock_acquire(&Thread_main_lock);
+  thread_lock_acquire(Dom_c_threads);
   /*  Forget the thread descriptor */
   st_tls_set(caml_thread_key, NULL);
   /* Remove thread info block from list of threads, and free it */
@@ -669,7 +682,7 @@ CAMLexport int caml_c_thread_unregister(void)
     caml_thread_restore_runtime_state();
 
   /* Release the runtime */
-  st_masterlock_release(&Thread_main_lock);
+  thread_lock_release(Dom_c_threads);
   return 1;
 }
 
@@ -704,7 +717,9 @@ CAMLprim value caml_thread_uncaught_exception(value exn)
 
 CAMLprim value caml_thread_yield(value unit)
 {
-  if (atomic_load_acq(&Thread_main_lock.waiters) == 0) return Val_unit;
+  st_masterlock *m = Thread_lock(Caml_state->id);
+  if (st_masterlock_waiters(m) == 0)
+    return Val_unit;
 
   /* Do all the parts of a blocking section enter/leave except lock
      manipulation, which we'll do more efficiently in st_thread_yield. (Since
@@ -714,7 +729,7 @@ CAMLprim value caml_thread_yield(value unit)
 
   caml_raise_if_exception(caml_process_pending_signals_exn());
   caml_thread_save_runtime_state();
-  st_thread_yield(&Thread_main_lock);
+  st_thread_yield(m);
   Active_thread = st_tls_get(caml_thread_key);
   caml_thread_restore_runtime_state();
   caml_raise_if_exception(caml_process_pending_signals_exn());

otherlibs/systhreads/threads.h

@@ -56,11 +56,12 @@ CAMLextern int caml_c_thread_unregister(void);
 /* If a thread is created by C code (instead of by OCaml itself),
    it must be registered with the OCaml runtime system before
    being able to call back into OCaml code or use other runtime system
-   functions.  Just call [caml_c_thread_register] once.
-   Before the thread finishes, it must call [caml_c_thread_unregister].
+   functions.  Just call [caml_c_thread_register] once. The domain lock
+   is not held when [caml_c_thread_register] returns.
+   Before the thread finishes, it must call [caml_c_thread_unregister]
+   (without holding the domain lock).
    Both functions return 1 on success, 0 on error.
-   In multicore OCaml, note that threads created by C code will be registered
-   to the domain 0 threads chaining.
+   Note that threads registered by C code belong to the domain 0.
 */
 
 #ifdef __cplusplus

runtime/domain.c

@@ -1565,6 +1565,7 @@ CAMLexport void caml_acquire_domain_lock(void)
 {
   dom_internal* self = domain_self;
   caml_plat_lock(&self->domain_lock);
+  SET_Caml_state(self->state);
 }
 
 CAMLexport void caml_bt_enter_ocaml(void)
@@ -1581,6 +1582,7 @@ CAMLexport void caml_bt_enter_ocaml(void)
 CAMLexport void caml_release_domain_lock(void)
 {
   dom_internal* self = domain_self;
+  SET_Caml_state(NULL);
   caml_plat_unlock(&self->domain_lock);
 }
 

testsuite/tests/c-api/test_c_thread_has_lock.ml

@@ -0,0 +1,17 @@
+(* TEST
+   modules = "test_c_thread_has_lock_cstubs.c"
+   * bytecode
+   * native
+*)
+
+external test_with_lock : unit -> bool = "with_lock"
+external test_without_lock : unit -> bool = "without_lock"
+
+let passed b = Printf.printf (if b then "passed\n" else "failed\n")
+
+let f () =
+  passed (not (test_without_lock ())) ;
+  passed (test_with_lock ())
+
+let _ =
+  f ();

testsuite/tests/c-api/test_c_thread_has_lock.reference

@@ -0,0 +1,2 @@
+passed
+passed

testsuite/tests/c-api/test_c_thread_has_lock_cstubs.c

@@ -0,0 +1,17 @@
+#include "caml/mlvalues.h"
+#include "caml/domain_state.h"
+#include "caml/signals.h"
+
+value with_lock(value unit)
+{
+  return Val_bool(Caml_state != NULL);
+}
+
+value without_lock(value unit)
+{
+  int res;
+  caml_enter_blocking_section();
+  res = (Caml_state != NULL);
+  caml_leave_blocking_section();
+  return Val_bool(res);
+}

testsuite/tests/c-api/test_c_thread_has_lock_systhread.ml

@@ -0,0 +1,21 @@
+(* TEST
+   modules = "test_c_thread_has_lock_cstubs.c"
+   * hassysthreads
+   include systhreads
+   ** bytecode
+   ** native
+*)
+
+external test_with_lock : unit -> bool = "with_lock"
+external test_without_lock : unit -> bool = "without_lock"
+
+let passed b = Printf.printf (if b then "passed\n" else "failed\n")
+
+let f () =
+  passed (not (test_without_lock ())) ;
+  passed (test_with_lock ())
+
+let _ =
+  f ();
+  let t = Thread.create f () in
+  Thread.join t

testsuite/tests/c-api/test_c_thread_has_lock_systhread.reference

@@ -0,0 +1,4 @@
+passed
+passed
+passed
+passed