Make systhread mutexes errorcheck

This means that an exception is raised when attempting to lock a mutex
locked from the same thread, e.g. from an asynchronous callback.

This changes the behaviour on Windows where mutexes were recursive.

Add test for deadlock inside asynchronous callbacks.

Changes

@@ -84,6 +84,15 @@ Working version
    which has never existed.
   (Jacques-Henri Jourdan, review by Xavier Leroy)
 
+* #9757: With systhread, mutexes now raise an exception when
+  attempting to lock recursively, instead of deadlocking. This is
+  meant to improve the failure mode when locking a mutex or a channel
+  in a finaliser or a signal handler, that are already locked by the
+  thread. On Windows, mutexes used to be accidentally recursive, so
+  this might break Windows-specific programs that relied on this
+  behaviour.
+  (Guillaume Munch-Maccagnoni, review by)
+
 ### Code generation and optimizations:
 
 - #9620: Limit the number of parameters for an uncurried or untupled

otherlibs/systhreads/mutex.mli

@@ -36,7 +36,8 @@ val lock : t -> unit
 (** Lock the given mutex. Only one thread can have the mutex locked
    at any time. A thread that attempts to lock a mutex already locked
    by another thread will suspend until the other thread unlocks
-   the mutex. *)
+   the mutex. Attempting to lock the mutex from a thread that already
+   owns the lock results in a [Sys_error] exception. *)
 
 val try_lock : t -> bool
 (** Same as {!Mutex.lock}, but does not suspend the calling thread if

otherlibs/systhreads/st_posix.h

@@ -37,12 +37,22 @@ typedef int st_retcode;
 
 /* OS-specific initialization */
 
+static pthread_mutexattr_t lock_attr;
+
 static int st_initialize(void)
 {
+  if (pthread_mutexattr_init(&lock_attr) != 0)
+    caml_failwith("st_initialize");
+  pthread_mutexattr_settype(&lock_attr, PTHREAD_MUTEX_ERRORCHECK);
   caml_sigmask_hook = pthread_sigmask;
   return 0;
 }
 
+static void st_cleanup(void)
+{
+  pthread_mutexattr_destroy(&lock_attr);
+}
+
 /* Thread creation.  Created in detached mode if [res] is NULL. */
 
 typedef pthread_t st_thread_id;
@@ -199,7 +209,7 @@ static int st_mutex_create(st_mutex * res)
   int rc;
   st_mutex m = caml_stat_alloc_noexc(sizeof(pthread_mutex_t));
   if (m == NULL) return ENOMEM;
-  rc = pthread_mutex_init(m, NULL);
+  rc = pthread_mutex_init(m, &lock_attr);
   if (rc != 0) { caml_stat_free(m); return rc; }
   *res = m;
   return 0;

otherlibs/systhreads/st_stubs.c

@@ -276,6 +276,7 @@ static void caml_io_mutex_free(struct channel *chan)
 static void caml_io_mutex_lock(struct channel *chan)
 {
   st_mutex mutex = chan->mutex;
+  int retcode;
 
   if (mutex == NULL) {
     st_check_error(st_mutex_create(&mutex), "channel locking"); /*PR#7038*/
@@ -288,14 +289,16 @@ static void caml_io_mutex_lock(struct channel *chan)
   }
   /* If unsuccessful, block on mutex */
   caml_enter_blocking_section();
-  st_mutex_lock(mutex);
+  retcode = st_mutex_lock(mutex);
   /* Problem: if a signal occurs at this point,
      and the signal handler raises an exception, we will not
      unlock the mutex.  The alternative (doing the setspecific
      before locking the mutex is also incorrect, since we could
      then unlock a mutex that is unlocked or locked by someone else. */
-  st_tls_set(last_channel_locked_key, (void *) chan);
+  if (retcode == 0)
+    st_tls_set(last_channel_locked_key, (void *) chan);
   caml_leave_blocking_section();
+  st_check_error(retcode, "Mutex.lock");
 }
 
 static void caml_io_mutex_unlock(struct channel *chan)
@@ -524,6 +527,7 @@ CAMLprim value caml_thread_cleanup(value unit)   /* ML */
     caml_tick_thread_stop = 0;
     caml_tick_thread_running = 0;
   }
