mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-22 09:49:28 +02:00
* pthreads based ttread from Johannes Berg
This commit is contained in:
marco
parent
d709cc12ab
commit
20bd2d0e06
@ -14,6 +14,8 @@
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
|
||||
{$IFDEF VER1_0} // leaving the old implementation in for now...
|
||||
type
|
||||
PThreadRec=^TThreadRec;
|
||||
TThreadRec=record
|
||||
@ -74,7 +76,7 @@ begin
|
||||
Act^.sa_handler := @SIGCHLDHandler;
|
||||
Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART};
|
||||
Fillchar(Act^.sa_mask,sizeof(Act^.sa_mask),0); //Do not block all signals ??. Don't need if SA_NOMASK in flags
|
||||
FpSigAction(SIGCHLD, @Act, @OldAct);
|
||||
FpSigAction(SIGCHLD, Act, OldAct);
|
||||
|
||||
FreeMem(Act, SizeOf(SigActionRec));
|
||||
FreeMem(OldAct, SizeOf(SigActionRec));
|
||||
@ -146,6 +148,8 @@ var
|
||||
FreeThread: Boolean;
|
||||
Thread : TThread absolute args;
|
||||
begin
|
||||
while Thread.FHandle = 0 do fpsleep(1);
|
||||
if Thread.FSuspended then Thread.suspend();
|
||||
try
|
||||
Thread.Execute;
|
||||
except
|
||||
@ -176,7 +180,7 @@ begin
|
||||
FCallExitProcess:=false;
|
||||
{ Clone }
|
||||
FHandle:= Clone(@ThreadProc,FStackPointer,Flags,self);
|
||||
if FSuspended then Suspend;
|
||||
// if FSuspended then Suspend;
|
||||
FThreadID := FHandle;
|
||||
IsMultiThread := TRUE;
|
||||
FFatalException := nil;
|
||||
@ -191,7 +195,7 @@ begin
|
||||
WaitFor;
|
||||
end;
|
||||
if FHandle <> -1 then
|
||||
fpkill(FHandle, SIGKILL);
|
||||
fpkill(FHandle, SIGKILL);
|
||||
dec(FStackPointer,FStackSize);
|
||||
Freemem(FStackPointer);
|
||||
FFatalException.Free;
|
||||
@ -224,8 +228,7 @@ var
|
||||
P: Integer;
|
||||
I: TThreadPriority;
|
||||
begin
|
||||
P :=
|
||||
Unix.fpGetPriority(Prio_Process,FHandle);
|
||||
P := fpGetPriority(Prio_Process,FHandle);
|
||||
Result := tpNormal;
|
||||
for I := Low(TThreadPriority) to High(TThreadPriority) do
|
||||
if Priorities[I] = P then
|
||||
@ -235,7 +238,7 @@ end;
|
||||
|
||||
procedure TThread.SetPriority(Value: TThreadPriority);
|
||||
begin
|
||||
Unix.fpSetPriority(Prio_Process,FHandle,Priorities[Value]);
|
||||
fpSetPriority(Prio_Process,FHandle,Priorities[Value]);
|
||||
end;
|
||||
|
||||
|
||||
@ -261,14 +264,14 @@ end;
|
||||
|
||||
procedure TThread.Suspend;
|
||||
begin
|
||||
fpkill(FHandle, SIGSTOP);
|
||||
FSuspended := true;
|
||||
fpKill(FHandle, SIGSTOP);
|
||||
end;
|
||||
|
||||
|
||||
procedure TThread.Resume;
|
||||
begin
|
||||
fpkill(FHandle, SIGCONT);
|
||||
fpKill(FHandle, SIGCONT);
|
||||
FSuspended := False;
|
||||
end;
|
||||
|
||||
@ -283,15 +286,329 @@ var
|
||||
status : longint;
|
||||
begin
|
||||
if FThreadID = MainThreadID then
|
||||
fpwaitpid(0,@status,0)
|
||||
fpwaitpid(0,@status,0)
|
||||
else
|
||||
fpwaitpid(FHandle,@status,0);
|
||||
fpwaitpid(FHandle,@status,0);
|
||||
Result:=status;
|
||||
end;
|
||||
{$ELSE}
|
||||
|
||||
{
|
||||
What follows, is a short description on my implementation of TThread.
|
||||
Most information can also be found by reading the source and accompanying
|
||||
comments.
|
||||
|
||||
A thread is created using BeginThread, which in turn calls
|
||||
pthread_create. So the threads here are always posix threads.
|
||||
Posix doesn't define anything for suspending threads as this is
|
||||
inherintly unsafe. Just don't suspend threads at points they cannot
|
||||
control. Therefore, I didn't implement .Suspend() if its called from
|
||||
outside the threads execution flow (except on Linux _without_ NPTL).
|
||||
|
||||
The implementation for .suspend uses a semaphore, which is initialized
|
||||
at thread creation. If the thread tries to suspend itself, we simply
|
||||
let it wait on the semaphore until it is unblocked by someone else
|
||||
who calls .Resume.
|
||||
|
||||
If a thread is supposed to be suspended (from outside its own path of
|
||||
execution) on a system where the symbol LINUX is defined, two things
|
||||
are possible.
|
||||
1) the system has the LinuxThreads pthread implementation
|
||||
2) the system has NPTL as the pthread implementation.
|
||||
|
||||
In the first case, each thread is a process on its own, which as far as
|
||||
know actually violates posix with respect to signal handling.
|
||||
But we can detect this case, because getpid(2) will
|
||||
return a different PID for each thread. In that case, sending SIGSTOP
|
||||
to the PID associated with a thread will actually stop that thread
|
||||
only.
|
||||
In the second case, this is not possible. But getpid(2) returns the same
|
||||
PID across all threads, which is detected, and TThread.Suspend() does
|
||||
nothing in that case. This should probably be changed, but I know of
|
||||
no way to suspend a thread when using NPTL.
|
||||
|
||||
If the symbol LINUX is not defined, then the unimplemented
|
||||
function SuspendThread is called.
|
||||
|
||||
Johannes Berg <johannes@sipsolutions.de>, Sunday, November 16 2003
|
||||
}
|
||||
|
||||
// ========== semaphore stuff ==========
|
||||
{
|
||||
I don't like this. It eats up 2 filedescriptors for each thread,
|
||||
and those are a limited resource. If you have a server programm
|
||||
handling client connections (one per thread) it will not be able
|
||||
to handle many if we use 2 fds already for internal structures.
|
||||
However, right now I don't see a better option unless some sem_*
|
||||
functions are added to systhrds.
|
||||
I encapsulated all used functions here to make it easier to
|
||||
change them completely.
|
||||
}
|
||||
|
||||
function SemaphoreInit: Pointer;
|
||||
begin
|
||||
SemaphoreInit := GetMem(SizeOf(TFilDes));
|
||||
fppipe(PFilDes(SemaphoreInit)^);
|
||||
end;
|
||||
|
||||
procedure SemaphoreWait(const FSem: Pointer);
|
||||
var
|
||||
b: byte;
|
||||
begin
|
||||
fpread(PFilDes(FSem)^[0], b, 1);
|
||||
end;
|
||||
|
||||
procedure SemaphorePost(const FSem: Pointer);
|
||||
begin
|
||||
fpwrite(PFilDes(FSem)^[1], #0, 1);
|
||||
end;
|
||||
|
||||
procedure SemaphoreDestroy(const FSem: Pointer);
|
||||
begin
|
||||
fpclose(PFilDes(FSem)^[0]);
|
||||
fpclose(PFilDes(FSem)^[1]);
|
||||
FreeMemory(FSem);
|
||||
end;
|
||||
|
||||
// =========== semaphore end ===========
|
||||
|
||||
var
|
||||
ThreadsInited: boolean = false;
|
||||
{$IFDEF LINUX}
|
||||
GMainPID: LongInt = 0;
|
||||
{$ENDIF}
|
||||
const
|
||||
// stupid, considering its not even implemented...
|
||||
Priorities: array [TThreadPriority] of Integer =
|
||||
(-20,-19,-10,0,9,18,19);
|
||||
|
||||
procedure InitThreads;
|
||||
begin
|
||||
if not ThreadsInited then begin
|
||||
ThreadsInited := true;
|
||||
{$IFDEF LINUX}
|
||||
GMainPid := fpgetpid();
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DoneThreads;
|
||||
begin
|
||||
ThreadsInited := false;
|
||||
end;
|
||||
|
||||
{ ok, so this is a hack, but it works nicely. Just never use
|
||||
a multiline argument with WRITE_DEBUG! }
|
||||
{$MACRO ON}
|
||||
{$IFDEF DEBUG_MT}
|
||||
{$define WRITE_DEBUG := writeln} // actually write something
|
||||
{$ELSE}
|
||||
{$define WRITE_DEBUG := //} // just comment out those lines
|
||||
{$ENDIF}
|
||||
|
||||
function ThreadFunc(parameter: Pointer): LongInt; cdecl;
|
||||
var
|
||||
LThread: TThread;
|
||||
c: char;
|
||||
begin
|
||||
WRITE_DEBUG('ThreadFunc is here...');
|
||||
LThread := TThread(parameter);
|
||||
{$IFDEF LINUX}
|
||||
// save the PID of the "thread"
|
||||
// this is different from the PID of the main thread if
|
||||
// the LinuxThreads implementation is used
|
||||
LThread.FPid := fpgetpid();
|
||||
{$ENDIF}
|
||||
WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
|
||||
try
|
||||
if LThread.FInitialSuspended then begin
|
||||
SemaphoreWait(LThread.FSem);
|
||||
if not LThread.FInitialSuspended then begin
|
||||
WRITE_DEBUG('going into LThread.Execute');
|
||||
LThread.Execute;
|
||||
end;
|
||||
end else begin
|
||||
WRITE_DEBUG('going into LThread.Execute');
|
||||
LThread.Execute;
|
||||
end;
|
||||
except
|
||||
on e: exception do begin
|
||||
WRITE_DEBUG('got exception: ',e.message);
|
||||
LThread.FFatalException := TObject(AcquireExceptionObject);
|
||||
// not sure if we should really do this...
|
||||
// but .Destroy was called, so why not try FreeOnTerminate?
|
||||
if e is EThreadDestroyCalled then LThread.FFreeOnTerminate := true;
|
||||
end;
|
||||
end;
|
||||
WRITE_DEBUG('thread done running');
|
||||
Result := LThread.FReturnValue;
|
||||
WRITE_DEBUG('Result is ',Result);
|
||||
LThread.FFinished := True;
|
||||
LThread.DoTerminate;
|
||||
if LThread.FreeOnTerminate then begin
|
||||
WRITE_DEBUG('Thread should be freed');
|
||||
LThread.Free;
|
||||
WRITE_DEBUG('Thread freed');
|
||||
end;
|
||||
WRITE_DEBUG('thread func exiting');
|
||||
end;
|
||||
|
||||
{ TThread }
|
||||
constructor TThread.Create(CreateSuspended: Boolean);
|
||||
begin
|
||||
// lets just hope that the user doesn't create a thread
|
||||
// via BeginThread and creates the first TThread Object in there!
|
||||
InitThreads;
|
||||
inherited Create;
|
||||
FSem := SemaphoreInit;
|
||||
FSuspended := true;
|
||||
FSuspendedExternal := false;
|
||||
FInitialSuspended := CreateSuspended;
|
||||
FFatalException := nil;
|
||||
WRITE_DEBUG('creating thread, self = ',longint(self));
|
||||
FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID);
|
||||
WRITE_DEBUG('TThread.Create done');
|
||||
end;
|
||||
|
||||
|
||||
destructor TThread.Destroy;
|
||||
begin
|
||||
if FThreadID = GetCurrentThreadID then begin
|
||||
raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!');
|
||||
end;
|
||||
// if someone calls .Free on a thread with
|
||||
// FreeOnTerminate, then don't crash!
|
||||
FFreeOnTerminate := false;
|
||||
if not FFinished and not FSuspended then begin
|
||||
Terminate;
|
||||
WaitFor;
|
||||
end;
|
||||
if (FInitialSuspended) then begin
|
||||
// thread was created suspended but never woken up.
|
||||
SemaphorePost(FSem);
|
||||
WaitFor;
|
||||
end;
|
||||
FFatalException.Free;
|
||||
FFatalException := nil;
|
||||
SemaphoreDestroy(FSem);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TThread.SetSuspended(Value: Boolean);
|
||||
begin
|
||||
if Value <> FSuspended then
|
||||
if Value then
|
||||
Suspend
|
||||
else
|
||||
Resume;
|
||||
end;
|
||||
|
||||
procedure TThread.Suspend;
|
||||
begin
|
||||
if not FSuspended then begin
|
||||
if FThreadID = GetCurrentThreadID then begin
|
||||
FSuspended := true;
|
||||
SemaphoreWait(FSem);
|
||||
end else begin
|
||||
FSuspendedExternal := true;
|
||||
{$IFDEF LINUX}
|
||||
// naughty hack if the user doesn't have Linux with NPTL...
|
||||
// in that case, the PID of threads will not be identical
|
||||
// to the other threads, which means that our thread is a normal
|
||||
// process that we can suspend via SIGSTOP...
|
||||
// this violates POSIX, but is the way it works on the
|
||||
// LinuxThreads pthread implementation. Not with NPTL, but in that case
|
||||
// getpid(2) also behaves properly and returns the same PID for
|
||||
// all threads. Thats actually (FINALLY!) native thread support :-)
|
||||
if FPid <> GMainPID then begin
|
||||
FSuspended := true;
|
||||
fpkill(FPid, SIGSTOP);
|
||||
end;
|
||||
{$ELSE}
|
||||
SuspendThread(FHandle);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TThread.Resume;
|
||||
begin
|
||||
if (not FSuspendedExternal) then begin
|
||||
if FSuspended then begin
|
||||
SemaphorePost(FSem);
|
||||
FInitialSuspended := false;
|
||||
FSuspended := False;
|
||||
end;
|
||||
end else begin
|
||||
{$IFDEF LINUX}
|
||||
// see .Suspend
|
||||
if FPid <> GMainPID then begin
|
||||
fpkill(FPid, SIGCONT);
|
||||
FSuspended := False;
|
||||
end;
|
||||
{$ELSE}
|
||||
ResumeThread(FHandle);
|
||||
{$ENDIF}
|
||||
FSuspendedExternal := false;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TThread.Terminate;
|
||||
begin
|
||||
FTerminated := True;
|
||||
end;
|
||||
|
||||
function TThread.WaitFor: Integer;
|
||||
begin
|
||||
WRITE_DEBUG('waiting for thread ',FHandle);
|
||||
WaitFor := WaitForThreadTerminate(FHandle, 0);
|
||||
WRITE_DEBUG('thread terminated');
|
||||
end;
|
||||
|
||||
procedure TThread.CallOnTerminate;
|
||||
begin
|
||||
// no need to check if FOnTerminate <> nil, because
|
||||
// thats already done in DoTerminate
|
||||
FOnTerminate(self);
|
||||
end;
|
||||
|
||||
procedure TThread.DoTerminate;
|
||||
begin
|
||||
if Assigned(FOnTerminate) then
|
||||
Synchronize(@CallOnTerminate);
|
||||
end;
|
||||
|
||||
function TThread.GetPriority: TThreadPriority;
|
||||
var
|
||||
P: Integer;
|
||||
I: TThreadPriority;
|
||||
begin
|
||||
P := ThreadGetPriority(FHandle);
|
||||
Result := tpNormal;
|
||||
for I := Low(TThreadPriority) to High(TThreadPriority) do
|
||||
if Priorities[I] = P then
|
||||
Result := I;
|
||||
end;
|
||||
|
||||
procedure TThread.Synchronize(Method: TThreadMethod);
|
||||
begin
|
||||
{$TODO someone with more clue of the GUI stuff will have to do this}
|
||||
end;
|
||||
|
||||
procedure TThread.SetPriority(Value: TThreadPriority);
|
||||
begin
|
||||
ThreadSetPriority(FHandle, Priorities[Value]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2003-11-10 16:54:28 marco
|
||||
Revision 1.4 2003-11-17 08:27:49 marco
|
||||
* pthreads based ttread from Johannes Berg
|
||||
|
||||
Revision 1.3 2003/11/10 16:54:28 marco
|
||||
* new oldlinux unit. 1_0 defines killed in some former FCL parts.
|
||||
|
||||
Revision 1.2 2003/11/03 09:42:28 marco
|
||||
|
||||
@ -16,7 +16,6 @@
|
||||
**********************************************************************}
|
||||
unit systhrds;
|
||||
interface
|
||||
|
||||
{$S-}
|
||||
|
||||
{$ifndef BSD}
|
||||
@ -197,7 +196,20 @@ CONST
|
||||
function ThreadMain(param : pointer) : pointer;cdecl;
|
||||
var
|
||||
ti : tthreadinfo;
|
||||
{$ifdef DEBUG_MT}
|
||||
// in here, don't use write/writeln before having called
|
||||
// InitThread! I wonder if anyone ever debugged these routines,
|
||||
// because they will have crashed if DEBUG_MT was enabled!
|
||||
// this took me the good part of an hour to figure out
|
||||
// why it was crashing all the time!
|
||||
// this is kind of a workaround, we simply write(2) to fd 0
|
||||
s: string[100]; // not an ansistring
|
||||
{$endif DEBUG_MT}
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
s := 'New thread started, initing threadvars'#10;
|
||||
fpwrite(0,s[1],length(s));
|
||||
{$endif DEBUG_MT}
|
||||
{$ifdef HASTHREADVAR}
|
||||
{ Allocate local thread vars, this must be the first thing,
|
||||
because the exception management and io depends on threadvars }
|
||||
@ -205,7 +217,8 @@ CONST
|
||||
{$endif HASTHREADVAR}
|
||||
{ Copy parameter to local data }
|
||||
{$ifdef DEBUG_MT}
|
||||
writeln('New thread started, initialising ...');
|
||||
s := 'New thread started, initialising ...'#10;
|
||||
fpwrite(0,s[1],length(s));
|
||||
{$endif DEBUG_MT}
|
||||
ti:=pthreadinfo(param)^;
|
||||
dispose(pthreadinfo(param));
|
||||
@ -216,6 +229,8 @@ CONST
|
||||
writeln('Jumping to thread function');
|
||||
{$endif DEBUG_MT}
|
||||
ThreadMain:=pointer(ti.f(ti.p));
|
||||
DoneThread;
|
||||
pthread_detach(pthread_self);
|
||||
end;
|
||||
|
||||
|
||||
@ -251,16 +266,27 @@ CONST
|
||||
{$endif DEBUG_MT}
|
||||
pthread_attr_init(@thread_attr);
|
||||
pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED);
|
||||
|
||||
// will fail under linux -- apparently unimplemented
|
||||
pthread_attr_setscope(@thread_attr, PTHREAD_SCOPE_PROCESS);
|
||||
pthread_attr_setdetachstate(@thread_attr, PTHREAD_CREATE_DETACHED);
|
||||
pthread_create(@threadid, @thread_attr, @ThreadMain,ti);
|
||||
|
||||
// don't create detached, we need to be able to join (waitfor) on
|
||||
// the newly created thread!
|
||||
//pthread_attr_setdetachstate(@thread_attr, PTHREAD_CREATE_DETACHED);
|
||||
if pthread_create(@threadid, @thread_attr, @ThreadMain,ti) <> 0 then begin
|
||||
threadid := 0;
|
||||
end;
|
||||
BeginThread:=threadid;
|
||||
{$ifdef DEBUG_MT}
|
||||
writeln('BeginThread returning ',BeginThread);
|
||||
{$endif DEBUG_MT}
|
||||
end;
|
||||
|
||||
|
||||
procedure EndThread(ExitCode : DWord);
|
||||
begin
|
||||
DoneThread;
|
||||
pthread_detach(pthread_self);
|
||||
pthread_exit(pointer(ExitCode));
|
||||
end;
|
||||
|
||||
@ -283,12 +309,19 @@ CONST
|
||||
|
||||
function KillThread (threadHandle : dword) : dword;
|
||||
begin
|
||||
{$Warning KillThread needs to be implemented}
|
||||
pthread_detach(pointer(threadHandle));
|
||||
KillThread := pthread_cancel(Pointer(threadHandle));
|
||||
end;
|
||||
|
||||
function WaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword; {0=no timeout}
|
||||
var
|
||||
LResultP: Pointer;
|
||||
LResult: DWord;
|
||||
begin
|
||||
{$Warning WaitForThreadTerminate needs to be implemented}
|
||||
LResult := 0;
|
||||
LResultP := @LResult;
|
||||
pthread_join(Pointer(threadHandle), @LResultP);
|
||||
WaitForThreadTerminate := LResult;
|
||||
end;
|
||||
|
||||
function ThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
|
||||
@ -385,7 +418,10 @@ initialization
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.15 2003-10-01 21:00:09 peter
|
||||
Revision 1.16 2003-11-17 08:27:50 marco
|
||||
* pthreads based ttread from Johannes Berg
|
||||
|
||||
Revision 1.15 2003/10/01 21:00:09 peter
|
||||
* GetCurrentThreadHandle renamed to GetCurrentThreadId
|
||||
|
||||
Revision 1.14 2003/10/01 20:53:08 peter
|
||||
|
||||
Loading…
Reference in New Issue
Block a user