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

* fix for Mantis #36941: apply (adjusted) patch by Bi0T1N to implement SetThreadDebugNameA and -U for Windows, with the exception of Windows CE

Browse Source 
git-svn-id: trunk@45206 -
This commit is contained in:
svenbarth 2020-05-01 13:10:54 +00:00
parent 722ad1ff7b
commit 68d743a83e
3 changed files with 100 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
rtl/win/sysos.inc
View File

@ -231,6 +231,9 @@ type
procedure SetLastError(dwErrCode : DWORD);
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'SetLastError';
procedure RaiseException(dwExceptionCode: DWORD; dwExceptionFlags: DWORD; dwArgCount: DWORD; lpArguments: Pointer);
{$ifdef wince}cdecl{$else}stdcall{$endif}; external KernelDLL name 'RaiseException';
{ time and date functions }
function GetTickCount : DWORD;
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'GetTickCount';

100
rtl/win/systhrd.inc
View File

@ -52,6 +52,13 @@ function WaitForSingleObject (hHandle : THandle;Milliseconds: dword): dword; {$
function WinThreadSetPriority (threadHandle : THandle; Prio: longint): boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'SetThreadPriority';
function WinThreadGetPriority (threadHandle : THandle): LongInt; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'GetThreadPriority';
{$ifndef WINCE}
function WinGetCurrentThread: THandle; stdcall; external KernelDLL name 'GetCurrentThread';
function WinOpenThread(dwDesiredAccess: DWord; bInheritHandle: Boolean; dwThreadId: DWord): THandle; stdcall; external KernelDLL name 'OpenThread';
function WinIsDebuggerPresent: Boolean; stdcall; external KernelDLL name 'IsDebuggerPresent';
type
TSetThreadDescription = function(threadHandle: THandle; lpThreadDescription: PWideChar): HResult; stdcall;
var
WinSetThreadDescription: TSetThreadDescription;
function CreateEvent(lpEventAttributes:pointer;bManualReset:longbool;bInitialState:longbool;lpName:pchar): THandle; stdcall; external KernelDLL name 'CreateEventA';
function ResetEvent(hEvent:THandle):LONGBOOL; stdcall; external KernelDLL name 'ResetEvent';
function SetEvent(hEvent:THandle):LONGBOOL; stdcall; external KernelDLL name 'SetEvent';
@ -338,14 +345,90 @@ var
SysGetCurrentThreadId:=Win32GetCurrentThreadId;
end;
{$ifndef WINCE}
{ following method is supported on older Windows versions AND currently only supported method by GDB }
procedure RaiseMSVCExceptionMethod(threadHandle: TThreadID; const ThreadName: AnsiString);
const
MS_VC_EXCEPTION: DWord = $406D1388;
type
THREADNAME_INFO = record
dwType: DWord; // Must be 0x1000.
szName: PAnsiChar; // Pointer to name (in user addr space).
dwThreadID: DWord; // Thread ID (-1=caller thread).
dwFlags: DWord; // Reserved for future use, must be zero.
end;
var
thrdinfo: THREADNAME_INFO;
begin
thrdinfo.dwType:=$1000;
thrdinfo.szName:=@ThreadName[1];
thrdinfo.dwThreadID:=threadHandle;
thrdinfo.dwFlags:=0;
try
RaiseException(MS_VC_EXCEPTION, 0, SizeOf(thrdinfo) div SizeOf(DWord), @thrdinfo);
except
{do nothing}
end;
end;
{ following method needs at least Windows 10 version 1607 or Windows Server 2016 }
procedure SetThreadDescriptionMethod(threadHandle: TThreadID; const ThreadName: UnicodeString);
var
thrdhandle: THandle;
ClosingNeeded: Boolean;
begin
if threadHandle=TThreadID(-1) then
begin
thrdhandle:=WinGetCurrentThread;
ClosingNeeded:=False;
end
else
begin
thrdhandle:=WinOpenThread($0400, False, threadHandle);
ClosingNeeded:=True;
end;
WinSetThreadDescription(thrdhandle, @ThreadName[1]);
if ClosingNeeded then
begin
CloseHandle(thrdhandle);
end;
end;
{$endif WINCE}
procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
begin
{$ifndef WINCE}
if WinIsDebuggerPresent then
begin
RaiseMSVCExceptionMethod(threadHandle, ThreadName);
end;
if Assigned(WinSetThreadDescription) then
begin
SetThreadDescriptionMethod(threadHandle, UnicodeString(ThreadName));
end;
{$else WINCE}
{$Warning SetThreadDebugNameA needs to be implemented}
{$endif WINCE}
end;
procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
begin
{$ifndef WINCE}
if WinIsDebuggerPresent then
begin
RaiseMSVCExceptionMethod(threadHandle, AnsiString(ThreadName));
end;
if Assigned(WinSetThreadDescription) then
begin
SetThreadDescriptionMethod(threadHandle, ThreadName);
end;
{$else WINCE}
{$Warning SetThreadDebugNameU needs to be implemented}
{$endif WINCE}
end;
{*****************************************************************************
@ -507,10 +590,10 @@ Var
WinThreadManager : TThreadManager;
Procedure InitSystemThreads;public name '_FPC_InitSystemThreads';
{$IFDEF SUPPORT_WIN95}
{$ifndef WINCE}
var
KernelHandle : THandle;
{$ENDIF SUPPORT_WIN95}
{$endif}
begin
With WinThreadManager do
begin
@ -556,13 +639,24 @@ begin
if IsLibrary then
{$endif}
SysInitTLS;
{$ifndef WINCE}
KernelHandle:=GetModuleHandle(KernelDLL);
{$endif}
{$IFDEF SUPPORT_WIN95}
{ Try to find TryEnterCriticalSection function }
KernelHandle:=GetModuleHandle(KernelDLL);
if KernelHandle<>0 then
WinTryEnterCriticalSection:=TTryEnterCriticalSection(WinGetProcAddress(KernelHandle,'TryEnterCriticalSection'));
if not assigned(WinTryEnterCriticalSection) then
WinTryEnterCriticalSection:=@Win95TryEnterCriticalSection;
{$ENDIF SUPPORT_WIN95}
{$ifndef WINCE}
if KernelHandle<>0 then
begin
WinSetThreadDescription:=TSetThreadDescription(WinGetProcAddress(KernelHandle, 'SetThreadDescription'));
end;
{$endif WINCE}
end;

8
rtl/win/syswin.inc
View File

@ -130,14 +130,6 @@ type
TExceptClsProc=function(code: Longint): Pointer; { ExceptClass }
procedure RaiseException(
dwExceptionCode: DWORD;
dwExceptionFlags: DWORD;
dwArgCount: DWORD;
lpArguments: Pointer); // msdn: *ULONG_PTR
stdcall; external 'kernel32.dll' name 'RaiseException';
function RunErrorCode(const rec: TExceptionRecord): longint;
begin
{ negative result means 'FPU reset required' }