From 44e79eb0d4a135531f7a0c90a8215d1c6ab93719 Mon Sep 17 00:00:00 2001
From: Pascal Riekenberg <pascal@riekenberg.eu>
Date: Tue, 19 Apr 2022 23:28:26 +0200
Subject: [PATCH 1/4] First attempt: Name threads for debugging
---
components/fpdebug/fpdbgclasses.pp | 9 +++++++
components/fpdebug/fpdbgwinclasses.pas | 25 +++++++++++++++++++
.../lazdebuggerfp/fpdebugdebugger.pas | 8 +++---
3 files changed, 38 insertions(+), 4 deletions(-)
diff --git a/components/fpdebug/fpdbgclasses.pp b/components/fpdebug/fpdbgclasses.pp
index bb1361ba48..9980386e4f 100644
--- a/components/fpdebug/fpdbgclasses.pp
+++ b/components/fpdebug/fpdbgclasses.pp
@@ -211,11 +211,13 @@ type
FStoreStepStartAddr, FStoreStepEndAddr: TDBGPtr;
FStoreStepSrcLineNo: integer;
FStoreStepFuncAddr: TDBGPtr;
+ FThreadNum: Integer;
procedure LoadRegisterValues; virtual;
property Process: TDbgProcess read FProcess;
function ResetInstructionPointerAfterBreakpoint: boolean; virtual; abstract;
procedure DoBeforeBreakLocationMapChange; // A new location added / or a location removed => memory will change
procedure ValidateRemovedBreakPointInfo;
+ function GetName: String; virtual;
public
constructor Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle); virtual;
procedure DoBeforeProcessLoop;
@@ -260,6 +262,8 @@ type
procedure StoreStepInfo(AnAddr: TDBGPtr = 0);
property ID: Integer read FID;
property Handle: THandle read FHandle;
+ property Name: String read GetName;
+ property ThreadNum: Integer read FThreadNum;
property NextIsSingleStep: boolean read FNextIsSingleStep write FNextIsSingleStep;
property RegisterValueList: TDbgRegisterValueList read GetRegisterValueList;
property CallStackEntryList: TDbgCallstackEntryList read FCallStackEntryList;
@@ -2898,6 +2902,11 @@ begin
FPausedAtRemovedBreakPointState := rbUnknown;
end;
+function TDbgThread.GetName: String;
+begin
+ Result := 'Thread ' + IntToStr(FID);
+end;
+
constructor TDbgThread.Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle);
begin
FID := AID;
diff --git a/components/fpdebug/fpdbgwinclasses.pas b/components/fpdebug/fpdbgwinclasses.pas
index 4b3359576d..229fa1bb5e 100644
--- a/components/fpdebug/fpdbgwinclasses.pas
+++ b/components/fpdebug/fpdbgwinclasses.pas
@@ -122,6 +122,8 @@ uses
FpDbgCommon, FpdMemoryTools, FpErrorMessages;
type
+ PPWSTR = ^PWSTR;
+ TGetThreadDescription = function(threadHandle: THandle; name: PPWSTR): HResult; stdcall;
TFpWinCtxFlags = (cfSkip, cfControl, cfFull);
TFpContextChangeFlag = (ccfControl, ccfInteger);
@@ -143,6 +145,7 @@ type
procedure LoadRegisterValues; override;
function GetFpThreadContext(var AStorage: TFpContext; out ACtxPtr: PFpContext; ACtxFlags: TFpWinCtxFlags): Boolean;
function SetFpThreadContext(ACtxPtr: PFpContext; ACtxFlags: TFpWinCtxFlags = cfSkip): Boolean;
+ function GetName: String; override;
public
procedure Suspend;
procedure SuspendForStepOverBreakPoint;
@@ -237,6 +240,8 @@ implementation
var
DBG_VERBOSE, DBG_WARNINGS, FPDBG_WINDOWS: PLazLoggerLogGroup;
+ KernelHandle : THandle;
+ GetThreadDescription: TGetThreadDescription;
{$ifdef cpux86_64}
const
@@ -1594,6 +1599,22 @@ begin
DebugLn(DBG_WARNINGS and (not Result), ['Unable to set Context for ', ID, ': ', GetLastErrorText]);
end;
+function TDbgWinThread.GetName: String;
+var
+ n: PWSTR;
+begin
+ if Assigned(GetThreadDescription) then begin
+ if Succeeded(GetThreadDescription(Handle, @n)) then begin
+ Result := WideCharToString(n);
+ LocalFree(HLOCAL(n));
+ if Result = '' then
+ Result := inherited GetName;
+ end else
+ Result := inherited GetName;
+ end else
+ Result := inherited GetName;
+end;
+
procedure TDbgWinThread.Suspend;
var
r: DWORD;
@@ -1925,5 +1946,9 @@ initialization
TX86AsmDecoder
));
+ KernelHandle := GetModuleHandle(KernelDLL);
+ if KernelHandle <> 0 then
+ GetThreadDescription := TGetThreadDescription(GetProcAddress(KernelHandle, 'GetThreadDescription'));
+
end.
diff --git a/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas b/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
index 23ed1e79d5..400f3530f2 100644
--- a/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
+++ b/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
@@ -916,21 +916,21 @@ begin
if Assigned(CallStack) and (CallStack.Count > 0) then begin
c := CallStack.Items[0];
if t = nil then begin
- n := Threads.CurrentThreads.CreateEntry(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, 'Thread ' + IntToStr(FpThr.ID), 'paused');
+ n := Threads.CurrentThreads.CreateEntry(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, FpThr.Name, 'paused');
Threads.CurrentThreads.Add(n);
n.Free;
end
else
- t.Init(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, 'Thread ' + IntToStr(FpThr.ID), 'paused');
+ t.Init(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, FpThr.Name, 'paused');
end
else begin
if t = nil then begin
- n := Threads.CurrentThreads.CreateEntry(0, nil, '', '', '', 0, FpThr.ID, 'Thread ' + IntToStr(FpThr.ID), 'paused');
+ n := Threads.CurrentThreads.CreateEntry(0, nil, '', '', '', 0, FpThr.ID, FpThr.Name, 'paused');
Threads.CurrentThreads.Add(n);
n.Free;
end
else
- t.Init(0, nil, '', '', '', 0, FpThr.ID, 'Thread ' + IntToStr(FpThr.ID), 'paused');
+ t.Init(0, nil, '', '', '', 0, FpThr.ID, FpThr.Name, 'paused');
end;
end;
From a70f8d70931ed3a426b06910c138b5f31f326a1e Mon Sep 17 00:00:00 2001
From: Pascal Riekenberg <pascal@riekenberg.eu>
Date: Tue, 19 Apr 2022 23:28:26 +0200
Subject: [PATCH 2/4] First attempt: Name threads for debugging
---
components/fpdebug/fpdbgclasses.pp | 9 +++++++
components/fpdebug/fpdbgwinclasses.pas | 25 +++++++++++++++++++
.../lazdebuggerfp/fpdebugdebugger.pas | 8 +++---
3 files changed, 38 insertions(+), 4 deletions(-)
diff --git a/components/fpdebug/fpdbgclasses.pp b/components/fpdebug/fpdbgclasses.pp
index 67323d190c..6b7a67eee1 100644
--- a/components/fpdebug/fpdbgclasses.pp
+++ b/components/fpdebug/fpdbgclasses.pp
@@ -211,11 +211,13 @@ type
FStoreStepStartAddr, FStoreStepEndAddr: TDBGPtr;
FStoreStepSrcLineNo: integer;
FStoreStepFuncAddr: TDBGPtr;
+ FThreadNum: Integer;
procedure LoadRegisterValues; virtual;
property Process: TDbgProcess read FProcess;
function ResetInstructionPointerAfterBreakpoint: boolean; virtual; abstract;
procedure DoBeforeBreakLocationMapChange; // A new location added / or a location removed => memory will change
procedure ValidateRemovedBreakPointInfo;
+ function GetName: String; virtual;
public
constructor Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle); virtual;
procedure DoBeforeProcessLoop;
@@ -260,6 +262,8 @@ type
procedure StoreStepInfo(AnAddr: TDBGPtr = 0);
property ID: Integer read FID;
property Handle: THandle read FHandle;
+ property Name: String read GetName;
+ property ThreadNum: Integer read FThreadNum;
property NextIsSingleStep: boolean read FNextIsSingleStep write FNextIsSingleStep;
property RegisterValueList: TDbgRegisterValueList read GetRegisterValueList;
property CallStackEntryList: TDbgCallstackEntryList read FCallStackEntryList;
@@ -2910,6 +2914,11 @@ begin
FPausedAtRemovedBreakPointState := rbUnknown;
end;
+function TDbgThread.GetName: String;
+begin
+ Result := 'Thread ' + IntToStr(FID);
+end;
+
constructor TDbgThread.Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle);
begin
FID := AID;
diff --git a/components/fpdebug/fpdbgwinclasses.pas b/components/fpdebug/fpdbgwinclasses.pas
index 4b3359576d..229fa1bb5e 100644
--- a/components/fpdebug/fpdbgwinclasses.pas
+++ b/components/fpdebug/fpdbgwinclasses.pas
@@ -122,6 +122,8 @@ uses
FpDbgCommon, FpdMemoryTools, FpErrorMessages;
type
+ PPWSTR = ^PWSTR;
+ TGetThreadDescription = function(threadHandle: THandle; name: PPWSTR): HResult; stdcall;
TFpWinCtxFlags = (cfSkip, cfControl, cfFull);
TFpContextChangeFlag = (ccfControl, ccfInteger);
@@ -143,6 +145,7 @@ type
procedure LoadRegisterValues; override;
function GetFpThreadContext(var AStorage: TFpContext; out ACtxPtr: PFpContext; ACtxFlags: TFpWinCtxFlags): Boolean;
function SetFpThreadContext(ACtxPtr: PFpContext; ACtxFlags: TFpWinCtxFlags = cfSkip): Boolean;
+ function GetName: String; override;
public
procedure Suspend;
procedure SuspendForStepOverBreakPoint;
@@ -237,6 +240,8 @@ implementation
var
DBG_VERBOSE, DBG_WARNINGS, FPDBG_WINDOWS: PLazLoggerLogGroup;
+ KernelHandle : THandle;
+ GetThreadDescription: TGetThreadDescription;
{$ifdef cpux86_64}
const
@@ -1594,6 +1599,22 @@ begin
DebugLn(DBG_WARNINGS and (not Result), ['Unable to set Context for ', ID, ': ', GetLastErrorText]);
end;
+function TDbgWinThread.GetName: String;
+var
+ n: PWSTR;
+begin
+ if Assigned(GetThreadDescription) then begin
+ if Succeeded(GetThreadDescription(Handle, @n)) then begin
+ Result := WideCharToString(n);
+ LocalFree(HLOCAL(n));
+ if Result = '' then
+ Result := inherited GetName;
+ end else
+ Result := inherited GetName;
+ end else
+ Result := inherited GetName;
+end;
+
procedure TDbgWinThread.Suspend;
var
r: DWORD;
@@ -1925,5 +1946,9 @@ initialization
TX86AsmDecoder
));
+ KernelHandle := GetModuleHandle(KernelDLL);
+ if KernelHandle <> 0 then
+ GetThreadDescription := TGetThreadDescription(GetProcAddress(KernelHandle, 'GetThreadDescription'));
+
end.
diff --git a/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas b/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
index 23ed1e79d5..400f3530f2 100644
--- a/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
+++ b/components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
@@ -916,21 +916,21 @@ begin
if Assigned(CallStack) and (CallStack.Count > 0) then begin
c := CallStack.Items[0];
if t = nil then begin
- n := Threads.CurrentThreads.CreateEntry(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, 'Thread ' + IntToStr(FpThr.ID), 'paused');
+ n := Threads.CurrentThreads.CreateEntry(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, FpThr.Name, 'paused');
Threads.CurrentThreads.Add(n);
n.Free;
end
else
- t.Init(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, 'Thread ' + IntToStr(FpThr.ID), 'paused');
+ t.Init(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, FpThr.Name, 'paused');
end
else begin
if t = nil then begin
- n := Threads.CurrentThreads.CreateEntry(0, nil, '', '', '', 0, FpThr.ID, 'Thread ' + IntToStr(FpThr.ID), 'paused');
+ n := Threads.CurrentThreads.CreateEntry(0, nil, '', '', '', 0, FpThr.ID, FpThr.Name, 'paused');
Threads.CurrentThreads.Add(n);
n.Free;
end
else
- t.Init(0, nil, '', '', '', 0, FpThr.ID, 'Thread ' + IntToStr(FpThr.ID), 'paused');
+ t.Init(0, nil, '', '', '', 0, FpThr.ID, FpThr.Name, 'paused');
end;
end;
From 5897bdfc8f2d54646f92cbdc1998584c08d62733 Mon Sep 17 00:00:00 2001
From: Pascal Riekenberg <pascal@riekenberg.eu>
Date: Thu, 12 May 2022 09:57:04 +0200
Subject: [PATCH 3/4] adding support for setting name by debugger exception
---
components/fpdebug/fpdbgwinclasses.pas | 42 ++++++++++++++++++--------
1 file changed, 30 insertions(+), 12 deletions(-)
diff --git a/components/fpdebug/fpdbgwinclasses.pas b/components/fpdebug/fpdbgwinclasses.pas
index 229fa1bb5e..26b1d6b555 100644
--- a/components/fpdebug/fpdbgwinclasses.pas
+++ b/components/fpdebug/fpdbgwinclasses.pas
@@ -123,7 +123,6 @@ uses
type
PPWSTR = ^PWSTR;
- TGetThreadDescription = function(threadHandle: THandle; name: PPWSTR): HResult; stdcall;
TFpWinCtxFlags = (cfSkip, cfControl, cfFull);
TFpContextChangeFlag = (ccfControl, ccfInteger);
@@ -136,6 +135,8 @@ type
FIsSuspended: Boolean;
FIsSkippingBreakPoint: Boolean;
FIsSkippingBreakPointAddress: TDBGPtr;
+ FDoNotPollName: Boolean;
+ FName: String;
protected
FThreadContextChanged: boolean;
FThreadContextChangeFlags: TFpContextChangeFlags;
@@ -240,8 +241,6 @@ implementation
var
DBG_VERBOSE, DBG_WARNINGS, FPDBG_WINDOWS: PLazLoggerLogGroup;
- KernelHandle : THandle;
- GetThreadDescription: TGetThreadDescription;
{$ifdef cpux86_64}
const
@@ -316,6 +315,7 @@ var
_Wow64GetThreadContext: function (hThread: THandle; var lpContext: WOW64_CONTEXT): BOOL; stdcall = nil;
_Wow64SetThreadContext: function (hThread: THandle; const lpContext: WOW64_CONTEXT): BOOL; stdcall = nil;
_DebugBreakProcess: function(Process:HANDLE): WINBOOL; stdcall = nil;
+ _GetThreadDescription: function(hThread: THandle; ppszThreadDescription: PPWSTR): HResult; stdcall = nil;
procedure LoadKernelEntryPoints;
var
@@ -333,6 +333,7 @@ begin
Pointer(_DebugActiveProcess) := GetProcAddress(hMod, 'DebugActiveProcess');
Pointer(_GetFinalPathNameByHandle) := GetProcAddress(hMod, 'GetFinalPathNameByHandleW');
Pointer(_DebugBreakProcess) := GetProcAddress(hMod, 'DebugBreakProcess');
+ Pointer(_GetThreadDescription) := GetProcAddress(hMod, 'GetThreadDescription');
{$ifdef cpux86_64}
Pointer(_IsWow64Process) := GetProcAddress(hMod, 'IsWow64Process');
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 (_GetFinalPathNameByHandle = nil), ['WARNING: Failed to get GetFinalPathNameByHandle']);
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}
DebugLn(DBG_WARNINGS and (_IsWow64Process = nil), ['WARNING: Failed to get IsWow64Process']);
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);
end;
+const
+ EXCEPTION_SET_THREADNAME = $406D1388;
var
InterceptAtFirst: Boolean;
+ threadname: String;
begin
if AThread <> nil then
TDbgWinThread(AThread).EndSingleStepOverBreakPoint;
@@ -1279,6 +1284,17 @@ begin
end;
EXCEPTION_SINGLE_STEP, STATUS_WX86_SINGLE_STEP: begin
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
else begin
HandleException(MDebugEvent, InterceptAtFirst);
@@ -1603,15 +1619,17 @@ function TDbgWinThread.GetName: String;
var
n: PWSTR;
begin
- if Assigned(GetThreadDescription) then begin
- if Succeeded(GetThreadDescription(Handle, @n)) then begin
- Result := WideCharToString(n);
- LocalFree(HLOCAL(n));
- if Result = '' then
- Result := inherited GetName;
- end else
- Result := inherited GetName;
- end else
+ Result := '';
+ if FDoNotPollName then begin
+ Result := FName;
+ end else begin
+ if _GetThreadDescription <> nil then
+ if Succeeded(_GetThreadDescription(Handle, @n)) then begin
+ Result := WideCharToString(n);
+ LocalFree(HLOCAL(n));
+ end;
+ end;
+ if Result = '' then
Result := inherited GetName;
end;
From d7eb52797dbbcf68415df422faebc85a966cf1a3 Mon Sep 17 00:00:00 2001
From: Pascal Riekenberg <pascal@riekenberg.eu>
Date: Thu, 12 May 2022 10:22:10 +0200
Subject: [PATCH 4/4] missing changes from last commit
---
components/fpdebug/fpdbgwinclasses.pas | 4 ----
1 file changed, 4 deletions(-)
diff --git a/components/fpdebug/fpdbgwinclasses.pas b/components/fpdebug/fpdbgwinclasses.pas
index 26b1d6b555..5fec0ee2bf 100644
--- a/components/fpdebug/fpdbgwinclasses.pas
+++ b/components/fpdebug/fpdbgwinclasses.pas
@@ -1964,9 +1964,5 @@ initialization
TX86AsmDecoder
));
- KernelHandle := GetModuleHandle(KernelDLL);
- if KernelHandle <> 0 then
- GetThreadDescription := TGetThreadDescription(GetProcAddress(KernelHandle, 'GetThreadDescription'));
-
end.