* fix for Mantis #36941: apply (adjusted) patch by Bi0T1N to implement SetThreadDebugNameA and -U for Windows, with the exception of Windows CE

git-svn-id: trunk@45206 -

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

rtl/win/systhrd.inc

@@ -52,6 +52,13 @@ function  WaitForSingleObject (hHandle : THandle;Milliseconds: dword): dword; {$
 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';
 {$ifndef 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';
+type
+  TSetThreadDescription = function(threadHandle: THandle; lpThreadDescription: PWideChar): HResult; stdcall;
+var
+  WinSetThreadDescription: TSetThreadDescription;
 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';
 function  SetEvent(hEvent:THandle):LONGBOOL; stdcall; external KernelDLL name 'SetEvent';
@@ -338,14 +345,90 @@ var
       SysGetCurrentThreadId:=Win32GetCurrentThreadId;
     end;
 
+{$ifndef WINCE}
+    { 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
+        RaiseException(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;
+      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;
+{$endif WINCE}
+
     procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
     begin
+{$ifndef WINCE}
+      if WinIsDebuggerPresent then
+      begin
+        RaiseMSVCExceptionMethod(threadHandle, ThreadName);
+      end;
+
+      if Assigned(WinSetThreadDescription) then
+      begin
+        SetThreadDescriptionMethod(threadHandle, UnicodeString(ThreadName));
+      end;
+{$else WINCE}
       {$Warning SetThreadDebugNameA needs to be implemented}
+{$endif WINCE}
     end;
 
     procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
     begin
+{$ifndef WINCE}
+      if WinIsDebuggerPresent then
+      begin
+        RaiseMSVCExceptionMethod(threadHandle, AnsiString(ThreadName));
+      end;
+
+      if Assigned(WinSetThreadDescription) then
+      begin
+        SetThreadDescriptionMethod(threadHandle, ThreadName);
+      end;
+{$else WINCE}
       {$Warning SetThreadDebugNameU needs to be implemented}
+{$endif WINCE}
     end;
 
 {*****************************************************************************
@@ -507,10 +590,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,13 +639,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;
 

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' }