View Issue Details

IDProjectCategoryView StatusLast Update
0036940FPCRTLpublic2020-05-03 23:40
ReporterBi0T1N Assigned ToSven Barth  
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
Product Version3.3.1 
Fixed in Version3.3.1 
Summary0036940: [Patch] Add support for naming threads to TThreadManager
DescriptionThis patch defines a ThreadSetName procedure for the TThreadManager record which allows implementing thread naming for different platforms.
TagsNo tags attached.
Fixed in Revision45160
FPCOldBugId
FPCTarget-
Attached Files

Relationships

related to 0036950 closedSven Barth [Patch] Implement thread naming for Linux and Android 
related to 0036941 closedSven Barth [Patch] Implement thread naming for Windows 

Activities

Bi0T1N

2020-04-20 21:52

reporter  

01-Add_ThreadSetName_to_TThreadManager_record.patch (12,465 bytes)   
diff --git rtl/amicommon/athreads.pp rtl/amicommon/athreads.pp
index 3c06f48760..2547644b3f 100644
--- rtl/amicommon/athreads.pp
+++ rtl/amicommon/athreads.pp
@@ -748,6 +748,12 @@ begin
 end;
 
 
+procedure AThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+begin
+  {$Warning ThreadSetName needs to be implemented}
+end;
+
+
 Type  PINTRTLEvent = ^TINTRTLEvent;
       TINTRTLEvent = record
         isset: boolean;
@@ -1230,6 +1236,7 @@ begin
     ThreadSetPriority      :=@AThreadSetPriority;
     ThreadGetPriority      :=@AThreadGetPriority;
     GetCurrentThreadId     :=@AGetCurrentThreadId;
+    ThreadSetName          :=@AThreadSetName;
     InitCriticalSection    :=@AInitCriticalSection;
     DoneCriticalSection    :=@ADoneCriticalSection;
     EnterCriticalSection   :=@AEnterCriticalSection;
diff --git rtl/beos/bethreads.pp rtl/beos/bethreads.pp
index 98de02c985..fe50a4f9ce 100644
--- rtl/beos/bethreads.pp
+++ rtl/beos/bethreads.pp
@@ -263,6 +263,10 @@ Uses
       CGetCurrentThreadId:=dword(pthread_self());
     end;
 
+    procedure BeThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+    begin
+      {$Warning ThreadSetName needs to be implemented}
+    end;
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -494,6 +498,7 @@ begin
     ThreadSetPriority      :=@BeThreadSetPriority;
     ThreadGetPriority      :=@BeThreadGetPriority;
     GetCurrentThreadId     :=@BeGetCurrentThreadId;
+    ThreadSetName          :=@BeThreadSetName;
     InitCriticalSection    :=@BeInitCriticalSection;
     DoneCriticalSection    :=@BeDoneCriticalSection;
     EnterCriticalSection   :=@BeEnterCriticalSection;
diff --git rtl/inc/thread.inc rtl/inc/thread.inc
index ea6304e9fd..5e251f99ee 100644
--- rtl/inc/thread.inc
+++ rtl/inc/thread.inc
@@ -212,6 +212,11 @@ begin
   Result:=CurrentTM.GetCurrentThreadID();
 end;
 
+procedure ThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+begin
+  CurrentTM.ThreadSetName(threadHandle, ThreadName);
+end;
+
 procedure InitCriticalSection(var cs : TRTLCriticalSection);
 
 begin
@@ -410,6 +415,11 @@ begin
   result:=TThreadID(1);
 end;
 
+procedure NoThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+begin
+  NoThreadError;
+end;
+
 procedure NoCriticalSection(var CS);
 
 begin
@@ -518,6 +528,7 @@ const
          ThreadSetPriority      : TThreadSetPriorityHandler(@NoThreadError);
          ThreadGetPriority      : TThreadGetPriorityHandler(@NoThreadError);
          GetCurrentThreadId     : @NoGetCurrentThreadId;
+         ThreadSetName          : TThreadSetThreadNameHandler(@NoThreadError);
          InitCriticalSection    : TCriticalSectionHandler(@NoThreadError);
          DoneCriticalSection    : TCriticalSectionHandler(@NoThreadError);
          EnterCriticalSection   : TCriticalSectionHandler(@NoThreadError);
@@ -550,6 +561,7 @@ const
          ThreadSetPriority      : @NoThreadSetPriority;
          ThreadGetPriority      : @NoThreadGetPriority;
          GetCurrentThreadId     : @NoGetCurrentThreadId;
