paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-27 10:09:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

adding support for setting name by debugger exception

Browse Source
This commit is contained in:
Pascal Riekenberg 2022-05-12 09:57:04 +02:00
parent b3c03b3abf
commit 5897bdfc8f
1 changed files with 30 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
components/fpdebug/fpdbgwinclasses.pas
View File

@ -123,7 +123,6 @@ uses
type type
PPWSTR = ^PWSTR; PPWSTR = ^PWSTR;
TGetThreadDescription = function(threadHandle: THandle; name: PPWSTR): HResult; stdcall;
TFpWinCtxFlags = (cfSkip, cfControl, cfFull); TFpWinCtxFlags = (cfSkip, cfControl, cfFull);
TFpContextChangeFlag = (ccfControl, ccfInteger); TFpContextChangeFlag = (ccfControl, ccfInteger);
@ -136,6 +135,8 @@ type
FIsSuspended: Boolean; FIsSuspended: Boolean;
FIsSkippingBreakPoint: Boolean; FIsSkippingBreakPoint: Boolean;
FIsSkippingBreakPointAddress: TDBGPtr; FIsSkippingBreakPointAddress: TDBGPtr;
FDoNotPollName: Boolean;
FName: String;
protected protected
FThreadContextChanged: boolean; FThreadContextChanged: boolean;
FThreadContextChangeFlags: TFpContextChangeFlags; FThreadContextChangeFlags: TFpContextChangeFlags;
@ -240,8 +241,6 @@ implementation
var var
DBG_VERBOSE, DBG_WARNINGS, FPDBG_WINDOWS: PLazLoggerLogGroup; DBG_VERBOSE, DBG_WARNINGS, FPDBG_WINDOWS: PLazLoggerLogGroup;
KernelHandle : THandle;
GetThreadDescription: TGetThreadDescription;
{$ifdef cpux86_64} {$ifdef cpux86_64}
const const
@ -316,6 +315,7 @@ var
_Wow64GetThreadContext: function (hThread: THandle; var lpContext: WOW64_CONTEXT): BOOL; stdcall = nil; _Wow64GetThreadContext: function (hThread: THandle; var lpContext: WOW64_CONTEXT): BOOL; stdcall = nil;
_Wow64SetThreadContext: function (hThread: THandle; const lpContext: WOW64_CONTEXT): BOOL; stdcall = nil; _Wow64SetThreadContext: function (hThread: THandle; const lpContext: WOW64_CONTEXT): BOOL; stdcall = nil;
_DebugBreakProcess: function(Process:HANDLE): WINBOOL; stdcall = nil; _DebugBreakProcess: function(Process:HANDLE): WINBOOL; stdcall = nil;
_GetThreadDescription: function(hThread: THandle; ppszThreadDescription: PPWSTR): HResult; stdcall = nil;
procedure LoadKernelEntryPoints; procedure LoadKernelEntryPoints;
var var
@ -333,6 +333,7 @@ begin
Pointer(_DebugActiveProcess) := GetProcAddress(hMod, 'DebugActiveProcess'); Pointer(_DebugActiveProcess) := GetProcAddress(hMod, 'DebugActiveProcess');
Pointer(_GetFinalPathNameByHandle) := GetProcAddress(hMod, 'GetFinalPathNameByHandleW'); Pointer(_GetFinalPathNameByHandle) := GetProcAddress(hMod, 'GetFinalPathNameByHandleW');
Pointer(_DebugBreakProcess) := GetProcAddress(hMod, 'DebugBreakProcess'); Pointer(_DebugBreakProcess) := GetProcAddress(hMod, 'DebugBreakProcess');
Pointer(_GetThreadDescription) := GetProcAddress(hMod, 'GetThreadDescription');
{$ifdef cpux86_64} {$ifdef cpux86_64}
Pointer(_IsWow64Process) := GetProcAddress(hMod, 'IsWow64Process'); Pointer(_IsWow64Process) := GetProcAddress(hMod, 'IsWow64Process');
Pointer(_Wow64GetThreadContext) := GetProcAddress(hMod, 'Wow64GetThreadContext'); Pointer(_Wow64GetThreadContext) := GetProcAddress(hMod, 'Wow64GetThreadContext');
@ -346,6 +347,7 @@ begin
DebugLn(DBG_WARNINGS and (_DebugActiveProcess = nil), ['WARNING: Failed to get DebugActiveProcess']); DebugLn(DBG_WARNINGS and (_DebugActiveProcess = nil), ['WARNING: Failed to get DebugActiveProcess']);
DebugLn(DBG_WARNINGS and (_GetFinalPathNameByHandle = nil), ['WARNING: Failed to get GetFinalPathNameByHandle']); DebugLn(DBG_WARNINGS and (_GetFinalPathNameByHandle = nil), ['WARNING: Failed to get GetFinalPathNameByHandle']);
DebugLn(DBG_WARNINGS and (_DebugBreakProcess = nil), ['WARNING: Failed to get DebugBreakProcess']); DebugLn(DBG_WARNINGS and (_DebugBreakProcess = nil), ['WARNING: Failed to get DebugBreakProcess']);
DebugLn(DBG_WARNINGS and (_GetThreadDescription = nil), ['WARNING: Failed to get GetThreadDescription']);
{$ifdef cpux86_64} {$ifdef cpux86_64}
DebugLn(DBG_WARNINGS and (_IsWow64Process = nil), ['WARNING: Failed to get IsWow64Process']); DebugLn(DBG_WARNINGS and (_IsWow64Process = nil), ['WARNING: Failed to get IsWow64Process']);
DebugLn(DBG_WARNINGS and (_Wow64GetThreadContext = nil), ['WARNING: Failed to get Wow64GetThreadContext']); DebugLn(DBG_WARNINGS and (_Wow64GetThreadContext = nil), ['WARNING: Failed to get Wow64GetThreadContext']);
@ -1251,8 +1253,11 @@ function TDbgWinProcess.AnalyseDebugEvent(AThread: TDbgThread): TFPDEvent;
OnDebugOutputEvent(Self, AEvent.dwProcessId, AEvent.dwThreadId, S); OnDebugOutputEvent(Self, AEvent.dwProcessId, AEvent.dwThreadId, S);
end; end;
const
EXCEPTION_SET_THREADNAME = $406D1388;
var var
InterceptAtFirst: Boolean; InterceptAtFirst: Boolean;
threadname: String;
begin begin
if AThread <> nil then if AThread <> nil then
TDbgWinThread(AThread).EndSingleStepOverBreakPoint; TDbgWinThread(AThread).EndSingleStepOverBreakPoint;
@ -1279,6 +1284,17 @@ begin
end; end;
EXCEPTION_SINGLE_STEP, STATUS_WX86_SINGLE_STEP: begin EXCEPTION_SINGLE_STEP, STATUS_WX86_SINGLE_STEP: begin
result := deBreakpoint; result := deBreakpoint;
end;
EXCEPTION_SET_THREADNAME: begin
if AThread <> nil then begin
if not ReadString(TDbgPtr(MDebugEvent.Exception.ExceptionRecord.ExceptionInformation[1]), 200, threadname) then
threadname := 'error getting threadname';
with TDbgWinThread(AThread) do begin
FName := threadname;
FDoNotPollName := True;
end;
end;
result := deInternalContinue;
end end
else begin else begin
HandleException(MDebugEvent, InterceptAtFirst); HandleException(MDebugEvent, InterceptAtFirst);
@ -1603,15 +1619,17 @@ function TDbgWinThread.GetName: String;
var var
n: PWSTR; n: PWSTR;
begin begin
if Assigned(GetThreadDescription) then begin Result := '';
if Succeeded(GetThreadDescription(Handle, @n)) then begin if FDoNotPollName then begin
Result := WideCharToString(n); Result := FName;
LocalFree(HLOCAL(n)); end else begin
if Result = '' then if _GetThreadDescription <> nil then
Result := inherited GetName; if Succeeded(_GetThreadDescription(Handle, @n)) then begin
end else Result := WideCharToString(n);
Result := inherited GetName; LocalFree(HLOCAL(n));
end else end;
end;
if Result = '' then
Result := inherited GetName; Result := inherited GetName;
end; end;