+  st_cleanup();
   return Val_unit;
 }
 

otherlibs/systhreads/st_win32.h

@@ -52,6 +52,10 @@ static DWORD st_initialize(void)
     return 0;
 }
 
+static void st_cleanup(void)
+{
+}
+
 /* Thread creation.  Created in detached mode if [res] is NULL. */
 
 typedef HANDLE st_thread_id;
@@ -160,53 +164,74 @@ Caml_inline void st_thread_yield(st_masterlock * m)
 
 /* Mutexes */
 
-typedef CRITICAL_SECTION * st_mutex;
+/* Win32 Critical Sections are recursive mutexes. We use a flag to
+   enforce that they are not locked recursively. */
+typedef struct {
+  CRITICAL_SECTION mutex;         /* to protect contents  */
+  int taken;                      /* 0 = free, 1 = taken */
+} st_errorcheck_mutex;
+
+typedef st_errorcheck_mutex * st_mutex;
 
 static DWORD st_mutex_create(st_mutex * res)
 {
-  st_mutex m = caml_stat_alloc_noexc(sizeof(CRITICAL_SECTION));
+  st_mutex m = caml_stat_alloc_noexc(sizeof(st_errorcheck_mutex));
   if (m == NULL) return ERROR_NOT_ENOUGH_MEMORY;
-  InitializeCriticalSection(m);
+  InitializeCriticalSection(&m->mutex);
+  m->taken = 0;
   *res = m;
   return 0;
 }
 
 static DWORD st_mutex_destroy(st_mutex m)
 {
-  DeleteCriticalSection(m);
+  DeleteCriticalSection(&m->mutex);
   caml_stat_free(m);
   return 0;
 }
 
-Caml_inline DWORD st_mutex_lock(st_mutex m)
-{
-  TRACE1("st_mutex_lock", m);
-  EnterCriticalSection(m);
-  TRACE1("st_mutex_lock (done)", m);
-  return 0;
-}
-
 /* Error codes with the 29th bit set are reserved for the application */
 
 #define PREVIOUSLY_UNLOCKED 0
 #define ALREADY_LOCKED (1<<29)
 
