View Issue Details

IDProjectCategoryView StatusLast Update
0036941FPCRTLpublic2020-05-03 23:40
ReporterBi0T1N Assigned ToSven Barth  
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
Product Version3.3.1 
Fixed in Version3.3.1 
Summary0036941: [Patch] Implement thread naming for Windows
DescriptionThis patch implements thread naming for the Windows platform.
See https://docs.microsoft.com/en-us/visualstudio/debugger/how-to-set-a-thread-name-in-native-code?view=vs-2019


There are two 'open' issues:
1. According to the Microsoft Docs page the record is aligned/packed, so it might need something like
Align(@thrdinfo, 8);

or
packed record

but here (Win 10 64bit) it's working fine without all of this.

2. If THREADNAME_IS_ANSISTRING gets defined the cast to AnsiString isn't needed. If it is not defined the UnicodeString cast can be removed. I'm not sure which definition should be favoured. Both lines are marked in the patch.
Additional InformationThis patch bases on the changes from https://bugs.freepascal.org/view.php?id=36940
TagsNo tags attached.
Fixed in Revision45206
FPCOldBugId
FPCTarget-
Attached Files

Relationships

related to 0036940 closedSven Barth [Patch] Add support for naming threads to TThreadManager 

Activities

Bi0T1N

2020-04-20 22:07

reporter  

01-Implement_ThreadSetName_for_Windows.patch (4,503 bytes)   
diff --git rtl/win/systhrd.inc rtl/win/systhrd.inc
index 5eee904c56..c1982d73c0 100644
--- rtl/win/systhrd.inc
+++ rtl/win/systhrd.inc
@@ -51,6 +51,16 @@ function  TerminateThread  (threadHandle : THandle; var exitCode : dword) : bool
 function  WaitForSingleObject (hHandle : THandle;Milliseconds: dword): dword; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'WaitForSingleObject';
 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';
+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';
+procedure WinRaiseException(dwExceptionCode, dwExceptionFlags, nNumberOfArguments: DWord; const lpArguments: PUInt64); stdcall; external KernelDLL name 'RaiseException';
+{$ifndef WINCE}
+type
+  TSetThreadDescription = function(threadHandle: THandle; lpThreadDescription: PWideChar): HResult; stdcall;
+var
+  WinSetThreadDescription: TSetThreadDescription;
+{$endif WINCE}
 {$ifndef WINCE}
 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';
@@ -339,8 +349,47 @@ var
     end;
 
     procedure SysThreadSetName(threadHandle: TThreadID; const ThreadName: String);
+    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
+      thrdhandle: THandle;
+      thrdinfo: THREADNAME_INFO;
     begin
