From: Ronan Desplanques <[email protected]>
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.
Tested on x86_64-pc-linux-gnu (before the recent bootstrap breakage), committed
on master.
---
gcc/ada/adaint.c | 29 ++++++++++++++++++++++++++++
gcc/ada/libgnarl/s-taprop__mingw.adb | 28 +++++++++++++++++++++++++++
gcc/ada/mingw32.h | 7 +++++++
gcc/ada/rtinit.c | 15 ++++++++++++++
4 files changed, 79 insertions(+)
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 1b99312630c..78be4e0b7b5 100644
--- 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 f7deb6ea7e9..4153e32be1a 100644
--- 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 5f8c9f5ac7b..9506ccc438e 100644
--- 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 3b5af0dfb01..e215c80fd33 100644
--- 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) */
/**************************************************/
--
2.51.0
