paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 11:28:06 +02:00
Code Issues Packages Projects Releases Wiki Activity

* 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)

Browse Source 
git-svn-id: trunk@45160 -
This commit is contained in:
svenbarth 2020-04-28 19:58:20 +00:00
parent e131a4e014
commit c8b7094378
12 changed files with 152 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
rtl/amicommon/athreads.pp
View File

@ -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;

11
rtl/beos/bethreads.pp
View File

@ -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;

32
rtl/inc/thread.inc
View File

@ -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;

12
rtl/inc/threadh.inc
View File

@ -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 }

10
rtl/nativent/systhrd.inc
View File

@ -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;

13
rtl/netware/systhrd.inc
View File

@ -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;

11
rtl/netwlibc/systhrd.inc
View File

@ -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;

38
rtl/objpas/classes/classes.inc
View File

@ -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;

8
rtl/objpas/classes/classesh.inc
View File

@ -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;

13
rtl/os2/systhrd.inc
View File

@ -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;

14
rtl/unix/cthreads.pp
View File

@ -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;

12
rtl/win/systhrd.inc
View File

@ -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;