+Caml_inline DWORD st_mutex_lock(st_mutex m)
+{
+  TRACE1("st_mutex_lock", &m->mutex);
+  EnterCriticalSection(&m->mutex);
+  if (m->taken == 1) {
+    TRACE1("st_mutex_lock (recursive)", &m->mutex);
+    LeaveCriticalSection(&m->mutex);
+    return ALREADY_LOCKED;
+  }
+  m->taken = 1;
+  TRACE1("st_mutex_lock (done)", &m->mutex);
+  return PREVIOUSLY_UNLOCKED;
+}
+
 Caml_inline DWORD st_mutex_trylock(st_mutex m)
 {
-  TRACE1("st_mutex_trylock", m);
-  if (TryEnterCriticalSection(m)) {
-    TRACE1("st_mutex_trylock (success)", m);
+  TRACE1("st_mutex_trylock", &m->mutex);
+  if (TryEnterCriticalSection(&m->mutex)) {
+    TRACE1("st_mutex_trylock (success)", &m->mutex);
+    if (m->taken == 1) {
+      TRACE1("st_mutex_trylock (recursive)", &m->mutex);
+      LeaveCriticalSection(&m->mutex);
+      return ALREADY_LOCKED;
+    }
+    m->taken = 1;
     return PREVIOUSLY_UNLOCKED;
-  } else {
-    TRACE1("st_mutex_trylock (failure)", m);
-    return ALREADY_LOCKED;
   }
+  TRACE1("st_mutex_trylock (failure)", &m->mutex);
+  return ALREADY_LOCKED;
 }
 
 Caml_inline DWORD st_mutex_unlock(st_mutex m)
 {
   TRACE1("st_mutex_unlock", m);
-  LeaveCriticalSection(m);
+  CAMLassert(m->taken);
+  m->taken = 0;
+  LeaveCriticalSection(&m->mutex);
   return 0;
 }
 
@@ -308,17 +333,19 @@ static DWORD st_condvar_wait(st_condvar c, st_mutex m)
   c->waiters = &wait;
   LeaveCriticalSection(&c->lock);
   /* Release the mutex m */
-  LeaveCriticalSection(m);
+  m->taken = 0;
+  LeaveCriticalSection(&m->mutex);
   /* Wait for our event to be signaled.  There is no risk of lost
      wakeup, since we inserted ourselves on the waiting list of c
      before releasing m */
   TRACE1("st_condvar_wait: blocking on event", ev);
   if (WaitForSingleObject(ev, INFINITE) == WAIT_FAILED)
     return GetLastError();
   /* Reacquire the mutex m */
-  TRACE1("st_condvar_wait: restarted, acquiring mutex", m);
-  EnterCriticalSection(m);
-  TRACE1("st_condvar_wait: acquired mutex", m);
+  TRACE1("st_condvar_wait: restarted, acquiring mutex", &m->mutex);
+  EnterCriticalSection(&m->mutex);
+  m->taken = 1;
+  TRACE1("st_condvar_wait: acquired mutex", &m->mutex);
   return 0;
 }
 
@@ -373,16 +400,22 @@ static void st_check_error(DWORD retcode, char * msg)
 
   if (retcode == 0) return;
   if (retcode == ERROR_NOT_ENOUGH_MEMORY) caml_raise_out_of_memory();
-  ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
-                      NULL,
-                      retcode,
-                      0,
-                      err,
-                      sizeof(err)/sizeof(wchar_t),
-                      NULL);
-  if (! ret) {
-    ret =
-      swprintf(err, sizeof(err)/sizeof(wchar_t), L"error code %lx", retcode);
+  if (retcode == ALREADY_LOCKED) {
+    ret = swprintf(err, sizeof(err)/sizeof(wchar_t),
+                   L"Resource deadlock avoided");
+  } else {
+    ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
+                        FORMAT_MESSAGE_IGNORE_INSERTS,
+                        NULL,
+                        retcode,
+                        0,
+                        err,
+                        sizeof(err)/sizeof(wchar_t),
+                        NULL);
+    if (! ret) {
+      ret = swprintf(err, sizeof(err)/sizeof(wchar_t),
+                     L"error code %lx", retcode);
+    }
   }
   msglen = strlen(msg);
   errlen = win_wide_char_to_multi_byte(err, ret, NULL, 0);

testsuite/tests/lib-threads/mutex_errorcheck.ml

@@ -0,0 +1,36 @@
+(* TEST
+
+* hassysthreads
+include systhreads
+** bytecode
+** native
+
+*)
+
+let m = Mutex.create ()
+
+let on = ref true
+
+let create_finalised () =
+  let r = ref 0 in
+  Gc.finalise (fun _ -> if !on then begin
+    Mutex.lock m ;
+    print_endline "finalised!" ;
+    Mutex.unlock m
+  end) r;
+  r
+
+let () =
+  print_endline "start" ;
+  begin
+    try
+      while true do
+        Mutex.lock m ;
+        let x = create_finalised () in
+        Mutex.unlock m ;
+        ignore (Sys.opaque_identity x)
+      done
+    with
+      e -> (on := false ; print_endline (Printexc.to_string e))
+  end;
+  print_endline "end";

testsuite/tests/lib-threads/mutex_errorcheck.reference

@@ -0,0 +1,3 @@
+start
+Sys_error("Mutex.lock: Resource deadlock avoided")
+end