* fix for Mantis #36940: apply (adjusted) patch by Bi0T1N to add functionality to the thread manager to set a thread's debug name (if supported by the platform)

git-svn-id: trunk@45160 -

rtl/amicommon/athreads.pp

@@ -748,6 +748,18 @@ begin
 end;
 
 
+procedure ASetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
+
+procedure ASetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  ASetThreadDebugNameA(threadHandle, AnsiString(ThreadName));
+end;
+
+
 Type  PINTRTLEvent = ^TINTRTLEvent;
       TINTRTLEvent = record
         isset: boolean;
@@ -1230,6 +1242,8 @@ begin
     ThreadSetPriority      :=@AThreadSetPriority;
     ThreadGetPriority      :=@AThreadGetPriority;
     GetCurrentThreadId     :=@AGetCurrentThreadId;
+    SetThreadDebugNameA    :=@ASetThreadDebugNameA;
+    SetThreadDebugNameU    :=@ASetThreadDebugNameU;
     InitCriticalSection    :=@AInitCriticalSection;
     DoneCriticalSection    :=@ADoneCriticalSection;
     EnterCriticalSection   :=@AEnterCriticalSection;

rtl/beos/bethreads.pp

@@ -263,6 +263,15 @@ Uses
       CGetCurrentThreadId:=dword(pthread_self());
     end;
 
+    procedure BeSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
+
+    procedure BeSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -494,6 +503,8 @@ begin
     ThreadSetPriority      :=@BeThreadSetPriority;
     ThreadGetPriority      :=@BeThreadGetPriority;
     GetCurrentThreadId     :=@BeGetCurrentThreadId;
+    SetThreadDebugNameA    :=@BeSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@BeSetThreadDebugNameU;
     InitCriticalSection    :=@BeInitCriticalSection;
     DoneCriticalSection    :=@BeDoneCriticalSection;
     EnterCriticalSection   :=@BeEnterCriticalSection;

rtl/inc/thread.inc

@@ -212,6 +212,18 @@ begin
   Result:=CurrentTM.GetCurrentThreadID();
 end;
 