-      {$Warning ThreadSetName needs to be implemented}
+      if WinIsDebuggerPresent then
+      begin
+        // supported on older Windows versions AND currently only supported method by GDB
+        thrdinfo.dwType:=$1000;
+        thrdinfo.szName:=@AnsiString(ThreadName)[1]; // <-- depends on THREADNAME_IS_ANSISTRING
+        thrdinfo.dwThreadID:=threadHandle;
+        thrdinfo.dwFlags:=0;
+        try
+          WinRaiseException(MS_VC_EXCEPTION, 0, SizeOf(thrdinfo) div SizeOf(DWord), @thrdinfo);
+        except
+        end;
+      end
+      else
+      begin
+        if Assigned(WinSetThreadDescription) then
+        begin
+          // at least Windows 10 version 1607 or Windows Server 2016
+          if threadHandle=TThreadID(-1) then
+          begin
+            thrdhandle:=WinGetCurrentThread;
+          end
+          else
+          begin
+            thrdhandle:=WinOpenThread($0400, False, threadHandle);
+          end;
+          WinSetThreadDescription(thrdhandle, @UnicodeString(ThreadName)[1]); // <-- depends on THREADNAME_IS_ANSISTRING
+        end;
+      end;
     end;
 
 {*****************************************************************************
@@ -502,10 +551,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
@@ -550,13 +599,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;
 

Bi0T1N

2020-04-20 22:12

reporter   ~0122304

Attached a small demo project and some screenshots.
Please note that you need at least GDB 8.0 for showing thread names on Windows.
namethreads.pas (1,086 bytes)   
program namethreads;
 
{$mode Delphi}
 
uses
  SysUtils, Classes;

type
  TMyThread = class(TThread)
  private
	i: Integer;
  protected
	procedure Execute; override;
	procedure SetNumber(const aNum: Integer);
  end;
 
procedure TMyThread.Execute;
begin
  writeln('hello from thread '+ThreadID.ToString);
  NameThreadForDebugging(IntToStr(i));
  sleep(30000);
end;
 
procedure TMyThread.SetNumber(const aNum: Integer);
begin
  i := aNum + 1;
end;

var
  threads: TArray<TMyThread>;
  i: Integer;
  thread: TMyThread;
 
begin
  writeln('start');

  SetLength(threads, 5);
  for i := Low(threads) to High(threads) do
  begin
	threads[i] := TMyThread.Create(True);
	threads[i].SetNumber(i);
  end;
 
  for thread in threads do
  begin
	thread.Start;
  end;
 
  sleep(10000);
 
  TMyThread.NameThreadForDebugging('bronze', threads[2].ThreadID); // third thread
  TMyThread.NameThreadForDebugging('always number one'); // main thread
 
  for thread in threads do
  begin
	thread.WaitFor;
  end;
 
  writeln('done');
  readln;
end.
namethreads.pas (1,086 bytes)   
gdb.PNG (41,157 bytes)   
gdb.PNG (41,157 bytes)   
processhacker.PNG (27,761 bytes)   
processhacker.PNG (27,761 bytes)   
x64dbg_1.PNG (74,496 bytes)   
x64dbg_1.PNG (74,496 bytes)   
x64dbg_2.PNG (92,279 bytes)   
x64dbg_2.PNG (92,279 bytes)   

Bi0T1N

2020-04-28 22:49

reporter   ~0122514

Updated patch after 0036940 got merged.
- wasn't sure if code duplication or string conversion should be avoided - decided for avoiding string conversions inside SysSetThreadDebugNameA/U.
- adapted the code slightly so that both methods can be used together as stated on the MS Docs:
"It is worth noting that both approaches can be used together, if desired, since the mechanisms by which they work are independent of each other." (https://docs.microsoft.com/en-us/visualstudio/debugger/how-to-set-a-thread-name-in-native-code?view=vs-2019)
01-Implement_Ansi_and_Unicode_ThreadSetName_for_Windows.patch (5,154 bytes)   
diff --git rtl/win/systhrd.inc rtl/win/systhrd.inc
index 6ab7f8f0b2..ee7e08dbe3 100644
--- rtl/win/systhrd.inc
+++ rtl/win/systhrd.inc
@@ -51,6 +51,16 @@ function  TerminateThread  (threadHandle : THandle; var exitCode : dword) : bool
 function  WaitForSingleObject (hHandle : THandle;Milliseconds: dword): dword; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'WaitForSingleObject';
 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';
+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';
+procedure WinRaiseException(dwExceptionCode, dwExceptionFlags, nNumberOfArguments: DWord; const lpArguments: PUInt64); stdcall; external KernelDLL name 'RaiseException';
+{$ifndef WINCE}
+type
+  TSetThreadDescription = function(threadHandle: THandle; lpThreadDescription: PWideChar): HResult; stdcall;
+var
+  WinSetThreadDescription: TSetThreadDescription;
+{$endif WINCE}
 {$ifndef WINCE}
 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';
@@ -338,14 +348,71 @@ var
       SysGetCurrentThreadId:=Win32GetCurrentThreadId;
     end;
 
+    { 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
+        WinRaiseException(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;
+    begin
+      if threadHandle=TThreadID(-1) then
+      begin
+        thrdhandle:=WinGetCurrentThread;
+      end
+      else
+      begin
+        thrdhandle:=WinOpenThread($0400, False, threadHandle);
+      end;
+      WinSetThreadDescription(thrdhandle, @ThreadName[1]);
+    end;
+
     procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
     begin
-      {$Warning SetThreadDebugNameA needs to be implemented}
+      if WinIsDebuggerPresent then
+      begin
+        RaiseMSVCExceptionMethod(threadHandle, ThreadName);
+      end;
+
+      if Assigned(WinSetThreadDescription) then
+      begin
+        SetThreadDescriptionMethod(threadHandle, UnicodeString(ThreadName));
+      end;
     end;
 
     procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
     begin
-      {$Warning SetThreadDebugNameU needs to be implemented}
+      if WinIsDebuggerPresent then
+      begin
+        RaiseMSVCExceptionMethod(threadHandle, AnsiString(ThreadName));
+      end;
+
+      if Assigned(WinSetThreadDescription) then
+      begin
+        SetThreadDescriptionMethod(threadHandle, ThreadName);
+      end;
     end;
 
 {*****************************************************************************
@@ -507,10 +574,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,6 +623,11 @@ begin
   if IsLibrary then
 {$endif}
     SysInitTLS;
+
+{$ifndef WINCE}
+  KernelHandle:=GetModuleHandle(KernelDLL);
+{$endif}
+
 {$IFDEF SUPPORT_WIN95}
   { Try to find TryEnterCriticalSection function }
   KernelHandle:=GetModuleHandle(KernelDLL);
@@ -564,5 +636,12 @@ begin
   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;
 

Sven Barth

2020-04-29 12:31

manager   ~0122521

Following remarks:
- the string conversion is fine as you did it
- remove the KernelHandle assignment inside the SUPPORT_WIN95 define (otherwise KernelHandle would be assigned twice if that is defined)
- don't you need to close the thread you opened with OpenThread after the call to SetThreadDescription?
- RaiseException is already imported in syswin.inc, maybe move that to sysos.inc (and use "RaiseException" instead of "WinRaiseException" then)

Bi0T1N

2020-04-29 16:03

reporter   ~0122526

Fixed your remarks in the attached patch for an easy review. Should be applied on top of the previous one.
02-Implement_Ansi_and_Unicode_ThreadSetName_for_Windows.patch (3,514 bytes)   
diff --git rtl/win/sysos.inc rtl/win/sysos.inc
index a85f424900..83a1eda5f1 100644
--- rtl/win/sysos.inc
+++ rtl/win/sysos.inc
@@ -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';
diff --git rtl/win/systhrd.inc rtl/win/systhrd.inc
index ee7e08dbe3..4a929b16d4 100644
--- rtl/win/systhrd.inc
+++ rtl/win/systhrd.inc
@@ -54,7 +54,6 @@ function  WinThreadGetPriority (threadHandle : THandle): LongInt; {$ifdef 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';
-procedure WinRaiseException(dwExceptionCode, dwExceptionFlags, nNumberOfArguments: DWord; const lpArguments: PUInt64); stdcall; external KernelDLL name 'RaiseException';
 {$ifndef WINCE}
 type
   TSetThreadDescription = function(threadHandle: THandle; lpThreadDescription: PWideChar): HResult; stdcall;
@@ -367,7 +366,7 @@ var
       thrdinfo.dwThreadID:=threadHandle;
       thrdinfo.dwFlags:=0;
       try
-        WinRaiseException(MS_VC_EXCEPTION, 0, SizeOf(thrdinfo) div SizeOf(DWord), @thrdinfo);
+        RaiseException(MS_VC_EXCEPTION, 0, SizeOf(thrdinfo) div SizeOf(DWord), @thrdinfo);
       except
         {do nothing}
       end;
@@ -377,16 +376,25 @@ var
     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;
 
     procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
@@ -630,7 +638,6 @@ begin
 
 {$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
diff --git rtl/win/syswin.inc rtl/win/syswin.inc
index 7204e6797e..e61833a70e 100644
--- rtl/win/syswin.inc
+++ rtl/win/syswin.inc
@@ -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' }

Sven Barth

2020-05-01 15:11

manager   ~0122578

Thank you. I've applied your patch with the added difference that I've disabled it for Windows CE (for now).

Please test and close if okay.

Issue History

Date Modified Username Field Change
2020-04-20 22:07 Bi0T1N New Issue
2020-04-20 22:07 Bi0T1N File Added: 01-Implement_ThreadSetName_for_Windows.patch
2020-04-20 22:12 Bi0T1N Note Added: 0122304
2020-04-20 22:12 Bi0T1N File Added: namethreads.pas
2020-04-20 22:12 Bi0T1N File Added: gdb.PNG
2020-04-20 22:12 Bi0T1N File Added: processhacker.PNG
2020-04-20 22:12 Bi0T1N File Added: x64dbg_1.PNG
2020-04-20 22:12 Bi0T1N File Added: x64dbg_2.PNG
2020-04-22 10:30 Sven Barth Relationship added related to 0036940
2020-04-28 22:49 Bi0T1N Note Added: 0122514
2020-04-28 22:49 Bi0T1N File Added: 01-Implement_Ansi_and_Unicode_ThreadSetName_for_Windows.patch
2020-04-29 12:31 Sven Barth Note Added: 0122521
2020-04-29 16:03 Bi0T1N Note Added: 0122526
2020-04-29 16:03 Bi0T1N File Added: 02-Implement_Ansi_and_Unicode_ThreadSetName_for_Windows.patch
2020-05-01 14:50 Sven Barth Assigned To => Sven Barth
2020-05-01 14:50 Sven Barth Status new => assigned
2020-05-01 15:11 Sven Barth Status assigned => resolved
2020-05-01 15:11 Sven Barth Resolution open => fixed
2020-05-01 15:11 Sven Barth Fixed in Version => 3.3.1
2020-05-01 15:11 Sven Barth Fixed in Revision => 45206
2020-05-01 15:11 Sven Barth FPCTarget => -
2020-05-01 15:11 Sven Barth Note Added: 0122578
2020-05-03 23:40 Bi0T1N Status resolved => closed