+         ThreadSetName          : @NoThreadSetName;
          InitCriticalSection    : @NoCriticalSection;
          DoneCriticalSection    : @NoCriticalSection;
          EnterCriticalSection   : @NoCriticalSection;
diff --git rtl/inc/threadh.inc rtl/inc/threadh.inc
index 9b52769ab3..2221007350 100644
--- rtl/inc/threadh.inc
+++ rtl/inc/threadh.inc
@@ -45,6 +45,7 @@ type
   TThreadSetPriorityHandler = Function (threadHandle : TThreadID; Prio: longint): boolean;            {-15..+15, 0=normal}
   TThreadGetPriorityHandler = Function (threadHandle : TThreadID): longint;
   TGetCurrentThreadIdHandler = Function : TThreadID;
+  TThreadSetThreadNameHandler = procedure(threadHandle: TThreadID; const ThreadName: String);
   TCriticalSectionHandler = Procedure (var cs);
   TCriticalSectionHandlerTryEnter = function (var cs):longint;
   TInitThreadVarHandler = Procedure(var offset : {$ifdef cpu16}word{$else}dword{$endif};size : dword);
@@ -78,6 +79,7 @@ type
     ThreadSetPriority      : TThreadSetPriorityHandler;
     ThreadGetPriority      : TThreadGetPriorityHandler;
     GetCurrentThreadId     : TGetCurrentThreadIdHandler;
+    ThreadSetName          : TThreadSetThreadNameHandler;
     InitCriticalSection    : TCriticalSectionHandler;
     DoneCriticalSection    : TCriticalSectionHandler;
     EnterCriticalSection   : TCriticalSectionHandler;
@@ -148,6 +150,7 @@ function  WaitForThreadTerminate (threadHandle : TThreadID; TimeoutMs : longint)
 function  ThreadSetPriority (threadHandle : TThreadID; Prio: longint): boolean;            {-15..+15, 0=normal}
 function  ThreadGetPriority (threadHandle : TThreadID): longint;
 function  GetCurrentThreadId : TThreadID;
+procedure ThreadSetName(threadHandle: TThreadID; const ThreadName: String);
 
 
 { this allows to do a lot of things in MT safe way }
diff --git rtl/nativent/systhrd.inc rtl/nativent/systhrd.inc
index 4c628688d7..54e7c0a227 100644
--- rtl/nativent/systhrd.inc
+++ rtl/nativent/systhrd.inc
@@ -130,6 +130,11 @@ const
       Result := 0;
     end;
 
+    procedure SysThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+    begin
+      {$Warning ThreadSetName needs to be implemented}
+    end;
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -231,11 +236,12 @@ begin
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
     ThreadSwitch           :=@SysThreadSwitch;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    ThreadSetName          :=@SysThreadSetName;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
diff --git rtl/netware/systhrd.inc rtl/netware/systhrd.inc
index f11fe133e5..d04740d737 100644
--- rtl/netware/systhrd.inc
+++ rtl/netware/systhrd.inc
@@ -244,13 +244,15 @@ begin
   SysThreadGetPriority := 0;
 end;
 
-
-
 function  SysGetCurrentThreadId : dword;
 begin
   SysGetCurrentThreadId := CGetThreadID;
 end;
 
+procedure SysThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+begin
+  {$Warning ThreadSetName needs to be implemented}
+end;
 
 { netware requires all allocated semaphores }
 { to be closed before terminating the nlm, otherwise }
@@ -469,6 +471,7 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    ThreadSetName          :=@SysThreadSetName;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
diff --git rtl/netwlibc/systhrd.inc rtl/netwlibc/systhrd.inc
index 8205feefec..6bc6bf45c9 100644
--- rtl/netwlibc/systhrd.inc
+++ rtl/netwlibc/systhrd.inc
@@ -221,6 +221,10 @@
       SysGetCurrentThreadId:=dword(pthread_self);
     end;
 
+    procedure SysThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+    begin
+      {$Warning ThreadSetName needs to be implemented}
+    end;
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -364,6 +368,7 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    ThreadSetName          :=@SysThreadSetName;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
diff --git rtl/objpas/classes/classes.inc rtl/objpas/classes/classes.inc
index 70d47ba6d5..75c92d0686 100644
--- rtl/objpas/classes/classes.inc
+++ rtl/objpas/classes/classes.inc
@@ -681,7 +681,7 @@ end;
   {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
 class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
 begin
-  { empty }
+  ThreadSetName(aThreadID, aThreadName);
 end;
   {$endif}
 {$else}
@@ -690,11 +690,10 @@ end;
   simply calls the UnicodeString variant }
 class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
 begin
