Debugger: added support for TThread.NameThreadForDebugging

components/fpdebug/fpdbgclasses.pp

@@ -218,6 +218,7 @@ type
     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;
@@ -266,6 +267,7 @@ type
     procedure StoreStepInfo(AnAddr: TDBGPtr = 0);
     property ID: Integer read FID;
     property Handle: THandle read FHandle;
+    property Name: String read GetName;
     property NextIsSingleStep: boolean read FNextIsSingleStep write FNextIsSingleStep;
     property RegisterValueList: TDbgRegisterValueList read GetRegisterValueList;
     property CallStackEntryList: TDbgCallstackEntryList read FCallStackEntryList;
@@ -2916,6 +2918,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;

components/fpdebug/fpdbglinuxclasses.pas

@@ -277,6 +277,7 @@ type
     function GetDebugRegOffset(ind: byte): pointer;
     function ReadDebugReg(ind: byte; out AVal: PtrUInt): boolean;
     function WriteDebugReg(ind: byte; AVal: PtrUInt): boolean;
+    function GetName: String; override;
   protected
     function ReadThreadState: boolean;
 
@@ -539,6 +540,28 @@ begin
     result := true;
 end;
 
+function TDbgLinuxThread.GetName: String;
+var
+  fh: THandle;
+  n: array[0..30] of AnsiChar;
+  c: LongInt;
+begin
+  Result := '';
+  fh := FileOpen('/proc/' + IntToStr(Handle) + '/comm', fmOpenRead or fmShareDenyNone);
+  if fh <> THandle(-1) then begin
+    try
+      c := FileRead(fh, n, 30);
+      if c > 0 then begin
+        n[c] := #0;
+        Result := TrimRightSet(n, [' ', #10]);
+      end;
+    finally
+      FileClose(fh);
+    end;
+  end;
+  if Result = '' then
+    Result := inherited GetName;
+end;
 
 function TDbgLinuxThread.ReadThreadState: boolean;
 var

components/fpdebug/fpdbgwinclasses.pas

@@ -127,6 +127,7 @@ type
   TFpWinCtxFlags = (cfSkip, cfControl, cfFull);
   TFpContextChangeFlag = (ccfControl, ccfInteger);
   TFpContextChangeFlags = set of TFpContextChangeFlag;
+  PPWSTR = ^PWSTR;
 
   { TDbgWinThread }
 
@@ -135,6 +136,8 @@ type
     FIsSuspended: Boolean;
     FIsSkippingBreakPoint: Boolean;
     FIsSkippingBreakPointAddress: TDBGPtr;
+    FDoNotPollName: Boolean;
+    FName: String;
   protected
     FThreadContextChanged: boolean;
     FThreadContextChangeFlags: TFpContextChangeFlags;
@@ -144,6 +147,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;
@@ -313,6 +317,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
@@ -330,6 +335,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');
@@ -343,6 +349,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']);
@@ -1248,8 +1255,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;
@@ -1276,6 +1286,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);
@@ -1596,6 +1617,24 @@ begin
   DebugLn(DBG_WARNINGS and (not Result), ['Unable to set Context for ', ID, ': ', GetLastErrorText]);
 end;
 
+function TDbgWinThread.GetName: String;
+var
+  n: PWSTR;
+begin
+  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;
+
 procedure TDbgWinThread.Suspend;
 var
   r: DWORD;

components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas

@@ -915,21 +915,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;