mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-13 10:29:17 +02:00
* more platform independent thread routines, needs to be implemented for unix
This commit is contained in:
armin
parent
e414b2032c
commit
2d9ba86107
@ -13,15 +13,6 @@
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{ additional functions needed for netware that are not defined in systhrds }
|
||||
|
||||
function SuspendThread (threadId : longint) : longint; cdecl; external 'clib' name 'SuspendThread';
|
||||
function ResumeThread (threadId : longint) : longint; cdecl; external 'clib' name 'ResumeThread';
|
||||
procedure ThreadSwitchWithDelay; cdecl; external 'clib' name 'ThreadSwitchWithDelay';
|
||||
function GetThreadName (threadId : longint; var threadName) : longint; cdecl; external 'clib' name 'GetThreadName';
|
||||
function RenameThread (threadId : longint; threadName:pchar) : longint; cdecl; external 'clib' name 'RenameThread';
|
||||
|
||||
|
||||
|
||||
type
|
||||
@ -146,7 +137,6 @@ end;
|
||||
constructor TThread.Create(CreateSuspended: Boolean);
|
||||
var
|
||||
Flags: Integer;
|
||||
nam : string [18]; {17 chars is the maximum}
|
||||
begin
|
||||
inherited Create;
|
||||
AddThread(self);
|
||||
@ -154,8 +144,6 @@ begin
|
||||
{ Create new thread }
|
||||
FHandle := BeginThread (@ThreadProc,self);
|
||||
if FSuspended then Suspend;
|
||||
nam := copy (ClassName,1,17)+#0;
|
||||
RenameThread (FHandle, @nam[1]);
|
||||
FThreadID := FHandle;
|
||||
//IsMultiThread := TRUE; {already set by systhrds}
|
||||
end;
|
||||
@ -170,7 +158,7 @@ begin
|
||||
WaitFor;
|
||||
end;
|
||||
if FHandle <> -1 then
|
||||
SuspendThread (FHandle); {something went wrong, this will crash the server at unload}
|
||||
KillThread (FHandle); {something went wrong, kill the thread (not possible on netware)}
|
||||
inherited Destroy;
|
||||
RemoveThread(self);
|
||||
end;
|
||||
@ -188,24 +176,40 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
Priorities: array [TThreadPriority] of Integer =
|
||||
(THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
|
||||
THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
|
||||
THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
|
||||
|
||||
function TThread.GetPriority: TThreadPriority;
|
||||
var
|
||||
P: Integer;
|
||||
I: TThreadPriority;
|
||||
begin
|
||||
result := tpNormal;
|
||||
P := ThreadGetPriority(FHandle);
|
||||
Result := tpNormal;
|
||||
for I := Low(TThreadPriority) to High(TThreadPriority) do
|
||||
if Priorities[I] = P then Result := I;
|
||||
end;
|
||||
|
||||
|
||||
procedure TThread.SetPriority(Value: TThreadPriority);
|
||||
begin
|
||||
ThreadSetPriority(FHandle, Priorities[Value]);
|
||||
end;
|
||||
|
||||
|
||||
{does not make sense for netware}
|
||||
procedure TThread.Synchronize(Method: TThreadMethod);
|
||||
begin
|
||||
{$ifndef netware}
|
||||
FSynchronizeException := nil;
|
||||
FMethod := Method;
|
||||
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
|
||||
{$warning Synchronize needs implementation}
|
||||
if Assigned(FSynchronizeException) then
|
||||
raise FSynchronizeException;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
|
||||
@ -236,24 +240,23 @@ end;
|
||||
procedure TThread.Terminate;
|
||||
begin
|
||||
FTerminated := True;
|
||||
ThreadSwitchWithDelay;
|
||||
ThreadSwitch;
|
||||
end;
|
||||
|
||||
|
||||
function TThread.WaitFor: Integer;
|
||||
var
|
||||
status : longint;
|
||||
buf : array [0..50] of char;
|
||||
begin
|
||||
repeat
|
||||
status := GetThreadName (FHandle,Buf); {should return EBADHNDL if thread is terminated}
|
||||
ThreadSwitchWithDelay;
|
||||
until status <> 0;
|
||||
Result:=0;
|
||||
Result := WaitForThreadTerminate (FHandle,0);
|
||||
if Result = 0 then
|
||||
FHandle := -1;
|
||||
end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2003-03-25 17:56:19 armin
|
||||
Revision 1.2 2003-03-27 17:14:27 armin
|
||||
* more platform independent thread routines, needs to be implemented for unix
|
||||
|
||||
Revision 1.1 2003/03/25 17:56:19 armin
|
||||
* first fcl implementation for netware
|
||||
|
||||
Revision 1.7 2002/12/18 20:44:36 peter
|
||||
|
||||
@ -14,7 +14,7 @@
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
|
||||
const
|
||||
DefaultStackSize = 32768; { including 16384 margin for stackchecking }
|
||||
|
||||
@ -44,6 +44,17 @@ function BeginThread(ThreadFunction : tthreadfunc;p : pointer; var ThreadId : Lo
|
||||
procedure EndThread(ExitCode : DWord);
|
||||
procedure EndThread;
|
||||
|
||||
{some thread support functions}
|
||||
function SuspendThread (threadHandle : dword) : dword;
|
||||
function ResumeThread (threadHandle : dword) : dword;
|
||||
procedure ThreadSwitch; {give time to other threads}
|
||||
function KillThread (threadHandle : dword) : dword;
|
||||
function WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword; {0=no timeout}
|
||||
function ThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
|
||||
function ThreadGetPriority (threadHandle : dword): Integer;
|
||||
function GetCurrentThreadHandle : dword;
|
||||
|
||||
|
||||
{ this allows to do a lot of things in MT safe way }
|
||||
{ it is also used to make the heap management }
|
||||
{ thread safe }
|
||||
@ -54,7 +65,10 @@ procedure LeaveCriticalsection(var cs : TRTLCriticalSection);
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.9 2002-10-16 19:04:27 michael
|
||||
Revision 1.10 2003-03-27 17:14:27 armin
|
||||
* more platform independent thread routines, needs to be implemented for unix
|
||||
|
||||
Revision 1.9 2002/10/16 19:04:27 michael
|
||||
+ More system-independent thread routines
|
||||
|
||||
Revision 1.8 2002/10/14 19:39:17 peter
|
||||
|
||||
@ -32,6 +32,16 @@ interface
|
||||
{ Include generic thread interface }
|
||||
{$i threadh.inc }
|
||||
|
||||
{Delphi/Windows compatible priority constants, they are also defined for Unix and Win32}
|
||||
const
|
||||
THREAD_PRIORITY_IDLE = -15;
|
||||
THREAD_PRIORITY_LOWEST = -2;
|
||||
THREAD_PRIORITY_BELOW_NORMAL = -1;
|
||||
THREAD_PRIORITY_NORMAL = 0;
|
||||
THREAD_PRIORITY_ABOVE_NORMAL = 1;
|
||||
THREAD_PRIORITY_HIGHEST = 2;
|
||||
THREAD_PRIORITY_TIME_CRITICAL = 15;
|
||||
|
||||
implementation
|
||||
|
||||
{$i thread.inc }
|
||||
@ -198,6 +208,73 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Thread handling
|
||||
*****************************************************************************}
|
||||
|
||||
|
||||
function __SuspendThread (threadId : dword) : dword; cdecl; external 'clib' name 'SuspendThread';
|
||||
function __ResumeThread (threadId : dword) : dword; cdecl; external 'clib' name 'ResumeThread';
|
||||
procedure __ThreadSwitchWithDelay; cdecl; external 'clib' name 'ThreadSwitchWithDelay';
|
||||
|
||||
{redefined because the interface has not cdecl calling convention}
|
||||
function SuspendThread (threadHandle : dword) : dword;
|
||||
begin
|
||||
SuspendThread := __SuspendThread (threadHandle);
|
||||
end;
|
||||
|
||||
|
||||
function ResumeThread (threadHandle : dword) : dword;
|
||||
begin
|
||||
ResumeThread := __ResumeThread (threadHandle);
|
||||
end;
|
||||
|
||||
|
||||
procedure ThreadSwitch;
|
||||
begin
|
||||
__ThreadSwitchWithDelay;
|
||||
end;
|
||||
|
||||
|
||||
function KillThread (threadHandle : dword) : dword;
|
||||
begin
|
||||
KillThread := 1; {not supported for netware}
|
||||
end;
|
||||
|
||||
function GetThreadName (threadId : longint; var threadName) : longint; cdecl; external 'clib' name 'GetThreadName';
|
||||
//function __RenameThread (threadId : longint; threadName:pchar) : longint; cdecl; external 'clib' name 'RenameThread';
|
||||
|
||||
function WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;
|
||||
var
|
||||
status : longint;
|
||||
buf : array [0..50] of char;
|
||||
begin
|
||||
{$warning timeout needs to be implemented}
|
||||
repeat
|
||||
status := GetThreadName (ThreadHandle,Buf); {should return EBADHNDL if thread is terminated}
|
||||
ThreadSwitch;
|
||||
until status <> 0;
|
||||
WaitForThreadTerminate:=0;
|
||||
end;
|
||||
|
||||
function ThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
|
||||
begin
|
||||
ThreadSetPriority := true;
|
||||
end;
|
||||
|
||||
function ThreadGetPriority (threadHandle : dword): Integer;
|
||||
begin
|
||||
ThreadGetPriority := 0;
|
||||
end;
|
||||
|
||||
function GetThreadID : dword; cdecl; external 'clib' name 'GetThreadID';
|
||||
|
||||
function GetCurrentThreadHandle : dword;
|
||||
begin
|
||||
GetCurrentThreadHandle := GetThreadID;
|
||||
end;
|
||||
|
||||
|
||||
{ netware requires all allocated semaphores }
|
||||
{ to be closed before terminating the nlm, otherwise }
|
||||
{ the server will abend (except for netware 6 i think) }
|
||||
@ -329,20 +406,20 @@ end;
|
||||
{*****************************************************************************
|
||||
Heap Mutex Protection
|
||||
*****************************************************************************}
|
||||
|
||||
|
||||
var
|
||||
HeapMutex : TRTLCriticalSection;
|
||||
|
||||
|
||||
procedure NWHeapMutexInit;
|
||||
begin
|
||||
InitCriticalSection(heapmutex);
|
||||
end;
|
||||
|
||||
|
||||
procedure NWHeapMutexDone;
|
||||
begin
|
||||
DoneCriticalSection(heapmutex);
|
||||
end;
|
||||
|
||||
|
||||
procedure NWHeapMutexLock;
|
||||
begin
|
||||
EnterCriticalSection(heapmutex);
|
||||
@ -352,7 +429,7 @@ procedure NWHeapMutexUnlock;
|
||||
begin
|
||||
LeaveCriticalSection(heapmutex);
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
NWMemoryMutexManager : TMemoryMutexManager = (
|
||||
MutexInit : @NWHeapMutexInit;
|
||||
@ -360,7 +437,7 @@ const
|
||||
MutexLock : @NWHeapMutexLock;
|
||||
MutexUnlock : @NWHeapMutexUnlock;
|
||||
);
|
||||
|
||||
|
||||
procedure InitHeapMutexes;
|
||||
begin
|
||||
SetMemoryMutexManager(NWMemoryMutexManager);
|
||||
@ -377,7 +454,10 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2003-02-16 17:12:15 armin
|
||||
Revision 1.2 2003-03-27 17:14:27 armin
|
||||
* more platform independent thread routines, needs to be implemented for unix
|
||||
|
||||
Revision 1.1 2003/02/16 17:12:15 armin
|
||||
* systhrds fir netware added
|
||||
|
||||
|
||||
|
||||
@ -46,7 +46,7 @@ interface
|
||||
implementation
|
||||
|
||||
{*****************************************************************************
|
||||
Generic overloaded
|
||||
Generic overloaded
|
||||
*****************************************************************************}
|
||||
|
||||
{ Include generic overloaded routines }
|
||||
@ -296,8 +296,8 @@ CONST
|
||||
pthread_create(@threadid, @thread_attr, @ThreadMain,ti);
|
||||
BeginThread:=threadid;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
|
||||
procedure EndThread(ExitCode : DWord);
|
||||
begin
|
||||
DoneThread;
|
||||
@ -305,6 +305,49 @@ CONST
|
||||
end;
|
||||
|
||||
|
||||
function SuspendThread (threadHandle : dword) : dword;
|
||||
begin
|
||||
{$Warning SuspendThread needs to be implemented}
|
||||
end;
|
||||
|
||||
function ResumeThread (threadHandle : dword) : dword;
|
||||
begin
|
||||
{$Warning ResumeThread needs to be implemented}
|
||||
end;
|
||||
|
||||
procedure ThreadSwitch; {give time to other threads}
|
||||
begin
|
||||
{extern int pthread_yield (void) __THROW;}
|
||||
{$Warning ThreadSwitch needs to be implemented}
|
||||
end;
|
||||
|
||||
function KillThread (threadHandle : dword) : dword;
|
||||
begin
|
||||
{$Warning KillThread needs to be implemented}
|
||||
end;
|
||||
|
||||
function WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword; {0=no timeout}
|
||||
begin
|
||||
{$Warning WaitForThreadTerminate needs to be implemented}
|
||||
end;
|
||||
|
||||
function ThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
|
||||
begin
|
||||
{$Warning ThreadSetPriority needs to be implemented}
|
||||
end;
|
||||
|
||||
|
||||
function ThreadGetPriority (threadHandle : dword): Integer;
|
||||
begin
|
||||
{$Warning ThreadGetPriority needs to be implemented}
|
||||
end;
|
||||
|
||||
function GetCurrentThreadHandle : dword;
|
||||
begin
|
||||
{$Warning ThreadGetPriority needs to be implemented}
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Delphi/Win32 compatibility
|
||||
*****************************************************************************}
|
||||
@ -382,7 +425,10 @@ initialization
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.7 2003-01-05 19:11:32 marco
|
||||
Revision 1.8 2003-03-27 17:14:27 armin
|
||||
* more platform independent thread routines, needs to be implemented for unix
|
||||
|
||||
Revision 1.7 2003/01/05 19:11:32 marco
|
||||
* small changes originating from introduction of Baseunix to FreeBSD
|
||||
|
||||
Revision 1.6 2002/11/11 21:41:06 marco
|
||||
@ -409,4 +455,4 @@ end.
|
||||
* threads unit added for thread support
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -73,6 +73,15 @@ procedure ExitThread(dwExitCode : DWord);
|
||||
function GlobalAlloc(uFlags:DWord; dwBytes:DWORD):Pointer;
|
||||
external 'kernel32' name 'GlobalAlloc';
|
||||
function GlobalFree(hMem : Pointer):Pointer; external 'kernel32' name 'GlobalFree';
|
||||
procedure Sleep(dwMilliseconds: DWord); external 'kernel32' name 'Sleep';
|
||||
function SuspendThread (threadHandle : dword) : dword; external 'kernel32' name 'SuspendThread';
|
||||
function ResumeThread (threadHandle : dword) : dword; external 'kernel32' name 'ResumeThread';
|
||||
function TerminateThread (threadHandle : dword; var exitCode : dword) : boolean; external 'kernel32' name 'TerminateThread';
|
||||
function GetLastError : dword; external 'kernel32' name 'GetLastError';
|
||||
function WaitForSingleObject (hHandle,Milliseconds: dword): dword; external 'kernel32' name 'WaitForSingleObject';
|
||||
function ThreadSetPriority (threadHandle : dword; Prio: longint): boolean; external 'kernel32' name 'SetThreadPriority';
|
||||
function ThreadGetPriority (threadHandle : dword): Integer; external 'kernel32' name 'GetThreadPriority';
|
||||
function GetCurrentThreadHandle : dword; external 'kernel32' name 'GetCurrentThread';
|
||||
|
||||
{*****************************************************************************
|
||||
Threadvar support
|
||||
@ -209,6 +218,29 @@ function GlobalFree(hMem : Pointer):Pointer; external 'kernel32' name 'GlobalFre
|
||||
end;
|
||||
|
||||
|
||||
procedure ThreadSwitch;
|
||||
begin
|
||||
Sleep(0);
|
||||
end;
|
||||
|
||||
|
||||
function KillThread (threadHandle : dword) : dword;
|
||||
var exitCode : dword;
|
||||
begin
|
||||
if not TerminateThread (threadHandle, exitCode) then
|
||||
KillThread := GetLastError
|
||||
else
|
||||
KillThread := 0;
|
||||
end;
|
||||
|
||||
function WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;
|
||||
begin
|
||||
if timeoutMs = 0 then dec (timeoutMs); // $ffffffff is INFINITE
|
||||
WaitForThreadTerminate := WaitForSingleObject(threadHandle, TimeoutMs);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Delphi/Win32 compatibility
|
||||
*****************************************************************************}
|
||||
@ -274,7 +306,10 @@ initialization
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2003-03-24 16:12:01 jonas
|
||||
Revision 1.4 2003-03-27 17:14:27 armin
|
||||
* more platform independent thread routines, needs to be implemented for unix
|
||||
|
||||
Revision 1.3 2003/03/24 16:12:01 jonas
|
||||
* BeginThread() now returns the thread handle instead of the threadid
|
||||
(needed because you have to free the handle after your thread is
|
||||
finished, and the threadid is already returned via a var-parameter)
|
||||
@ -289,4 +324,4 @@ end.
|
||||
* threads unit added for thread support
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user