mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 15:49:27 +02:00
--- 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 -
This commit is contained in:
svenbarth
parent
c60ce2af07
commit
74a1b6406e
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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 }
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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';
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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' }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user