--- Merging r45159 into '.':

U    rtl/nativent/systhrd.inc
U    rtl/os2/systhrd.inc
U    rtl/win/systhrd.inc
--- Recording mergeinfo for merge of r45159 into '.':
 U   .
--- Merging r45160 into '.':
U    rtl/amicommon/athreads.pp
U    rtl/beos/bethreads.pp
U    rtl/inc/thread.inc
U    rtl/inc/threadh.inc
G    rtl/nativent/systhrd.inc
U    rtl/netware/systhrd.inc
U    rtl/netwlibc/systhrd.inc
U    rtl/objpas/classes/classes.inc
U    rtl/objpas/classes/classesh.inc
G    rtl/os2/systhrd.inc
U    rtl/unix/cthreads.pp
G    rtl/win/systhrd.inc
--- Recording mergeinfo for merge of r45160 into '.':
 G   .
--- Merging r45206 into '.':
U    rtl/win/sysos.inc
G    rtl/win/systhrd.inc
U    rtl/win/syswin.inc
--- Recording mergeinfo for merge of r45206 into '.':
 G   .
--- Merging r45207 into '.':
U    rtl/linux/pthread.inc
--- Recording mergeinfo for merge of r45207 into '.':
 G   .
--- Merging r45233 into '.':
G    rtl/linux/pthread.inc
G    rtl/unix/cthreads.pp
--- Recording mergeinfo for merge of r45233 into '.':
 G   .
--- Merging r45237 into '.':
G    rtl/unix/cthreads.pp
G    rtl/win/systhrd.inc
--- Recording mergeinfo for merge of r45237 into '.':
 G   .

git-svn-id: branches/fixes_3_2@47806 -

rtl/amicommon/athreads.pp

@@ -738,6 +738,18 @@ begin
 end;
 
 
+procedure ASetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
+
+procedure ASetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  ASetThreadDebugNameA(threadHandle, AnsiString(ThreadName));
+end;
+
+
 Type  PINTRTLEvent = ^TINTRTLEvent;
       TINTRTLEvent = record
         isset: boolean;
@@ -1220,6 +1232,8 @@ begin
     ThreadSetPriority      :=@AThreadSetPriority;
     ThreadGetPriority      :=@AThreadGetPriority;
     GetCurrentThreadId     :=@AGetCurrentThreadId;
+    SetThreadDebugNameA    :=@ASetThreadDebugNameA;
+    SetThreadDebugNameU    :=@ASetThreadDebugNameU;
     InitCriticalSection    :=@AInitCriticalSection;
     DoneCriticalSection    :=@ADoneCriticalSection;
     EnterCriticalSection   :=@AEnterCriticalSection;

rtl/beos/bethreads.pp

@@ -263,6 +263,15 @@ Uses
       CGetCurrentThreadId:=dword(pthread_self());
     end;
 
+    procedure BeSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
+
+    procedure BeSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -494,6 +503,8 @@ begin
     ThreadSetPriority      :=@BeThreadSetPriority;
     ThreadGetPriority      :=@BeThreadGetPriority;
     GetCurrentThreadId     :=@BeGetCurrentThreadId;
+    SetThreadDebugNameA    :=@BeSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@BeSetThreadDebugNameU;
     InitCriticalSection    :=@BeInitCriticalSection;
     DoneCriticalSection    :=@BeDoneCriticalSection;
     EnterCriticalSection   :=@BeEnterCriticalSection;

rtl/inc/thread.inc

@@ -205,6 +205,18 @@ begin
   Result:=CurrentTM.GetCurrentThreadID();
 end;
 