-  { empty }
+  ThreadSetName(aThreadID, aThreadName);
 end;
   {$endif}
 
-
 class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
 begin
   NameThreadForDebugging(UnicodeString(aThreadName), aThreadID);
diff --git rtl/os2/systhrd.inc rtl/os2/systhrd.inc
index f798eff510..4234d66b9b 100644
--- rtl/os2/systhrd.inc
+++ rtl/os2/systhrd.inc
@@ -659,6 +659,11 @@ begin
 end;
 
 
+procedure SysThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+begin
+  {$Warning ThreadSetName needs to be implemented}
+end;
+
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -936,12 +941,13 @@ begin
     SuspendThread          :=@SysSuspendThread;
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     ThreadSwitch           :=@SysThreadSwitch;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    ThreadSetName          :=@SysThreadSetName;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
diff --git rtl/unix/cthreads.pp rtl/unix/cthreads.pp
index 92b537bffd..8db6646a18 100644
--- rtl/unix/cthreads.pp
+++ rtl/unix/cthreads.pp
@@ -487,6 +487,12 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
     end;
 
 
+  procedure CThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+    begin
+      {$Warning ThreadSetName needs to be implemented}
+    end;
+
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -944,6 +950,7 @@ begin
     ThreadSetPriority      :=@CThreadSetPriority;
     ThreadGetPriority      :=@CThreadGetPriority;
     GetCurrentThreadId     :=@CGetCurrentThreadId;
+    ThreadSetName          :=@CThreadSetName;
     InitCriticalSection    :=@CInitCriticalSection;
     DoneCriticalSection    :=@CDoneCriticalSection;
     EnterCriticalSection   :=@CEnterCriticalSection;
diff --git rtl/win/systhrd.inc rtl/win/systhrd.inc
index bbd6b132bf..5eee904c56 100644
--- rtl/win/systhrd.inc
+++ rtl/win/systhrd.inc
@@ -338,6 +338,11 @@ var
       SysGetCurrentThreadId:=Win32GetCurrentThreadId;
     end;
 
+    procedure SysThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+    begin
+      {$Warning ThreadSetName needs to be implemented}
+    end;
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -512,11 +517,12 @@ begin
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
     ThreadSwitch           :=@SysThreadSwitch;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    ThreadSetName          :=@SysThreadSetName;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

Tomas Hajny

2020-04-20 23:58

manager   ~0122305

Am I right to assume that this functionality may only be supported on MS Windows? If so, wouldn't it make sense to add a name field to TThread so that there's some place where the name may be placed on other platforms (if the new method is really needed at all)?

Bi0T1N

2020-04-21 00:28

reporter   ~0122306

