https://gcc.gnu.org/g:6c09f90690ee7ec6609ac5b7b526cbbbc124bb9c
commit r16-6629-g6c09f90690ee7ec6609ac5b7b526cbbbc124bb9c Author: Ronan Desplanques <[email protected]> Date: Tue Dec 16 15:28:48 2025 +0100 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: --- 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 1b99312630c9..78be4e0b7b53 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 f7deb6ea7e96..4153e32be1a3 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 5f8c9f5ac7b1..9506ccc438ed 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 3b5af0dfb01a..e215c80fd339 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) */ /**************************************************/
