Merge pull request ocaml#13504 from toots/thread-name

Add thread set_name API.

Changes

@@ -89,6 +89,9 @@ Working version
   default environment (where `TEMP` is set), there is no discernible change.
   (Antonin Décimo, review by Nicolás Ojeda Bär and David Allsopp)
 
+- #13504: Add `Thread.set_current_thread_name`.
+  (Romain Beauxis, review by Gabriel Scherer and Antonin Décimo)
+
 ### Tools:
 
 - #12019: ocamlc: add `align_double` and `align_int64` to `ocamlc -config`

configure.ac

@@ -2419,6 +2419,36 @@ AC_LINK_IFELSE(
     AC_DEFINE([HAS_BSD_GETAFFINITY_NP], [1])],
     [AC_MSG_RESULT([pthread_getaffinity_np not found])])])
 
+## prctl
+AC_CHECK_DECL(
+  [prctl],
+  [AC_DEFINE([HAS_DECL_PRCTL] , [1])],
+  [],
+  [#include <sys/prctl.h>])
+
+## pthread_setname_np
+AC_CHECK_FUNCS(
+  [pthread_setname_np],
+  [AC_DEFINE([HAS_PTHREAD_SETNAME_NP], [1])])
+
+## pthread_set_name_np
+AC_CHECK_FUNCS(
+  [pthread_set_name_np],
+  [AC_DEFINE([HAS_PTHREAD_SET_NAME_NP], [1])])
+
+## SetThreadDescription
+AC_CHECK_FUNCS(
+  [SetThreadDescription],
+  [AC_DEFINE([HAS_SETTHREADDESCRIPTION], [1])])
+
+AC_CHECK_DECL(
+  [SetThreadDescription],
+  [AC_DEFINE([HAS_DECL_SETTHREADDESCRIPTION], [1])],
+  [],
+  [[#define WIN32_LEAN_AND_MEAN
+    #include <windows.h>
+    #include <processthreadsapi.h>]])
+
 ## Activate the systhread library
 
 AS_CASE([$enable_systhreads,$enable_unix_lib],

otherlibs/systhreads/st_stubs.c

@@ -15,6 +15,31 @@
 
 #define CAML_INTERNALS
 
+#define _GNU_SOURCE /* helps to find pthread_setname_np() */
+#include "caml/config.h"
+
+#if defined(_WIN32)
+#  include <windows.h>
+#  include <processthreadsapi.h>
+#  include <caml/osdeps.h>
+
+#  if defined(HAS_SETTHREADDESCRIPTION) && \
+      !defined(HAS_DECL_SETTHREADDESCRIPTION)
+HRESULT SetThreadDescription(HANDLE hThread, PCWSTR lpThreadDescription);
+#  endif
+
+#elif defined(HAS_DECL_PRCTL)
+#  include <sys/prctl.h>
+#elif defined(HAS_PTHREAD_SETNAME_NP) || defined(HAS_PTHREAD_SET_NAME_NP)
+#  include <pthread.h>
+
+#  if defined(HAS_PTHREAD_NP_H)
+#    include <pthread_np.h>
+#  endif
+#endif
+
+#include "caml/misc.h"
+
 #if defined(_WIN32) && !defined(NATIVE_CODE) && !defined(_MSC_VER)
 /* Ensure that pthread.h marks symbols __declspec(dllimport) so that they can be
    picked up from the runtime (which will have linked winpthreads statically).
@@ -951,3 +976,42 @@ static st_retcode caml_threadstatus_wait (value wrapper)
 
   CAMLreturnT(st_retcode, retcode);
 }
+
+/* Set the current thread's name. */
+CAMLprim value caml_set_current_thread_name(value name)
+{
+#if defined(_WIN32)
+
+#  if defined(HAS_SETTHREADDESCRIPTION)
+  wchar_t *thread_name = caml_stat_strdup_to_utf16(String_val(name));
+  SetThreadDescription(GetCurrentThread(), thread_name);
+  caml_stat_free(thread_name);
+#  endif
+
+#  if defined(HAS_PTHREAD_SETNAME_NP)
+  // We are using both methods.
+  // See: https://github.com/ocaml/ocaml/pull/13504#discussion_r1786358928
+  pthread_setname_np(pthread_self(), String_val(name));
+#  endif
+
+#elif defined(HAS_DECL_PRCTL)
+  prctl(PR_SET_NAME, String_val(name));
+#elif defined(HAS_PTHREAD_SETNAME_NP)
+#  if defined(__APPLE__)
+  pthread_setname_np(String_val(name));
+#  elif defined(__NetBSD__)
+  pthread_setname_np(pthread_self(), "%s", String_val(name));
+#  else
+  pthread_setname_np(pthread_self(), String_val(name));
+#  endif
+#elif defined(HAS_PTHREAD_SET_NAME_NP)
+  pthread_set_name_np(pthread_self(), String_val(name));
+#else
+  if (caml_runtime_warnings_active()) {
+    fprintf(stderr, "set thread name not implemented\n");
+    fflush(stderr);
+  }
+#endif
+
+  return Val_unit;
+}

otherlibs/systhreads/thread.ml

@@ -92,3 +92,6 @@ let wait_pid p = Unix.waitpid [] p
 
 let sigmask = Unix.sigprocmask
 let wait_signal = Unix.sigwait
+
+external set_current_thread_name : string -> unit =
+        "caml_set_current_thread_name"

otherlibs/systhreads/thread.mli

@@ -45,6 +45,15 @@ val id : t -> int
    is an integer that identifies uniquely the thread.
    It can be used to build data structures indexed by threads. *)
 
+val set_current_thread_name : string -> unit
+(** Set the thread's name. This should be called from within the thread
+    function. Setting thread name is available on most systems.
+
+    This does nothing if the functionality is not implemented but will
+    print a warning on the standard error if enabled.
+
+    @since 5.4 *)
+
 exception Exit
 (** Exception raised by user code to initiate termination of the
     current thread.

runtime/caml/s.h.in

@@ -108,6 +108,16 @@
 
 #undef HAS_PTHREAD_NP_H
 
+#undef HAS_DECL_PRCTL
+
+#undef HAS_PTHREAD_SETNAME_NP
+
+#undef HAS_PTHREAD_SET_NAME_NP
+
+#undef HAS_SETTHREADDESCRIPTION
+
+#undef HAS_DECL_SETTHREADDESCRIPTION
+
 #undef HAS_UNISTD
 
 /* Define HAS_UNISTD if you have /usr/include/unistd.h. */