* pthreads based ttread from Johannes Berg

rtl/linux/tthread.inc

@@ -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 <[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$
-  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

rtl/unix/systhrds.pp

@@ -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