program threads;
{$mode Delphi}
uses
SysUtils, Classes;
type
TSetThreadDescription = function(threadHandle: THandle; pcwstr: PWideChar): HResult; stdcall;
//function SetThreadDescription(threadHandle: THandle; pcwstr: PWideChar): HResult; stdcall; external KernelDLL name 'SetThreadDescription';
function GetCurrentThread(): THandle; stdcall; external KernelDLL name 'GetCurrentThread';
function OpenThread(dwDesiredAccess: DWord; bInheritHandle: Boolean; dwThreadId: DWord): THandle; stdcall; external KernelDLL name 'OpenThread';
function IsDebuggerPresent(): Boolean; stdcall; external KernelDLL name 'IsDebuggerPresent';
procedure RaiseException(dwExceptionCode, dwExceptionFlags, nNumberOfArguments: DWord; const lpArguments: PUInt64); stdcall; external KernelDLL name 'RaiseException';
function GetModuleHandle(lpModuleName: PAnsiChar): THandle; stdcall; external KernelDLL name 'GetModuleHandleA';
var
KernelHandle : THandle;
SetThreadDescription: TSetThreadDescription;
type
TMyThread = class(TThread)
private
i: Integer;
protected
procedure Execute; override;
procedure SetNumber(const aNum: Integer);
procedure NameThreadForDebugging1(aThreadName: UnicodeString; aThreadID: TThreadID = TThreadID(-1));
procedure NameThreadForDebugging1(aThreadName: AnsiString; aThreadID: TThreadID = TThreadID(-1));
class procedure NameThreadForDebuggingTest(aThreadName: UnicodeString; aThreadID: TThreadID = TThreadID(-1));
end;
procedure TMyThread.Execute;
begin
writeln('hello from thread '+ThreadID.ToString);
NameThreadForDebugging1(IntToStr(i));
sleep(30000);
end;
procedure TMyThread.SetNumber(const aNum: Integer);
begin
i := aNum;
end;
procedure TMyThread.NameThreadForDebugging1(aThreadName: AnsiString; aThreadID: TThreadID);
begin
writeln('ansi '+ThreadID.ToString);
NameThreadForDebugging1(UnicodeString(aThreadName), aThreadID);
end;
procedure TMyThread.NameThreadForDebugging1(aThreadName: UnicodeString; aThreadID: TThreadID);
begin
writeln('uni threadid '+ThreadID.ToString);
writeln('uni threadhandle '+Handle.ToString);
NameThreadForDebuggingTest(aThreadName, aThreadID);
end;
class procedure TMyThread.NameThreadForDebuggingTest(aThreadName: UnicodeString; aThreadID: TThreadID);
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
ThreadHandle: THandle;
thrdinfo: THREADNAME_INFO;
begin
writeln('setting threadname to '+aThreadName);
if Assigned(SetThreadDescription) then
begin
writeln('this Windows has SetThreadDescription');
// at least Windows 10 version 1607 or Windows Server 2016
if aThreadID = TThreadID(-1) then
begin
ThreadHandle := GetCurrentThread();
end
else
begin
ThreadHandle := OpenThread($0400, False, aThreadID);
end;
SetThreadDescription(ThreadHandle, @aThreadName[1]);
end
else
begin
writeln('fallback for older Windows');
// older Windows versions
if IsDebuggerPresent then
begin
writeln('changing name');
thrdinfo.dwType := $1000;
thrdinfo.szName := @AnsiString(aThreadName)[1];
thrdinfo.dwThreadID := aThreadID;
thrdinfo.dwFlags := 0;
RaiseException(MS_VC_EXCEPTION, 0, SizeOf(thrdinfo) div SizeOf(DWord), @thrdinfo);
end;
end;
end;
var
threads: TArray<TMyThread>;
i: Integer;
thread: TMyThread;
begin
writeln('start');
KernelHandle := GetModuleHandle(KernelDLL);
if KernelHandle <> 0 then
SetThreadDescription := TSetThreadDescription(GetProcAddress(KernelHandle, 'SetThreadDescription'));
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.NameThreadForDebuggingTest('test'); // main thread
TMyThread.NameThreadForDebuggingTest('bronze', threads[2].ThreadID); // third thread
for thread in threads do
begin
thread.WaitFor;
end;
writeln('done');
readln;
end.