diff --git a/rtl/amicommon/athreads.pp b/rtl/amicommon/athreads.pp index 614bdc03b4..bb2f253594 100644 --- a/rtl/amicommon/athreads.pp +++ b/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; diff --git a/rtl/beos/bethreads.pp b/rtl/beos/bethreads.pp index 98de02c985..fe437f0474 100644 --- a/rtl/beos/bethreads.pp +++ b/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; diff --git a/rtl/inc/thread.inc b/rtl/inc/thread.inc index 98d233ccd1..94f8a602ef 100644 --- a/rtl/inc/thread.inc +++ b/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; diff --git a/rtl/inc/threadh.inc b/rtl/inc/threadh.inc index 30942afc80..0d0b626f28 100644 --- a/rtl/inc/threadh.inc +++ b/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 } diff --git a/rtl/linux/pthread.inc b/rtl/linux/pthread.inc index 50522c9994..316c096a05 100644 --- a/rtl/linux/pthread.inc +++ b/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; diff --git a/rtl/nativent/systhrd.inc b/rtl/nativent/systhrd.inc index 4c628688d7..2eac9b3ca5 100644 --- a/rtl/nativent/systhrd.inc +++ b/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; diff --git a/rtl/netware/systhrd.inc b/rtl/netware/systhrd.inc index f11fe133e5..c362c59704 100644 --- a/rtl/netware/systhrd.inc +++ b/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; diff --git a/rtl/netwlibc/systhrd.inc b/rtl/netwlibc/systhrd.inc index 8205feefec..5d12022fad 100644 --- a/rtl/netwlibc/systhrd.inc +++ b/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; diff --git a/rtl/objpas/classes/classes.inc b/rtl/objpas/classes/classes.inc index 5300682b04..78a37ec6f3 100644 --- a/rtl/objpas/classes/classes.inc +++ b/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); -end; - - {$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; +{$ifdef FPC_HAS_FEATURE_THREADING} + SetThreadDebugName(aThreadID, aThreadName); {$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; diff --git a/rtl/objpas/classes/classesh.inc b/rtl/objpas/classes/classesh.inc index e8808b149a..79b93f79be 100644 --- a/rtl/objpas/classes/classesh.inc +++ b/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 - 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: UnicodeString; aThreadID: TThreadID = TThreadID(-1)); static; inline; class procedure NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID = TThreadID(-1)); static; inline; class procedure SetReturnValue(aValue: Integer); static; class function CheckTerminated: Boolean; static; diff --git a/rtl/os2/systhrd.inc b/rtl/os2/systhrd.inc index f798eff510..3cd6d6e5c0 100644 --- a/rtl/os2/systhrd.inc +++ b/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; diff --git a/rtl/unix/cthreads.pp b/rtl/unix/cthreads.pp index 0ea07e3530..76bd636f52 100644 --- a/rtl/unix/cthreads.pp +++ b/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; diff --git a/rtl/win/sysos.inc b/rtl/win/sysos.inc index e8842297fd..3d23035aab 100644 --- a/rtl/win/sysos.inc +++ b/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 a/rtl/win/systhrd.inc b/rtl/win/systhrd.inc index bbd6b132bf..10bb07fda4 100644 --- a/rtl/win/systhrd.inc +++ b/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; diff --git a/rtl/win/syswin.inc b/rtl/win/syswin.inc index b707757d8c..75e6011fc5 100644 --- a/rtl/win/syswin.inc +++ b/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' }