ada: Set thread description on Windows

On Windows, the tasking runtime now calls SetThreadDescription on the
underlying system threads with the task images as argument.

gcc/ada/ChangeLog:

	* adaint.c (__gnat_set_thread_description): New function.
	* libgnarl/s-taprop__mingw.adb (Enter_Task): Set thread description.
	* rtinit.c (__gnat_runtime_initialize): Set up function pointer.
	* mingw32.h (HRESULT, pSetThreadDescription): New.

diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 1b99312630c9dd69f547154db47d0b9b48086f17..78be4e0b7b534b7cadc19569e376e675160ea4fc 100644 (file)
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -3720,6 +3720,35 @@ void __gnat_killprocesstree (int pid, int sig_num)
   */
 }
 
+#if defined (_WIN32)
+
+int __gnat_set_thread_description(HANDLE h, char *descr, int length) {
+
+  /* This function is a no-op if Unicode support is not enabled */
+#ifdef GNAT_UNICODE_SUPPORT
+
+  if (!pSetThreadDescription) {
+    /* This is presumably not an error case, SetThreadDescription is simply
+       not available in the current Windows version. */
+    return 1;
+  }
+
+  TCHAR wdescr[length + 1];
+
+  S2WSC (wdescr, descr, length + 1);
+
+  HRESULT res = pSetThreadDescription(h, wdescr);
+  if (FAILED(res)) {
+    return 0;
+  }
+
+#endif
+
+  return 1;
+}
+
+#endif /* defined (_WIN32) */
+
 #ifdef __cplusplus
 }
 #endif

diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb
index f7deb6ea7e967433d85c80b03b49e43b46fc2394..4153e32be1a3f2ac7ac9950108bb0659ce963ba6 100644 (file)
--- a/gcc/ada/libgnarl/s-taprop__mingw.adb
+++ b/gcc/ada/libgnarl/s-taprop__mingw.adb
@@ -740,6 +740,34 @@ package body System.Task_Primitives.Operations is
       Get_Stack_Bounds
         (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address,
          Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
+
+      if Self_ID.Common.Task_Image_Len > 0 then
+         declare
+            function Set_Thread_Description
+              (H : Thread_Id; Descr : Address; Length : Integer)
+               return Integer;
+            pragma
+              Import
+                (C, Set_Thread_Description, "__gnat_set_thread_description");
+
+            Nul_Terminated_Image : constant String :=
+              Self_ID.Common.Task_Image
+                (Self_ID.Common.Task_Image'First
+                 ..
+                   Self_ID.Common.Task_Image'First
+                   + Self_ID.Common.Task_Image_Len
+                   - 1)
+              & ASCII.NUL;
+
+            Result : constant Integer :=
+              Set_Thread_Description
+                (Self_ID.Common.LL.Thread,
+                 Nul_Terminated_Image'Address,
+                 Self_ID.Common.Task_Image_Len);
+         begin
+            pragma Assert (Result = 1);
+         end;
+      end if;
    end Enter_Task;
 
    -------------------

diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h
index 5f8c9f5ac7b1f88b7065c2144fd05f3d535de993..9506ccc438ed0e6835dd7328b7351a595a13fcca 100644 (file)
--- a/gcc/ada/mingw32.h
+++ b/gcc/ada/mingw32.h
@@ -95,4 +95,11 @@ extern UINT __gnat_current_ccs_encoding;
 #define WS2S(str,wstr,len) strncpy(str,wstr,len)
 #endif
 
+typedef HRESULT (WINAPI *SetThreadDescription_t)(
+    _In_ HANDLE hThread,
+    _In_ PCWSTR lpThreadDescription
+);
+
+extern SetThreadDescription_t pSetThreadDescription;
+
 #endif /* _MINGW32_H */

diff --git a/gcc/ada/rtinit.c b/gcc/ada/rtinit.c
index 3b5af0dfb01ae49e084fbd265f732d847ed6f1b2..e215c80fd33977472c76817c663852b3d54ca307 100644 (file)
--- a/gcc/ada/rtinit.c
+++ b/gcc/ada/rtinit.c
@@ -505,12 +505,27 @@ __gnat_runtime_initialize (int install_handler)
           (gnat_argv, argc_expanded * sizeof (char *));
        }
    }
+
+  /* We check whether the SetThreadDescription function is available. If so, we
+     set up a pointer to it. We follow the method that's documented on this page:
+
+     https://learn.microsoft.com/en-us/windows/win32/api/libloaderapi/nf-libloaderapi-getprocaddress
+   */
+  HMODULE hKernel32 = GetModuleHandleW(L"kernel32.dll");
+
+  if (hKernel32) {
+    pSetThreadDescription =
+      (SetThreadDescription_t)GetProcAddress(hKernel32, "SetThreadDescription");
+  }
+
 #endif
 
   if (install_handler)
     __gnat_install_handler();
 }
 
+SetThreadDescription_t pSetThreadDescription;
+
 /**************************************************/
 /* __gnat_runtime_initialize (init_float version) */
 /**************************************************/