From c8b7094378ce420428bbf532a5108ce51bc59890 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Tue, 28 Apr 2020 19:58:20 +0000 Subject: [PATCH] * 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 | 14 ++++++++++++ rtl/beos/bethreads.pp | 11 ++++++++++ rtl/inc/thread.inc | 32 +++++++++++++++++++++++++++ rtl/inc/threadh.inc | 12 +++++++++++ rtl/nativent/systhrd.inc | 10 +++++++++ rtl/netware/systhrd.inc | 13 +++++++++-- rtl/netwlibc/systhrd.inc | 11 ++++++++++ rtl/objpas/classes/classes.inc | 38 ++++++++++----------------------- rtl/objpas/classes/classesh.inc | 8 +------ rtl/os2/systhrd.inc | 13 +++++++++++ rtl/unix/cthreads.pp | 14 ++++++++++++ rtl/win/systhrd.inc | 12 +++++++++++ 12 files changed, 152 insertions(+), 36 deletions(-) diff --git a/rtl/amicommon/athreads.pp b/rtl/amicommon/athreads.pp index 3c06f48760..a38d1b0044 100644 --- a/rtl/amicommon/athreads.pp +++ b/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; diff --git a/rtl/beos/bethreads.pp b/rtl/beos/bethreads.pp index 98de02c985..fe437f0474 100644 --- a/rtl/beos/bethreads.pp +++ b/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; diff --git a/rtl/inc/thread.inc b/rtl/inc/thread.inc index ea6304e9fd..ce7ec796b4 100644 --- a/rtl/inc/thread.inc +++ b/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; diff --git a/rtl/inc/threadh.inc b/rtl/inc/threadh.inc index 9b52769ab3..8a8e58ffe7 100644 --- a/rtl/inc/threadh.inc +++ b/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 } diff --git a/rtl/nativent/systhrd.inc b/rtl/nativent/systhrd.inc index dcc280ee2d..2eac9b3ca5 100644 --- a/rtl/nativent/systhrd.inc +++ b/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; diff --git a/rtl/netware/systhrd.inc b/rtl/netware/systhrd.inc index f11fe133e5..c362c59704 100644 --- a/rtl/netware/systhrd.inc +++ b/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; diff --git a/rtl/netwlibc/systhrd.inc b/rtl/netwlibc/systhrd.inc index 8205feefec..5d12022fad 100644 --- a/rtl/netwlibc/systhrd.inc +++ b/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; diff --git a/rtl/objpas/classes/classes.inc b/rtl/objpas/classes/classes.inc index 70d47ba6d5..896850ef94 100644 --- a/rtl/objpas/classes/classes.inc +++ b/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 } -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.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID); +begin +{$ifdef FPC_HAS_FEATURE_THREADING} + SetThreadDebugName(aThreadID, aThreadName); +{$endif} +end; class procedure TThread.Yield; diff --git a/rtl/objpas/classes/classesh.inc b/rtl/objpas/classes/classesh.inc index e6eaccb318..01f2328f0a 100644 --- a/rtl/objpas/classes/classesh.inc +++ b/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; diff --git a/rtl/os2/systhrd.inc b/rtl/os2/systhrd.inc index eb543cca64..3cd6d6e5c0 100644 --- a/rtl/os2/systhrd.inc +++ b/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; diff --git a/rtl/unix/cthreads.pp b/rtl/unix/cthreads.pp index 92b537bffd..89c8d75f99 100644 --- a/rtl/unix/cthreads.pp +++ b/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; diff --git a/rtl/win/systhrd.inc b/rtl/win/systhrd.inc index 7b31dfe714..6ab7f8f0b2 100644 --- a/rtl/win/systhrd.inc +++ b/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;