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