It can also be implemented for unix (see https://stackoverflow.com/a/7989973).
Using a field within TThread is not possible because you don't have access to it due to 'class procedure' (Delphi compatibility, http://docwiki.embarcadero.com/Libraries/Rio/en/System.Classes.TThread.NameThreadForDebugging). It also doesn't make sense to have it inside the TThread class as GDB and other debuggers don't know / care about it.

Thaddy de Koning

2020-04-21 10:41

reporter   ~0122312

Last edited: 2020-04-21 10:44

View 2 revisions

"Using a field within TThread is not possible "
It is possible to have a class var array or list as a container (or field...).
E.g. a class var of type TThreadlist can keep such things with ease.

Sven Barth

2020-04-21 13:51

manager   ~0122315

It's not possible for the intended purpose: to see the thread name in the debugger. Retrieving the content of a thread variable is more complex (and one probably will have to look it up each and every time) than just using the internal naming mechanism that the OS already provides (which is SetThreadDescription on newer Windows 10, raising a specific exception in older Windows and pthread_setname_np on e.g. Linux). I would agree with you, Thaddy, if we had a ThreadName property or something like that, but purpose of this is explicitly to implement SetThreadNameForDebugging.

Bi0T1N

2020-04-21 23:21

reporter   ~0122332

Last edited: 2020-04-21 23:22

View 2 revisions

The implementation for Linux/Android can be seen in https://bugs.freepascal.org/view.php?id=36950. The implementation for the other unix targets would be similar but unfortunately I'm not able to test them.
And yes, the main purpose is to be able to see the threadnames in the debugger or other system tools which won't work with any list/variable which keeps the ID and name.

Sven Barth

2020-04-22 10:29

manager   ~0122336

Maybe better name the function SetThreadDebugName to make clear what its purpose is?

Bi0T1N

2020-04-23 15:18

reporter   ~0122360

I can do that if it would mean the patches get accepted.

Sven Barth

2020-04-23 15:52

manager   ~0122363

In principle I see no problem with this. It was on my ToDo list anyway.

There are however a few other points I noticed:
- as SetThreadDescription takes a PCWSTR you should provide SetThreadDebugName as both AnsiString and UnicodeString variants
- as the thread manager is part of the System unit you need to explicitely use AnisString (and UnicodeString) in the declaration as String is a ShortString there
- you should protect these functions with FPC_HAS_FEATURE_ANSISTRING and FPC_HAS_FEATURE_UNICODESTRING; I currently don't know of a target that supports threading, but no dynamic strings, but the possibility should be there

Bi0T1N

2020-04-23 16:13

reporter   ~0122364

Last edited: 2020-04-23 16:17

View 3 revisions

1. The code for TThread.NameThreadForDebugging passes an AnsiString OR UnicodeString - depending on if THREADNAME_IS_ANSISTRING is defined or not (see also note on 0036941) - and the MS_VC_EXCEPTION method needs AnsiString while the SetThreadDescription on newer Windows wants an UnicodeString. It's even more complex as both approaches can be used together (not implemented like that yet).
2. As the function depends on THREADNAME_IS_ANSISTRING should it use {$IFDEF THREADNAME_IS_ANSISTRING}AnsiString{$ELSE}UnicodeString{$ENDIF} in the declarations or do it still need checks for FPC_HAS_FEATURE_ANSISTRING and FPC_HAS_FEATURE_UNICODESTRING?

Sven Barth

2020-04-24 15:27

manager   ~0122379

1. That's why I suggest to provide both AnsiString and UnicodeString. TThread.NameThreadForDebugging will just stupidly pass on the name and the backend can then decide whether it's better to use the AnsiString or the UnicodeString thus avoiding unnecessary conversions (e.g. in your variant currently the UnicodeString variant would always be converted to AnsiString even if the backend uses SetThreadDescription which takes a PWideChar, so there would be two conversions).

2. The call inside TThread.NameThreadForDebugging does not need to check for FPC_HAS_FEATURE_x, because the Classes unit is only available with both enabled. And if TThreadManager.SetThreadName is available in both variants then THREADNAME_IS_ANSISTRING is not required anymore at all (it would only be required if we would decide to implement the thread naming solely in the Classes unit to handle the correct conversion direction)

Bi0T1N

2020-04-24 18:04

reporter   ~0122384

In my opinion providing a TThreadSetThreadNameHandler for Ansi and Unicode is overkill as TThreadManager would also need to have ThreadSetNameA and ThreadSetNameU then. (Correct me if you meant it differently)
The code for both implementations would be the same for all platforms except for the new Windows SetThreadDescription function which is the only function which needs UnicodeString. And you need to have the cast (in one or another direction) for Windows anyway if IsDebuggerPresent is true because GDB doesn't support threadnames set by SetThreadDescription (yet).
Thus it would make more sense to remove the THREADNAME_IS_* defines and convert them to AnsiString as only the new Windows function works with unicode strings (which might need to be converted to AnsiString, see above).

Sven Barth

2020-04-25 16:04

manager   ~0122417

It is indeed my idea to have both ThreadSetNameA and ThreadSetNameU (or more precisely ThreadSetDebugNameA and ThreadSetDebugNameU) which is what I had mentioned in 0036940:0122363. TThread.NameThreadForDebugging would simply call the corresponding ThreadSetDebugNameX function of the thread manager, no more defines there. The conversion then happens in the platform specific code which can use the most ideal route. Also your statement that it's unnecessary for all platforms except Windows is not true. For most platforms ThreadSetDebugNameX will simply be set to do nothing, because they won't be implemented yet. For POSIX threads ThreadSetDebugNameU will simply forward to ThreadSetDebugNameU. Only Windows will be more complex, but this concept of redirection is a concept we've introduced in the base RTL due to different platforms having different requirements. The idea of this concept is to reduce unnecessary string conversions. And calling NameThreadForDebugging with a UnicodeString only to have it converted to an AnsiString (potentially with character loss due to the active codepage) and back again to UnicodeString because the system has SetThreadDescription available definitely is unnecessary.

Bi0T1N

2020-04-25 19:10

reporter   ~0122422

1. That means the "four" variants of TThread.NameThreadForDebugging would transform into one which defines aThreadName as String?
2. Did you mean ThreadSetDebugNameU will forward to ThreadSetDebugNameA on POSIX? As there is no function for POSIX which supports unicode. Or should it do nothing in that case because ThreadSetDebugNameU is empty (only having $warning)?

Sven Barth

2020-04-26 00:20

manager   ~0122431

1. There would be two variants: One with AnsiString and one with UnicodeString. The AnsiString one would call ThreadManager.ThreadSetDebugNameA, the UnicodeString one ThreadManager.ThreadSetDebugNameU.
2. Correct. On POSIX ThreadSetDebugNameU would simply call ThreadSetDebugNameA with the UnicodeString parameter converted to AnsiString. Otherwise a user of TThread.NameThreadForDebugging would need to know which overload to use, which is not what we want (also the warning would only be visible when compiling the RTL, thus it would be useless for the normal user)

Bi0T1N

2020-04-26 17:33

reporter   ~0122453

Last edited: 2020-04-26 17:37

View 3 revisions

Please find attached an updated patch.
I just left out the FPC_HAS_FEATURE_ANSISTRING and FPC_HAS_FEATURE_UNICODESTRING defines as I don't know where to put them. I thought around the SetThreadDebugNameA and SetThreadDebugNameU functions in TThreadManager but there is already TBasicEventCreateHandler which also uses AnsiString and isn't protected. So maybe you meant to put them somewhere else?
01-Add_Ansi_and_Unicode_SetThreadDebugName_methods_to_TThreadManager_record.patch (15,668 bytes)   
diff --git rtl/amicommon/athreads.pp rtl/amicommon/athreads.pp
index 3c06f48760..aeb812d9b5 100644
--- rtl/amicommon/athreads.pp
+++ rtl/amicommon/athreads.pp
@@ -748,6 +748,12 @@ begin
 end;
 
 
+procedure ASetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
+
 Type  PINTRTLEvent = ^TINTRTLEvent;
       TINTRTLEvent = record
         isset: boolean;
@@ -1230,6 +1236,8 @@ begin
     ThreadSetPriority      :=@AThreadSetPriority;
     ThreadGetPriority      :=@AThreadGetPriority;
     GetCurrentThreadId     :=@AGetCurrentThreadId;
+    SetThreadDebugNameA    :=@ASetThreadDebugNameA;
+    SetThreadDebugNameU    :=@ASetThreadDebugNameA;
     InitCriticalSection    :=@AInitCriticalSection;
     DoneCriticalSection    :=@ADoneCriticalSection;
     EnterCriticalSection   :=@AEnterCriticalSection;
diff --git rtl/beos/bethreads.pp rtl/beos/bethreads.pp
index 98de02c985..1971d90aee 100644
--- rtl/beos/bethreads.pp
+++ rtl/beos/bethreads.pp
@@ -263,6 +263,10 @@ Uses
       CGetCurrentThreadId:=dword(pthread_self());
     end;
 
+    procedure BeSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -494,6 +498,8 @@ begin
     ThreadSetPriority      :=@BeThreadSetPriority;
     ThreadGetPriority      :=@BeThreadGetPriority;
     GetCurrentThreadId     :=@BeGetCurrentThreadId;
+    SetThreadDebugNameA    :=@BeSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@BeSetThreadDebugNameA;
     InitCriticalSection    :=@BeInitCriticalSection;
     DoneCriticalSection    :=@BeDoneCriticalSection;
     EnterCriticalSection   :=@BeEnterCriticalSection;
diff --git rtl/inc/thread.inc rtl/inc/thread.inc
index ea6304e9fd..bf84d7bfb4 100644
--- rtl/inc/thread.inc
+++ rtl/inc/thread.inc
@@ -212,6 +212,16 @@ begin
   Result:=CurrentTM.GetCurrentThreadID();
 end;
 
+procedure SetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  CurrentTM.SetThreadDebugNameA(threadHandle, ThreadName);
+end;
+
+procedure SetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  CurrentTM.SetThreadDebugNameU(threadHandle, ThreadName);
+end;
+
 procedure InitCriticalSection(var cs : TRTLCriticalSection);
 
 begin
@@ -410,6 +420,16 @@ begin
   result:=TThreadID(1);
 end;
 
+procedure NoSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  NoThreadError;
+end;
+
+procedure NoSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  NoThreadError;
+end;
+
 procedure NoCriticalSection(var CS);
 
 begin
@@ -518,6 +538,8 @@ const
          ThreadSetPriority      : TThreadSetPriorityHandler(@NoThreadError);
          ThreadGetPriority      : TThreadGetPriorityHandler(@NoThreadError);
          GetCurrentThreadId     : @NoGetCurrentThreadId;
+         SetThreadDebugNameA    : TThreadSetThreadDebugNameHandlerA(@NoThreadError);
+         SetThreadDebugNameU    : TThreadSetThreadDebugNameHandlerU(@NoThreadError);
          InitCriticalSection    : TCriticalSectionHandler(@NoThreadError);
          DoneCriticalSection    : TCriticalSectionHandler(@NoThreadError);
          EnterCriticalSection   : TCriticalSectionHandler(@NoThreadError);
@@ -550,6 +572,8 @@ const
          ThreadSetPriority      : @NoThreadSetPriority;
          ThreadGetPriority      : @NoThreadGetPriority;
          GetCurrentThreadId     : @NoGetCurrentThreadId;
+         SetThreadDebugNameA    : @NoSetThreadDebugNameA;
+         SetThreadDebugNameU    : @NoSetThreadDebugNameU;
          InitCriticalSection    : @NoCriticalSection;
          DoneCriticalSection    : @NoCriticalSection;
          EnterCriticalSection   : @NoCriticalSection;
diff --git rtl/inc/threadh.inc rtl/inc/threadh.inc
index 9b52769ab3..77dc8320e0 100644
--- rtl/inc/threadh.inc
+++ rtl/inc/threadh.inc
@@ -45,6 +45,8 @@ type
   TThreadSetPriorityHandler = Function (threadHandle : TThreadID; Prio: longint): boolean;            {-15..+15, 0=normal}
   TThreadGetPriorityHandler = Function (threadHandle : TThreadID): longint;
   TGetCurrentThreadIdHandler = Function : TThreadID;
+  TThreadSetThreadDebugNameHandlerA = procedure(threadHandle: TThreadID; const ThreadName: AnsiString);
+  TThreadSetThreadDebugNameHandlerU = procedure(threadHandle: TThreadID; const ThreadName: UnicodeString);
   TCriticalSectionHandler = Procedure (var cs);
   TCriticalSectionHandlerTryEnter = function (var cs):longint;
   TInitThreadVarHandler = Procedure(var offset : {$ifdef cpu16}word{$else}dword{$endif};size : dword);
@@ -78,6 +80,8 @@ type
     ThreadSetPriority      : TThreadSetPriorityHandler;
     ThreadGetPriority      : TThreadGetPriorityHandler;
     GetCurrentThreadId     : TGetCurrentThreadIdHandler;
+    SetThreadDebugNameA    : TThreadSetThreadDebugNameHandlerA;
+    SetThreadDebugNameU    : TThreadSetThreadDebugNameHandlerU;
     InitCriticalSection    : TCriticalSectionHandler;
     DoneCriticalSection    : TCriticalSectionHandler;
     EnterCriticalSection   : TCriticalSectionHandler;
@@ -148,6 +152,8 @@ function  WaitForThreadTerminate (threadHandle : TThreadID; TimeoutMs : longint)
 function  ThreadSetPriority (threadHandle : TThreadID; Prio: longint): boolean;            {-15..+15, 0=normal}
 function  ThreadGetPriority (threadHandle : TThreadID): longint;
 function  GetCurrentThreadId : TThreadID;
+procedure SetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+procedure SetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
 
 
 { this allows to do a lot of things in MT safe way }
diff --git rtl/nativent/systhrd.inc rtl/nativent/systhrd.inc
index 4c628688d7..6292e2216e 100644
--- rtl/nativent/systhrd.inc
+++ rtl/nativent/systhrd.inc
@@ -130,6 +130,11 @@ const
       Result := 0;
     end;
 
+    procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -231,11 +236,13 @@ begin
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
     ThreadSwitch           :=@SysThreadSwitch;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameA;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
diff --git rtl/netware/systhrd.inc rtl/netware/systhrd.inc
index f11fe133e5..8c56e59257 100644
--- rtl/netware/systhrd.inc
+++ rtl/netware/systhrd.inc
@@ -244,13 +244,15 @@ begin
   SysThreadGetPriority := 0;
 end;
 
-
-
 function  SysGetCurrentThreadId : dword;
 begin
   SysGetCurrentThreadId := CGetThreadID;
 end;
 
+procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
 
 { netware requires all allocated semaphores }
 { to be closed before terminating the nlm, otherwise }
@@ -469,6 +471,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameA;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
diff --git rtl/netwlibc/systhrd.inc rtl/netwlibc/systhrd.inc
index 8205feefec..7696a5b903 100644
--- rtl/netwlibc/systhrd.inc
+++ rtl/netwlibc/systhrd.inc
@@ -221,6 +221,10 @@
       SysGetCurrentThreadId:=dword(pthread_self);
     end;
 
+    procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -364,6 +368,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameA;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
diff --git rtl/objpas/classes/classes.inc rtl/objpas/classes/classes.inc
index 70d47ba6d5..b475dd72ec 100644
--- rtl/objpas/classes/classes.inc
+++ rtl/objpas/classes/classes.inc
@@ -670,36 +670,16 @@ begin
 end;
 
 
-{$ifdef THREADNAME_IS_ANSISTRING}
-{ the platform implements the AnsiString variant and the UnicodeString variant
-  simply calls the AnsiString variant }
 class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
 begin
-  NameThreadForDebugging(AnsiString(aThreadName), aThreadID);
+  SetThreadDebugNameU(aThreadID, aThreadName);
 end;
 
-  {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
-class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
-begin
-  { empty }
-end;
-  {$endif}
-{$else}
-  {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
-{ the platform implements the UnicodeString variant and the AnsiString variant
-  simply calls the UnicodeString variant }
-class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
-begin
-  { empty }
-end;
-  {$endif}
-
 
 class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
 begin
-  NameThreadForDebugging(UnicodeString(aThreadName), aThreadID);
+  SetThreadDebugNameA(aThreadID, aThreadName);
 end;
-{$endif}
 
 
 class procedure TThread.Yield;
diff --git rtl/objpas/classes/classesh.inc rtl/objpas/classes/classesh.inc
index e6eaccb318..61ddfae3b6 100644
--- rtl/objpas/classes/classesh.inc
+++ rtl/objpas/classes/classesh.inc
@@ -1947,12 +1947,6 @@ type
     destructor Destroy; override;
     { Note: Once closures are supported aProc will be changed to TProc }
     class function CreateAnonymousThread(aProc: TProcedure): TThread; static;
-    { Use HAS_TTHREAD_NAMETHREADFORDEBUGGING to implement a platform specific
-      variant of the UnicodeString method. The AnsiString method calls the
-      UnicodeString method. If your platform's API only supports AnsiString you
-      can additionally define THREADNAME_IS_ANSISTRING to swap the logic. Then
-      the UnicodeString variant will call the AnsiString variant which can be
-      implemented for a specific platform }
     class procedure NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID = TThreadID(-1)); static;
     class procedure NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID = TThreadID(-1)); static; inline;
     class procedure SetReturnValue(aValue: Integer); static;
diff --git rtl/os2/systhrd.inc rtl/os2/systhrd.inc
index f798eff510..c71970fd37 100644
--- rtl/os2/systhrd.inc
+++ rtl/os2/systhrd.inc
@@ -659,6 +659,11 @@ begin
 end;
 
 
+procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -936,12 +941,14 @@ begin
     SuspendThread          :=@SysSuspendThread;
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     ThreadSwitch           :=@SysThreadSwitch;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameA;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
diff --git rtl/unix/cthreads.pp rtl/unix/cthreads.pp
index 92b537bffd..bcee7c635b 100644
--- rtl/unix/cthreads.pp
+++ rtl/unix/cthreads.pp
@@ -487,6 +487,12 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
     end;
 
 
+  procedure CSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
+
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -944,6 +950,8 @@ begin
     ThreadSetPriority      :=@CThreadSetPriority;
     ThreadGetPriority      :=@CThreadGetPriority;
     GetCurrentThreadId     :=@CGetCurrentThreadId;
+    SetThreadDebugNameA    :=@CSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@CSetThreadDebugNameA;
     InitCriticalSection    :=@CInitCriticalSection;
     DoneCriticalSection    :=@CDoneCriticalSection;
     EnterCriticalSection   :=@CEnterCriticalSection;
diff --git rtl/win/systhrd.inc rtl/win/systhrd.inc
index bbd6b132bf..6ab7f8f0b2 100644
--- rtl/win/systhrd.inc
+++ rtl/win/systhrd.inc
@@ -338,6 +338,16 @@ var
       SysGetCurrentThreadId:=Win32GetCurrentThreadId;
     end;
 
+    procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugNameA needs to be implemented}
+    end;
+
+    procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+      {$Warning SetThreadDebugNameU needs to be implemented}
+    end;
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -512,11 +522,13 @@ begin
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
     ThreadSwitch           :=@SysThreadSwitch;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