+procedure SetThreadDebugName(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  CurrentTM.SetThreadDebugNameA(threadHandle, ThreadName);
+end;
+
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+procedure SetThreadDebugName(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  CurrentTM.SetThreadDebugNameU(threadHandle, ThreadName);
+end;
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
+
 procedure InitCriticalSection(var cs : TRTLCriticalSection);
 
 begin
@@ -403,6 +415,18 @@ begin
   result:=TThreadID(1);
 end;
 
+procedure NoSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  NoThreadError;
+end;
+
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+procedure NoSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  NoThreadError;
+end;
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
+
 procedure NoCriticalSection(var CS);
 
 begin
@@ -511,6 +535,10 @@ const
          ThreadSetPriority      : TThreadSetPriorityHandler(@NoThreadError);
          ThreadGetPriority      : TThreadGetPriorityHandler(@NoThreadError);
          GetCurrentThreadId     : @NoGetCurrentThreadId;
+         SetThreadDebugNameA    : TThreadSetThreadDebugNameHandlerA(@NoThreadError);
+         {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+         SetThreadDebugNameU    : TThreadSetThreadDebugNameHandlerU(@NoThreadError);
+         {$endif FPC_HAS_FEATURE_UNICODESTRINGS}
          InitCriticalSection    : TCriticalSectionHandler(@NoThreadError);
          DoneCriticalSection    : TCriticalSectionHandler(@NoThreadError);
          EnterCriticalSection   : TCriticalSectionHandler(@NoThreadError);
@@ -543,6 +571,10 @@ const
          ThreadSetPriority      : @NoThreadSetPriority;
          ThreadGetPriority      : @NoThreadGetPriority;
          GetCurrentThreadId     : @NoGetCurrentThreadId;
+         SetThreadDebugNameA    : @NoSetThreadDebugNameA;
+         {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+         SetThreadDebugNameU    : @NoSetThreadDebugNameU;
+         {$endif FPC_HAS_FEATURE_UNICODESTRINGS}
          InitCriticalSection    : @NoCriticalSection;
          DoneCriticalSection    : @NoCriticalSection;
          EnterCriticalSection   : @NoCriticalSection;

rtl/inc/threadh.inc

@@ -45,6 +45,10 @@ type
   TThreadSetPriorityHandler = Function (threadHandle : TThreadID; Prio: longint): boolean;            {-15..+15, 0=normal}
   TThreadGetPriorityHandler = Function (threadHandle : TThreadID): longint;
   TGetCurrentThreadIdHandler = Function : TThreadID;
+  TThreadSetThreadDebugNameHandlerA = procedure(threadHandle: TThreadID; const ThreadName: AnsiString);
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+  TThreadSetThreadDebugNameHandlerU = procedure(threadHandle: TThreadID; const ThreadName: UnicodeString);
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
   TCriticalSectionHandler = Procedure (var cs);
   TCriticalSectionHandlerTryEnter = function (var cs):longint;
   TInitThreadVarHandler = Procedure(var offset : {$ifdef cpu16}word{$else}dword{$endif};size : dword);
@@ -78,6 +82,10 @@ type
     ThreadSetPriority      : TThreadSetPriorityHandler;
     ThreadGetPriority      : TThreadGetPriorityHandler;
     GetCurrentThreadId     : TGetCurrentThreadIdHandler;
+    SetThreadDebugNameA    : TThreadSetThreadDebugNameHandlerA;
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+    SetThreadDebugNameU    : TThreadSetThreadDebugNameHandlerU;
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
     InitCriticalSection    : TCriticalSectionHandler;
     DoneCriticalSection    : TCriticalSectionHandler;
     EnterCriticalSection   : TCriticalSectionHandler;
@@ -147,6 +155,10 @@ function  WaitForThreadTerminate (threadHandle : TThreadID; TimeoutMs : longint)
 function  ThreadSetPriority (threadHandle : TThreadID; Prio: longint): boolean;            {-15..+15, 0=normal}
 function  ThreadGetPriority (threadHandle : TThreadID): longint;
 function  GetCurrentThreadId : TThreadID;
+procedure SetThreadDebugName(threadHandle: TThreadID; const ThreadName: AnsiString);
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
+procedure SetThreadDebugName(threadHandle: TThreadID; const ThreadName: UnicodeString);
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
 
 
 { this allows to do a lot of things in MT safe way }

rtl/linux/pthread.inc

@@ -143,33 +143,41 @@ Type
     function pthread_mutex_unlock(__mutex:ppthread_mutex_t):longint;cdecl;external;
     function pthread_mutexattr_init(__attr:ppthread_mutexattr_t):longint;cdecl;external;
     function pthread_mutexattr_destroy(__attr:ppthread_mutexattr_t):longint;cdecl;external;
+{$ifndef ANDROID}
     function pthread_mutexattr_setkind_np(__attr:ppthread_mutexattr_t; __kind:longint):longint;cdecl;external;
     function pthread_mutexattr_getkind_np(__attr:ppthread_mutexattr_t; __kind:plongint):longint;cdecl;external;
+{$endif}
     function pthread_cond_init(__cond:ppthread_cond_t; __cond_attr:ppthread_condattr_t):longint;cdecl;external;
     function pthread_cond_destroy(__cond:ppthread_cond_t):longint;cdecl;external;
     function pthread_cond_signal(__cond:ppthread_cond_t):longint;cdecl;external;
     function pthread_cond_broadcast(__cond:ppthread_cond_t):longint;cdecl;external;
     function pthread_cond_wait(__cond:ppthread_cond_t; __mutex:ppthread_mutex_t):longint;cdecl;external;
     function pthread_cond_timedwait(__cond:ppthread_cond_t; __mutex:ppthread_mutex_t; __abstime:ptimespec):longint;cdecl;external;
+{$ifndef ANDROID}
     function pthread_condattr_init(__attr:ppthread_condattr_t):longint;cdecl;external;
     function pthread_condattr_destroy(__attr:ppthread_condattr_t):longint;cdecl;external;
     function pthread_condattr_setclock(__attr:ppthread_condattr_t; __clock_id: longint):longint;cdecl;external;
+{$endif}
     function pthread_key_create(__key:ppthread_key_t; __destr_function:__destr_function_t):longint;cdecl;external;
     function pthread_key_delete(__key:pthread_key_t):longint;cdecl;external;
     function pthread_setspecific(__key:pthread_key_t; __pointer:pointer):longint;cdecl;external;
     function pthread_getspecific(__key:pthread_key_t):pointer;cdecl;external;
 {    function pthread_once(__once_control:ppthread_once_t; __init_routine:tprocedure ):longint;cdecl;external;}
+{$ifndef ANDROID}
     function pthread_setcancelstate(__state:longint; __oldstate:plongint):longint;cdecl;external;
     function pthread_setcanceltype(__type:longint; __oldtype:plongint):longint;cdecl;external;
     function pthread_cancel(__thread:pthread_t):longint;cdecl;external;
     procedure pthread_testcancel;cdecl;external;
+{$endif}
 {    procedure _pthread_cleanup_push(__buffer:p_pthread_cleanup_buffer;__routine:t_pthread_cleanup_push_routine; __arg:pointer);cdecl;external; }
 {    procedure _pthread_cleanup_push_defer(__buffer:p_pthread_cleanup_buffer;__routine:t_pthread_cleanup_push_defer_routine; __arg:pointer);cdecl;external;}
 {    function pthread_sigmask(__how:longint; __newmask:plibc_sigset; __oldmask:plibc_sigset):longint;cdecl;external;}
     function pthread_kill(__thread:pthread_t; __signo:longint):longint;cdecl;external;
 {    function sigwait(__set:plibc_sigset; __sig:plongint):longint;cdecl;external;}
+{$ifndef ANDROID}
     function pthread_atfork(__prepare:tprocedure ; __parent:tprocedure ; __child:tprocedure ):longint;cdecl;external;
     procedure pthread_kill_other_threads_np;cdecl;external;
+{$endif}
     function pthread_sigmask(how: cint; nset: plibc_sigset; oset: plibc_sigset): cint; cdecl; external;
 
     function sem_init (__sem:Psem_t; __pshared:longint; __value:dword):longint;cdecl;external;
@@ -183,6 +191,7 @@ Type
     function sem_getvalue (__sem:Psem_t; __sval:Plongint):longint;cdecl;external;
 
     function pthread_mutexattr_settype (__attr: Ppthread_mutexattr_t; Kind:Integer): Integer; cdecl;external;
+    function pthread_setname_np(thread: pthread_t; name: PAnsiChar):cint;cdecl;external;
 
 {$else}
 Var
@@ -264,6 +273,7 @@ Var
     sem_getvalue :   function (__sem:Psem_t; __sval:Plongint):longint;cdecl;
 
     pthread_mutexattr_settype : function(__attr: Ppthread_mutexattr_t; Kind:Integer): Integer; cdecl;
+    pthread_setname_np : function(thread: pthread_t; name: PAnsiChar):cint;cdecl;
 
 
 Var
@@ -355,6 +365,7 @@ begin
   Pointer(sem_post     ) := dlsym(PthreadDLL,'sem_post');
   Pointer(sem_getvalue ) := dlsym(PthreadDLL,'sem_getvalue');
   Pointer(pthread_mutexattr_settype) := dlsym(PthreadDLL,'pthread_mutexattr_settype');
+  Pointer(pthread_setname_np) := dlsym(PthreadDLL,'pthread_setname_np');
 end;
 
 Function UnLoadPthreads : Boolean;

rtl/nativent/systhrd.inc

@@ -130,6 +130,14 @@ const
       Result := 0;
     end;
 
+    procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+    end;
+
+    procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+    end;
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -231,11 +239,13 @@ begin
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
     ThreadSwitch           :=@SysThreadSwitch;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

rtl/netware/systhrd.inc

@@ -244,13 +244,20 @@ begin
   SysThreadGetPriority := 0;
 end;
 
-
-
 function  SysGetCurrentThreadId : dword;
 begin
   SysGetCurrentThreadId := CGetThreadID;
 end;
 
+procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
+procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
 
 { netware requires all allocated semaphores }
 { to be closed before terminating the nlm, otherwise }
@@ -469,6 +476,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

rtl/netwlibc/systhrd.inc

@@ -221,6 +221,15 @@
       SysGetCurrentThreadId:=dword(pthread_self);
     end;
 
+    procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
+
+    procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+      {$Warning SetThreadDebugName needs to be implemented}
+    end;
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -364,6 +373,8 @@ begin
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

rtl/objpas/classes/classes.inc

@@ -674,36 +674,20 @@ begin
 end;
 
 
-{$ifdef THREADNAME_IS_ANSISTRING}
-{ the platform implements the AnsiString variant and the UnicodeString variant
-  simply calls the AnsiString variant }
 class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
 begin
-  NameThreadForDebugging(AnsiString(aThreadName), aThreadID);
+{$ifdef FPC_HAS_FEATURE_THREADING}
-end;
+  SetThreadDebugName(aThreadID, aThreadName);
-
-  {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
-class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
-begin
-  { empty }
-end;
-  {$endif}
-{$else}
-  {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
-{ the platform implements the UnicodeString variant and the AnsiString variant
-  simply calls the UnicodeString variant }
-class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
-begin
-  { empty }
-end;
-  {$endif}
-
-
-class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
-begin
-  NameThreadForDebugging(UnicodeString(aThreadName), aThreadID);
-end;
 {$endif}
+end;
+
+
+class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
+begin
+{$ifdef FPC_HAS_FEATURE_THREADING}
+  SetThreadDebugName(aThreadID, aThreadName);
+{$endif}
+end;
 
 
 class procedure TThread.Yield;

rtl/objpas/classes/classesh.inc

@@ -1793,13 +1793,7 @@ type
     destructor Destroy; override;
     { Note: Once closures are supported aProc will be changed to TProc }
     class function CreateAnonymousThread(aProc: TProcedure): TThread; static;
-    { Use HAS_TTHREAD_NAMETHREADFORDEBUGGING to implement a platform specific
+    class procedure NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID = TThreadID(-1)); static; inline;
-      variant of the UnicodeString method. The AnsiString method calls the
-      UnicodeString method. If your platform's API only supports AnsiString you
-      can additionally define THREADNAME_IS_ANSISTRING to swap the logic. Then
-      the UnicodeString variant will call the AnsiString variant which can be
-      implemented for a specific platform }
-    class procedure NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID = TThreadID(-1)); static;
     class procedure NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID = TThreadID(-1)); static; inline;
     class procedure SetReturnValue(aValue: Integer); static;
     class function CheckTerminated: Boolean; static;

rtl/os2/systhrd.inc

@@ -659,6 +659,17 @@ begin
 end;
 
 
+procedure SysSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
+
+procedure SysSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+begin
+  {$Warning SetThreadDebugName needs to be implemented}
+end;
+
 
 {*****************************************************************************
                           Delphi/Win32 compatibility
@@ -936,12 +947,14 @@ begin
     SuspendThread          :=@SysSuspendThread;
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     ThreadSwitch           :=@SysThreadSwitch;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;

rtl/unix/cthreads.pp

@@ -481,6 +481,51 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
     end;
 
 
+  procedure CSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
+{$if defined(Linux) or defined(Android)}
+    var
+      CuttedName: AnsiString;
+{$endif}
+    begin
+{$if defined(Linux) or defined(Android)}
+      if ThreadName = '' then
+        Exit;
+  {$ifdef dynpthreads}
+      if Assigned(pthread_setname_np) then
+  {$endif dynpthreads}
+      begin
+        // length restricted to 16 characters including terminating null byte
+        CuttedName:=Copy(ThreadName, 1, 15);
+        if threadHandle=TThreadID(-1) then
+        begin
+          pthread_setname_np(pthread_self(), @CuttedName[1]);
+        end
+        else
+        begin
+          pthread_setname_np(pthread_t(threadHandle), @CuttedName[1]);
+        end;
+      end;
+{$else}
+       {$Warning SetThreadDebugName needs to be implemented}
+{$endif}
+    end;
+
+
+  procedure CSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
+    begin
+{$if defined(Linux) or defined(Android)}
+  {$ifdef dynpthreads}
+      if Assigned(pthread_setname_np) then
+  {$endif dynpthreads}
+      begin
+        CSetThreadDebugNameA(threadHandle, AnsiString(ThreadName));
+      end;
+{$else}
+       {$Warning SetThreadDebugName needs to be implemented}
+{$endif}
+    end;
+
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -938,6 +983,8 @@ begin
     ThreadSetPriority      :=@CThreadSetPriority;
     ThreadGetPriority      :=@CThreadGetPriority;
     GetCurrentThreadId     :=@CGetCurrentThreadId;
+    SetThreadDebugNameA    :=@CSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@CSetThreadDebugNameU;
     InitCriticalSection    :=@CInitCriticalSection;
     DoneCriticalSection    :=@CDoneCriticalSection;
     EnterCriticalSection   :=@CEnterCriticalSection;

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,6 +345,98 @@ 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 ThreadName = '' then
+        Exit;
+
+      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 ThreadName = '' then
+        Exit;
+
+      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;
+
 {*****************************************************************************
                           Delphi/Win32 compatibility
 *****************************************************************************}
@@ -497,10 +596,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
@@ -512,11 +611,13 @@ begin
     ResumeThread           :=@SysResumeThread;
     KillThread             :=@SysKillThread;
     ThreadSwitch           :=@SysThreadSwitch;
-    CloseThread		   :=@SysCloseThread;
+    CloseThread            :=@SysCloseThread;
     WaitForThreadTerminate :=@SysWaitForThreadTerminate;
     ThreadSetPriority      :=@SysThreadSetPriority;
     ThreadGetPriority      :=@SysThreadGetPriority;
     GetCurrentThreadId     :=@SysGetCurrentThreadId;
+    SetThreadDebugNameA    :=@SysSetThreadDebugNameA;
+    SetThreadDebugNameU    :=@SysSetThreadDebugNameU;
     InitCriticalSection    :=@SysInitCriticalSection;
     DoneCriticalSection    :=@SysDoneCriticalSection;
     EnterCriticalSection   :=@SysEnterCriticalSection;
@@ -544,13 +645,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' }