Hi, Attached is a new version, this time with the diff of classesh.inc
This one contains the following new features: * calling suspend from within threads is possible and properly supported * exceptions now work (I accidentally forgot AcquireExceptionObject) * a thread trying to free itself yields an exception (if it propagates up completely the FreeOnTerminate flag is set and the thread destroyed none-the-less) * factored out code for synchronization because I want to use semaphores as they don't fill up the file descriptor table, not used yet because they are not available in classes.pp (yet?), so still uses a pipe * moved FThreadID to protected visibility in case someone needs to use the base pthread_* functions on the thread - the pipe thing is most likely not signal safe (recv can be interrupted). I'm pretty sure actually, but need to test that and add loops as appropriate. - still no synchronization support. I don't think this is too hard, but need information on how the foreground thread should be notified. A pipe would work well, the foreground thread could select() it and see if any thread wants it to do work for it (I expect that the GUI app main loop already selects anyway) Have fun! :) I consider this pretty good to use, but the signal issue blocks it. johannes -- http://www.sipsolutions.de/ GnuPG key: http://www.sipsolutions.de/keys/JohannesBerg.asc Key-ID: 9AB78CA5 Johannes Berg <[EMAIL PROTECTED]> Fingerprint = AD02 0176 4E29 C137 1DF6 08D2 FC44 CF86 9AB7 8CA5
Index: linux/tthread.inc
===================================================================
RCS file: /FPC/CVS/fpc/rtl/linux/tthread.inc,v
retrieving revision 1.3
diff -u -r1.3 tthread.inc
--- linux/tthread.inc 10 Nov 2003 16:54:28 -0000 1.3
+++ linux/tthread.inc 17 Nov 2003 00:38:41 -0000
@@ -14,6 +14,8 @@
**********************************************************************}
+
+{$IFDEF VER1_0} // leaving the old implementation in for now...
type
PThreadRec=^TThreadRec;
TThreadRec=record
@@ -74,7 +76,7 @@
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 @@
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 @@
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 @@
WaitFor;
end;
if FHandle <> -1 then
- fpkill(FHandle, SIGKILL);
+ fpkill(FHandle, SIGKILL);
dec(FStackPointer,FStackSize);
Freemem(FStackPointer);
FFatalException.Free;
@@ -224,8 +228,7 @@
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 @@
procedure TThread.SetPriority(Value: TThreadPriority);
begin
- Unix.fpSetPriority(Prio_Process,FHandle,Priorities[Value]);
+ fpSetPriority(Prio_Process,FHandle,Priorities[Value]);
end;
@@ -261,14 +264,14 @@
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,11 +286,322 @@
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 <[EMAIL PROTECTED]>, 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: tthread.inc,v $
Index: ./objpas/classes/classesh.inc
===================================================================
RCS file: /FPC/CVS/fpc/rtl/objpas/classes/classesh.inc,v
retrieving revision 1.6
diff -u -r1.6 classesh.inc
--- ./objpas/classes/classesh.inc 3 Nov 2003 09:42:28 -0000 1.6
+++ ./objpas/classes/classesh.inc 17 Nov 2003 00:38:42 -0000
@@ -1093,6 +1093,7 @@
{ TThread }
EThread = class(Exception);
+ EThreadDestroyCalled = class(EThread);
TThreadMethod = procedure of object;
TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
@@ -1101,7 +1102,6 @@
TThread = class
private
FHandle: THandle;
- FThreadID: THandle;
FTerminated: Boolean;
FSuspended: Boolean;
FFreeOnTerminate: Boolean;
@@ -1116,6 +1116,7 @@
procedure SetPriority(Value: TThreadPriority);
procedure SetSuspended(Value: Boolean);
protected
+ FThreadID: THandle; // someone might need it for pthread_* calls
procedure DoTerminate; virtual;
procedure Execute; virtual; abstract;
procedure Synchronize(Method: TThreadMethod);
@@ -1123,11 +1124,23 @@
property Terminated: Boolean read FTerminated;
public
{$ifdef Unix}
+{$IFDEF VER1_0}
{ Needed for linux }
FStackPointer : Pointer;
FStackSize : integer;
FCallExitProcess : boolean;
+{$ELSE}
+private
+ // see tthread.inc, ThreadFunc and TThread.Resume
+ FSem: Pointer;
+ FInitialSuspended: boolean;
+ FSuspendedExternal: boolean;
+{$IFDEF LINUX}
+ FPid: LongInt;
+{$ENDIF}
+{$ENDIF}
{$endif}
+public
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
procedure Resume;
Index: unix/systhrds.pp
===================================================================
RCS file: /FPC/CVS/fpc/rtl/unix/systhrds.pp,v
retrieving revision 1.15
diff -u -r1.15 systhrds.pp
--- unix/systhrds.pp 1 Oct 2003 21:00:09 -0000 1.15
+++ unix/systhrds.pp 17 Nov 2003 00:38:42 -0000
@@ -16,7 +16,6 @@
**********************************************************************}
unit systhrds;
interface
-
{$S-}
{$ifndef BSD}
@@ -197,7 +196,20 @@
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 @@
{$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 @@
writeln('Jumping to thread function');
{$endif DEBUG_MT}
ThreadMain:=pointer(ti.f(ti.p));
+ DoneThread;
+ pthread_detach(pthread_self);
end;
@@ -251,16 +266,27 @@
{$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 @@
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}
signature.asc
Description: This is a digitally signed message part