Marco van de Voort

2020-04-26 22:50

manager   ~0122463

(btw, I don't think Thaddy's class var would work. If you have multiple worker threads of the same type, but with different names (e.g. number suffix), that wouldn't work. And I have that in my Delphi apps :-)

Sven Barth

2020-04-28 22:01

manager   ~0122511

I've applied your patch with a few adjustments:
- the -A and -U prefix for the global procedures are not required
- use FPC_HAS_FEATURE_UNICODESTRING to disable the UnicodeString variant inside the System unit
- introduce -U dummies for all RTLs (please don't pass a pointer to a function taking an AnsiString to a procedure variable taking a UnicodeString, this might lead to crashes)

Please test and close if okay.

Issue History

Date Modified Username Field Change
2020-04-20 21:52 Bi0T1N New Issue
2020-04-20 21:52 Bi0T1N File Added: 01-Add_ThreadSetName_to_TThreadManager_record.patch
2020-04-20 23:58 Tomas Hajny Note Added: 0122305
2020-04-21 00:28 Bi0T1N Note Added: 0122306
2020-04-21 10:41 Thaddy de Koning Note Added: 0122312
2020-04-21 10:44 Thaddy de Koning Note Edited: 0122312 View Revisions
2020-04-21 13:51 Sven Barth Note Added: 0122315
2020-04-21 23:21 Bi0T1N Note Added: 0122332
2020-04-21 23:22 Bi0T1N Note Edited: 0122332 View Revisions
2020-04-22 10:29 Sven Barth Note Added: 0122336
2020-04-22 10:30 Sven Barth Relationship added related to 0036950
2020-04-22 10:30 Sven Barth Relationship added related to 0036941
2020-04-23 15:18 Bi0T1N Note Added: 0122360
2020-04-23 15:52 Sven Barth Note Added: 0122363
2020-04-23 16:13 Bi0T1N Note Added: 0122364
2020-04-23 16:15 Bi0T1N Note Edited: 0122364 View Revisions
2020-04-23 16:17 Bi0T1N Note Edited: 0122364 View Revisions
2020-04-24 15:27 Sven Barth Note Added: 0122379
2020-04-24 18:04 Bi0T1N Note Added: 0122384
2020-04-25 16:04 Sven Barth Note Added: 0122417
2020-04-25 19:10 Bi0T1N Note Added: 0122422
2020-04-26 00:20 Sven Barth Note Added: 0122431
2020-04-26 17:33 Bi0T1N Note Added: 0122453
2020-04-26 17:33 Bi0T1N File Added: 01-Add_Ansi_and_Unicode_SetThreadDebugName_methods_to_TThreadManager_record.patch
2020-04-26 17:35 Bi0T1N Note Edited: 0122453 View Revisions
2020-04-26 17:37 Bi0T1N Note Edited: 0122453 View Revisions
2020-04-26 22:50 Marco van de Voort Note Added: 0122463
2020-04-28 20:40 Sven Barth Assigned To => Sven Barth
2020-04-28 20:40 Sven Barth Status new => assigned
2020-04-28 22:01 Sven Barth Status assigned => resolved
2020-04-28 22:01 Sven Barth Resolution open => fixed
2020-04-28 22:01 Sven Barth Fixed in Version => 3.3.1
2020-04-28 22:01 Sven Barth Fixed in Revision => 45160
2020-04-28 22:01 Sven Barth FPCTarget => -
2020-04-28 22:01 Sven Barth Note Added: 0122511
2020-05-03 23:40 Bi0T1N Status resolved => closed