Hi, Probably not complete, but an overview of what I have in mind -- read the notes in the file.
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: rtl/linux/tthread.inc
===================================================================
RCS file: /FPC/CVS/fpc/rtl/linux/tthread.inc,v
retrieving revision 1.3
diff -u -r1.3 tthread.inc
--- rtl/linux/tthread.inc 10 Nov 2003 16:54:28 -0000 1.3
+++ rtl/linux/tthread.inc 14 Nov 2003 12:49:46 -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,334 @@
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. CreateSuspended though is very important, and there's no need
+ to implement it using .Suspend(), because we know that in advance.
+ So the implementation here uses a pipe. On thread creation (if
+ CreateSuspended is true), a pipe is created, and the thread immediately
+ tries to read a single char from the pipe. After reading that char,
+ it closes both ends of the pipe. If the character is 'x' (lower case),
+ then it immediately returns without calling the TThread.Execute
+ function that was overridden.
+ Now, .Resume knows about this as well. If the pipe is open (ie,
+ the writing end has a number <> -1), it writes a single character
+ to the pipe ('r', lower case). This will be readable in the Thread,
+ which will awake and start processing.
+ If on the other hand, a thread is created suspended and never gets
+ resumed by a call to .Resume, freeing it will cause the destructor
+ to send a 'x' down the pipe and then wait for the thread, which
+ will never execute any code in TThread.Execute, but will free that
+ thread from the system.
+
+ If a thread is supposed to be suspended on a system where the symbol
+ LINUX is defined, then 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 actually
+ violates posix. 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]>, Friday, November 14 2003
+ ----------------
+
+ My opinion on the suspend matter is as follows:
+ TThread.Suspend should be marked "deprecated".
+ TThread.Resume is not affected because it can be used to wake a thread
+ that was created suspended, which is possible on all systems (see above).
+
+ Additionally, I would love to see the following possibility:
+ Create a conditional initialization section, which is only linked
+ in if .Suspend() is linked in. Otherwise, leave it out.
+ That conditional initialization would detect if it is running
+ on a NPTL system or not (possibly by creating a thread, see above).
+ If yes, it would halt the program and print the following warning:
+ =====
+ WARNING: This program uses TThread.Suspend() which is not portable.
+ In particular, it will not work on your system.
+ You may try to run the program after exporting the environment
+ variable LD_ASSUME_KERNEL=2.4.0 (for example (on systems using bash) by
+ entering "LD_ASSUME_KERNEL=2.4.0 <paramstr(0)>). However, this does not
+ guarantee correct execution of the program. It is recommended that
+ * if you are the author: rewrite the program to not use TThread.Suspend
+ * otherwise contact the author and present him with the discussion
+ of the problem available at
+ http://www.freepascal.org/tthread_suspend_issue.html
+ =====
+ But obviously that must be conditional and only compiled in if
+ TThread.Suspend is linked. I don't know if this is possible at all,
+ probably not without some major compiler magic.
+
+ Also, on systems other than Linux and Windows, don't even define
+ TThread.Suspend unless there is some way to implement it and it is
+ actually implemented. If someone tries to compile code using it they
+ should notice that it will never work, and possible stumble upon
+ above URL too ;-)
+ I'd be willing to write a nice article (containing this information and
+ more stuff from posix) that would be suitable for being at the URL.
+}
+
+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.FCreateSuspDescriptorOut <> -1 then begin
+ WRITE_DEBUG('thread created suspended, trying to read character');
+ fpread(LThread.FCreateSuspDescriptorOut, c, 1);
+ fpclose(LThread.FCreateSuspDescriptorOut);
+ LThread.FCreateSuspDescriptorOut := -1;
+ fpclose(LThread.FCreateSuspDescriptorIn);
+ LThread.FCreateSuspDescriptorIn := -1;
+ WRITE_DEBUG('read character ',c);
+ if c <> 'x' 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 := e;
+ 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);
+var
+ LDes: tfildes;
+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;
+ FSuspended := CreateSuspended;
+ FFatalException := nil;
+ WRITE_DEBUG('creating thread, self = ',longint(self));
+ FCreateSuspDescriptorIn := -1;
+ FCreateSuspDescriptorOut := -1;
+ if CreateSuspended then begin
+ // if it is created suspended, then we create a pipe, which
+ // ThreadFunc tries to read a single character from.
+ // TThread.Resume checks if the descriptor is <> -1 and
+ // in that case writes a single character to it, thus
+ // unblocking the waiting TThreadFunc
+ if fppipe(LDes) <> 0 then begin
+ raise EThread.Create('Cannot create filedescriptors');
+ end else begin
+ FCreateSuspDescriptorIn := LDes[1];
+ FCreateSuspDescriptorOut:= LDes[0];
+ end;
+ end;
+ FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID);
+ WRITE_DEBUG('TThread.Create done');
+end;
+
+
+destructor TThread.Destroy;
+begin
+ if not FFinished and not FSuspended then begin
+ // if someone calls .Free on a thread with
+ // FreeOnTerminate, then don't crash!
+ FFreeOnTerminate := false;
+ Terminate;
+ WaitFor;
+ end;
+ if (FCreateSuspDescriptorIn<>-1) then begin
+ // thread was created suspended but never woken up.
+ // we send it a 'x' letter so that it will terminate properly!
+ fpwrite(FCreateSuspDescriptorIn, 'x', 1);
+ // now wait for the thread to terminate
+ // TThread.Execute never runs in this case, so we're pretty much safe
+ // that it'll work properly
+ FFreeOnTerminate := false;
+ WaitFor;
+ end;
+ FFatalException.Free;
+ FFatalException := nil;
+ inherited Destroy;
+end;
+
+procedure TThread.SetSuspended(Value: Boolean);
+begin
+ if Value <> FSuspended then
+ if Value then
+ Suspend
+ else
+ Resume;
+end;
+
+procedure TThread.Suspend;
+begin
+{$IFDEF LINUX}
+ // naughty hack if the user doesn't have Linux 2.6 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;
+
+
+procedure TThread.Resume;
+begin
+ if FCreateSuspDescriptorIn <> -1 then begin
+ // send anything but 'x'
+ fpwrite(FCreateSuspDescriptorIn, 'r', 1);
+ FSuspended := False;
+ end else begin
+{$IFDEF LINUX}
+ // see .Suspend
+ if FPid <> GMainPID then begin
+ fpkill(FPid, SIGCONT);
+ FSuspended := False;
+ end;
+{$ELSE}
+ ResumeThread(FHandle);
+{$ENDIF}
+ 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: rtl/unix/systhrds.pp
===================================================================
RCS file: /FPC/CVS/fpc/rtl/unix/systhrds.pp,v
retrieving revision 1.15
diff -u -r1.15 systhrds.pp
--- rtl/unix/systhrds.pp 1 Oct 2003 21:00:09 -0000 1.15
+++ rtl/unix/systhrds.pp 14 Nov 2003 12:49:46 -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