+procedure SetThreadDebugName(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  CurrentTM.SetThreadDebugNameA(threadHandle, ThreadName);
+end;
+
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+procedure SetThreadDebugName(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  CurrentTM.SetThreadDebugNameU(threadHandle, ThreadName);
+end;
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
+
 procedure InitCriticalSection(var cs : TRTLCriticalSection);
 
 begin
@@ -410,6 +422,18 @@ begin
   result:=TThreadID(1);
 end;
 
+procedure NoSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  NoThreadError;
+end;
+
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+procedure NoSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  NoThreadError;
+end;
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
+
 procedure NoCriticalSection(var CS);
 
 begin
@@ -518,6 +542,10 @@ const
          ThreadSetPriority      : TThreadSetPriorityHandler(@NoThreadError);
          ThreadGetPriority      : TThreadGetPriorityHandler(@NoThreadError);
          GetCurrentThreadId     : @NoGetCurrentThreadId;
+         SetThreadDebugNameA    : TThreadSetThreadDebugNameHandlerA(@NoThreadError);
+         {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+         SetThreadDebugNameU    : TThreadSetThreadDebugNameHandlerU(@NoThreadError);
+         {$endif FPC_HAS_FEATURE_UNICODESTRINGS}
          InitCriticalSection    : TCriticalSectionHandler(@NoThreadError);
          DoneCriticalSection    : TCriticalSectionHandler(@NoThreadError);
          EnterCriticalSection   : TCriticalSectionHandler(@NoThreadError);
@@ -550,6 +578,10 @@ const
          ThreadSetPriority      : @NoThreadSetPriority;
          ThreadGetPriority      : @NoThreadGetPriority;
          GetCurrentThreadId     : @NoGetCurrentThreadId;
+         SetThreadDebugNameA    : @NoSetThreadDebugNameA;
+         {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+         SetThreadDebugNameU    : @NoSetThreadDebugNameU;
+         {$endif FPC_HAS_FEATURE_UNICODESTRINGS}
          InitCriticalSection    : @NoCriticalSection;
          DoneCriticalSection    : @NoCriticalSection;
          EnterCriticalSection   : @NoCriticalSection;

rtl/inc/threadh.inc

@@ -45,6 +45,10 @@ 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);
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+  TThreadSetThreadDebugNameHandlerU = procedure(threadHandle: TThreadID; const ThreadName: UnicodeString);
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
   TCriticalSectionHandler = Procedure (var cs);
   TCriticalSectionHandlerTryEnter = function (var cs):longint;
   TInitThreadVarHandler = Procedure(var offset : {$ifdef cpu16}word{$else}dword{$endif};size : dword);
@@ -78,6 +82,10 @@ type
     ThreadSetPriority      : TThreadSetPriorityHandler;
     ThreadGetPriority      : TThreadGetPriorityHandler;
     GetCurrentThreadId     : TGetCurrentThreadIdHandler;
+    SetThreadDebugNameA    : TThreadSetThreadDebugNameHandlerA;
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+    SetThreadDebugNameU    : TThreadSetThreadDebugNameHandlerU;
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
     InitCriticalSection    : TCriticalSectionHandler;
     DoneCriticalSection    : TCriticalSectionHandler;
     EnterCriticalSection   : TCriticalSectionHandler;
@@ -148,6 +156,10 @@ 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 SetThreadDebugName(threadHandle: TThreadID; const ThreadName: AnsiString);
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+procedure SetThreadDebugName(threadHandle: TThreadID; const ThreadName: UnicodeString);
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
 
 
 { this allows to do a lot of things in MT safe way }

rtl/nativent/systhrd.inc

@@ -130,6 +130,14 @@ const
       Result := 0;
     end;
 
+    procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+    end;
+
+    procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+    end;
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -236,6 +244,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

rtl/netware/systhrd.inc

@@ -244,13 +244,20 @@ 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;
+
+procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
 
 { netware requires all allocated semaphores }
 { to be closed before terminating the nlm, otherwise }
@@ -469,6 +476,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

rtl/netwlibc/systhrd.inc

@@ -221,6 +221,15 @@
       SysGetCurrentThreadId:=dword(pthread_self);
     end;
 
+    procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
+
+    procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -364,6 +373,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

rtl/objpas/classes/classes.inc

@@ -670,36 +670,20 @@ 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);
-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 }
+{$ifdef FPC_HAS_FEATURE_THREADING}
+  SetThreadDebugName(aThreadID, aThreadName);
+{$endif}
 end;
-  {$endif}
 
 
 class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
 begin
-  NameThreadForDebugging(UnicodeString(aThreadName), aThreadID);
-end;
+{$ifdef FPC_HAS_FEATURE_THREADING}
+  SetThreadDebugName(aThreadID, aThreadName);
 {$endif}
+end;
 
 
 class procedure TThread.Yield;

rtl/objpas/classes/classesh.inc

@@ -1947,13 +1947,7 @@ 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: UnicodeString; aThreadID: TThreadID = TThreadID(-1)); static; inline;
     class procedure NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID = TThreadID(-1)); static; inline;
     class procedure SetReturnValue(aValue: Integer); static;
     class function CheckTerminated: Boolean; static;

rtl/os2/systhrd.inc

@@ -659,6 +659,17 @@ begin
 end;
 
 
+procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
+
+procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -942,6 +953,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

rtl/unix/cthreads.pp

@@ -487,6 +487,18 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
     end;
 
 
+  procedure CSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
+
+
+  procedure CSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
+
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -944,6 +956,8 @@ begin
     ThreadSetPriority      :=@CThreadSetPriority;
     ThreadGetPriority      :=@CThreadGetPriority;
     GetCurrentThreadId     :=@CGetCurrentThreadId;
+    SetThreadDebugNameA    :=@CSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@CSetThreadDebugNameU;
     InitCriticalSection    :=@CInitCriticalSection;
     DoneCriticalSection    :=@CDoneCriticalSection;
     EnterCriticalSection   :=@CEnterCriticalSection;

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
 *****************************************************************************}
@@ -517,6 +527,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;