+ implementation of cSemaphore* and BasicRTLEvent based on

    sem_open/sem_close for Darwin (doesn't have sem_init/sem_destroy)
  + implementation of cSemaphore* based on pipes (for potential future
    systems that don't have either sem* routines)
  + test for basicrtlevent
  * fixed datarace whereby a TThread could be started, run and exit before
    TThread.AfterConstructor had been called (Mantis 6693, all platforms)
  * throw EThread exceptions in TThread.create if something during creating
    the tthread goes wrong (*nix)
  * don't crash in TThread.Destroy if the TThread throws an exception before
    it was fully initialised (*nix)
  * changed order of operations in TThread.Destroy so it doesn't perform
    invalid thread operations in some edge cases (*nix)
  * fixed usage of sem_wait/sem_trywait (can be interrupted) in Semaphore
    and RTLEvent implementations
  * fixed erroneous waiting for threads after they had already exited via
    pthread_detach/pthread_exit
  * fixed several memory leaks in case of thread intialisation errors
    (*nix)
  * unified tthread.inc for all Unices

git-svn-id: trunk@5662 -

.gitattributes

@@ -4425,7 +4425,6 @@ rtl/darwin/sysctlh.inc svneol=native#text/plain
 rtl/darwin/termio.pp svneol=native#text/plain
 rtl/darwin/termios.inc svneol=native#text/plain
 rtl/darwin/termiosproc.inc svneol=native#text/plain
-rtl/darwin/tthread.inc svneol=native#text/plain
 rtl/darwin/unxconst.inc svneol=native#text/plain
 rtl/darwin/unxfunc.inc svneol=native#text/plain
 rtl/darwin/unxsockh.inc svneol=native#text/plain
@@ -4485,7 +4484,6 @@ rtl/freebsd/sysnr.inc svneol=native#text/plain
 rtl/freebsd/termio.pp svneol=native#text/plain
 rtl/freebsd/termios.inc svneol=native#text/plain
 rtl/freebsd/termiosproc.inc svneol=native#text/plain
-rtl/freebsd/tthread.inc svneol=native#text/plain
 rtl/freebsd/ucontexth.inc -text svneol=unset#text/plain
 rtl/freebsd/unixsock.inc svneol=native#text/plain
 rtl/freebsd/unxconst.inc svneol=native#text/plain
@@ -4761,7 +4759,6 @@ rtl/linux/system.pp svneol=native#text/plain
 rtl/linux/termio.pp svneol=native#text/plain
 rtl/linux/termios.inc svneol=native#text/plain
 rtl/linux/termiosproc.inc svneol=native#text/plain
-rtl/linux/tthread.inc svneol=native#text/plain
 rtl/linux/unixsock.inc svneol=native#text/plain
 rtl/linux/unxconst.inc svneol=native#text/plain
 rtl/linux/unxfunc.inc svneol=native#text/plain
@@ -4897,7 +4894,6 @@ rtl/netbsd/systypes.inc svneol=native#text/plain
 rtl/netbsd/termio.pp svneol=native#text/plain
 rtl/netbsd/termios.inc svneol=native#text/plain
 rtl/netbsd/termiosproc.inc svneol=native#text/plain
-rtl/netbsd/tthread.inc svneol=native#text/plain
 rtl/netbsd/unixsock.inc svneol=native#text/plain
 rtl/netbsd/unxconst.inc svneol=native#text/plain
 rtl/netbsd/unxfunc.inc svneol=native#text/plain
@@ -5105,7 +5101,6 @@ rtl/openbsd/systypes.inc svneol=native#text/plain
 rtl/openbsd/termio.pp svneol=native#text/plain
 rtl/openbsd/termios.inc svneol=native#text/plain
 rtl/openbsd/termiosproc.inc svneol=native#text/plain
-rtl/openbsd/tthread.inc svneol=native#text/plain
 rtl/openbsd/unixsock.inc svneol=native#text/plain
 rtl/openbsd/unixsysc.inc svneol=native#text/plain
 rtl/openbsd/unxsockh.inc svneol=native#text/plain
@@ -5240,7 +5235,6 @@ rtl/solaris/system.pp svneol=native#text/plain
 rtl/solaris/termio.pp svneol=native#text/plain
 rtl/solaris/termios.inc svneol=native#text/plain
 rtl/solaris/termiosproc.inc svneol=native#text/plain
-rtl/solaris/tthread.inc svneol=native#text/plain
 rtl/solaris/unxconst.inc svneol=native#text/plain
 rtl/solaris/unxfunc.inc svneol=native#text/plain
 rtl/solaris/unxsockh.inc svneol=native#text/plain
@@ -5337,6 +5331,7 @@ rtl/unix/sysutils.pp svneol=native#text/plain
 rtl/unix/terminfo.pp svneol=native#text/plain
 rtl/unix/termiosh.inc svneol=native#text/plain
 rtl/unix/timezone.inc svneol=native#text/plain
+rtl/unix/tthread.inc svneol=native#text/plain
 rtl/unix/ttyname.inc svneol=native#text/plain
 rtl/unix/unix.pp svneol=native#text/plain
 rtl/unix/unixtype.pp svneol=native#text/plain
@@ -6501,6 +6496,7 @@ tests/test/tarray5.pp svneol=native#text/plain
 tests/test/tarray6.pp svneol=native#text/plain
 tests/test/tasmread.pp svneol=native#text/plain
 tests/test/tasout.pp svneol=native#text/plain
+tests/test/tbrtlevt.pp svneol=native#text/plain
 tests/test/tcase1.pp svneol=native#text/plain
 tests/test/tcase2.pp svneol=native#text/plain
 tests/test/tcg1.pp svneol=native#text/plain

rtl/darwin/pthread.inc

@@ -22,6 +22,7 @@
 CONST PTHREAD_EXPLICIT_SCHED       = 0;
       PTHREAD_CREATE_DETACHED      = 1;
       PTHREAD_SCOPE_PROCESS        = 0;
+      SEM_FAILED                   = -1;
 
  TYPE
     ppthread_t           = ^pthread_t;
@@ -63,7 +64,9 @@ function  pthread_cond_wait(_para1:Ppthread_cond_t;_para2:Ppthread_mutex_t):cint
 function pthread_kill(__thread:pthread_t; __signo:cint):cint;cdecl;external 'c';
 
 
-function sem_init(__sem:Psem_t; __pshared:cint;__value:cuint):cint;cdecl; external 'c' name 'sem_init';
+// not yet implemented in Mac OS X 10.4.8!
+// function sem_init(__sem:Psem_t; __pshared:cint;__value:cuint):cint;cdecl; external 'c' name 'sem_init';
+function sem_open(name: pchar; oflag: cint): Psem_t; cdecl; varargs; external 'c' name 'sem_open';
 function sem_destroy(__sem:Psem_t):cint;cdecl;external 'c' name 'sem_destroy';
 function sem_close(__sem:Psem_t):cint;cdecl;external 'c'  name 'sem_close';
 function sem_unlink(__name:Pchar):cint;cdecl;external 'c' name 'sem_unlink';
@@ -76,5 +79,4 @@ function pthread_mutexattr_init(_para1:Ppthread_mutexattr_t):cint;cdecl;external
 function pthread_mutexattr_destroy(_para1:Ppthread_mutexattr_t):cint;cdecl;external 'c' name 'pthread_mutexattr_destroy';
 function pthread_mutexattr_gettype(_para1:Ppthread_mutexattr_t; _para2:Pcint):cint;cdecl;external 'c' name 'pthread_mutexattr_gettype';
 function pthread_mutexattr_settype(_para1:Ppthread_mutexattr_t; _para2:cint):cint;cdecl;external 'c' name 'pthread_mutexattr_settype';
-function pthread_cond_timedwait(__cond:ppthread_cond_t; __mutex:ppthread_mutex_t; __abstime:ptimespec):cint; cdecl;external 'c' name 'pthread_cond_timedwait'; 
-
+function pthread_cond_timedwait(__cond:ppthread_cond_t; __mutex:ppthread_mutex_t; __abstime:ptimespec):cint; cdecl;external 'c' name 'pthread_cond_timedwait';

rtl/freebsd/tthread.inc

@@ -1,252 +0,0 @@
-{
-   This file is part of the Free Pascal run time library.
-   (c) 2000-2003 by Marco van de Voort
-   member of the Free Pascal development team.
-
-   See the file COPYING.FPC, included in this distribution,
-   for details about the copyright.
-
-   TThread implementation old (1.0) and new (pthreads) style
-
-   This program is distributed in the hope that it will be useful,
-   but WITHOUT ANY WARRANTY;without even the implied warranty of
-   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-}
-
-
-{
-  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
-}
-
-{ 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}
-
-var
-  ThreadsInited: boolean = false;
-  CurrentTM: TThreadManager;
-  
-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
-    GetThreadManager(CurrentTM);
-    ThreadsInited := true;
-  end;
-end;
-
-procedure DoneThreads;
-begin
-  ThreadsInited := false;
-end;
-
-function ThreadFunc(parameter: Pointer): LongInt;
-var
-  LThread: TThread;
-  c: char;
-begin
-  WRITE_DEBUG('ThreadFunc is here...');
-  LThread := TThread(parameter);
-  WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
-  try
-    if LThread.FInitialSuspended then begin
-      CurrentTM.SemaphoreWait(LThread.FSem);
-      if not LThread.FSuspended then begin
-        LThread.FInitialSuspended := false;
-        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 calling EndThread');
-  EndThread(Result);
-end;
-
-{ TThread }
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
-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 := CurrentTM.SemaphoreInit();
-  FSuspended := CreateSuspended;
-  FSuspendedExternal := false;
-  FInitialSuspended := CreateSuspended;
-  FFatalException := nil;
-  WRITE_DEBUG('creating thread, self = ',PtrInt(self));
-  FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID,StackSize);
-  WRITE_DEBUG('TThread.Create done');
-end;
-
-
-destructor TThread.Destroy;
-begin
-  if (FThreadID = GetCurrentThreadID) and not(FFreeOnTerminate) and not ffinished 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.
-    CurrentTM.SemaphorePost(FSem);
-    WaitFor;
-  end;
-  FFatalException.Free;
-  FFatalException := nil;
-  CurrentTM.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;
-      CurrentTM.SemaphoreWait(FSem);
-    end else begin
-      FSuspendedExternal := true;
-      SuspendThread(FHandle);
-    end;
-  end;
-end;
-
-
-procedure TThread.Resume;
-begin
-  if (not FSuspendedExternal) then begin
-    if FSuspended then begin
-      FSuspended := False;
-      CurrentTM.SemaphorePost(FSem);
-    end;
-  end else begin
-    FSuspendedExternal := false;
-    ResumeThread(FHandle);
-  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.SetPriority(Value: TThreadPriority);
-begin
-  ThreadSetPriority(FHandle, Priorities[Value]);
-end;
-

rtl/inc/thread.inc

@@ -79,7 +79,7 @@ begin
   Result:=CurrentTM.BeginThread(sa,stacksize,threadfunction,P,creationflags,ThreadID);
 end;
 
-procedure EndThread(ExitCode : DWord);
+procedure FlushThread;
 
 begin
 {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
@@ -89,6 +89,12 @@ begin
   Flush(StdOut);
   Flush(StdErr);
 {$endif FPC_HAS_FEATURE_CONSOLEIO}
+end;
+
+procedure EndThread(ExitCode : DWord);
+
+begin
+  FlushThread;
   CurrentTM.EndThread(ExitCode);
 end;
 

rtl/inc/threadh.inc

@@ -129,6 +129,7 @@ procedure EndThread(ExitCode : DWord);
 procedure EndThread;
 
 {some thread support functions}
+procedure FlushThread;
 function  SuspendThread (threadHandle : TThreadID) : dword;
 function  ResumeThread  (threadHandle : TThreadID) : dword;
 procedure ThreadSwitch;                                                                {give time to other threads}

rtl/linux/tthread.inc

@@ -1,258 +0,0 @@
-{
-   This file is part of the Free Pascal run time library.
-   (c) 2000-2003 by Marco van de Voort
-   member of the Free Pascal development team.
-
-   See the file COPYING.FPC, included in this distribution,
-   for details about the copyright.
-
-   TThread implementation old (1.0) and new (pthreads) style
-
-   This program is distributed in the hope that it will be useful,
-   but WITHOUT ANY WARRANTY;without even the implied warranty of
-   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-}
-
-
-{
-  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
-}
-
-{ 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}
-
-var
-  ThreadsInited: boolean = false;
-  CurrentTM: TThreadManager;
-  GMainPID: LongInt = 0;
-  
-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
-    GetThreadManager(CurrentTM);
-    ThreadsInited := true;
-    GMainPid := fpgetpid();
-  end;
-end;
-
-procedure DoneThreads;
-begin
-  ThreadsInited := false;
-end;
-
-function ThreadFunc(parameter: Pointer): PtrInt;
-var
-  LThread: TThread;
-  c: char;
-begin
-  WRITE_DEBUG('ThreadFunc is here...');
-  LThread := TThread(parameter);
-  WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
-  // 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();
-  try
-    if LThread.FInitialSuspended then begin
-      CurrentTM.SemaphoreWait(LThread.FSem);
-      if not LThread.FSuspended then begin
-        LThread.FInitialSuspended := false;
-        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 calling EndThread');
-  EndThread(Result);
-end;
-
-{ TThread }
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
-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 := CurrentTM.SemaphoreInit();
-  FSuspended := CreateSuspended;
-  FSuspendedExternal := false;
-  FInitialSuspended := CreateSuspended;
-  FFatalException := nil;
-  WRITE_DEBUG('creating thread, self = ',PtrInt(self));
-  FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID,StackSize);
-  WRITE_DEBUG('TThread.Create done');
-end;
-
-
-destructor TThread.Destroy;
-begin
-  if (FThreadID = GetCurrentThreadID) and not(FFreeOnTerminate) and not ffinished 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.
-    CurrentTM.SemaphorePost(FSem);
-    WaitFor;
-  end;
-  FFatalException.Free;
-  FFatalException := nil;
-  CurrentTM.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;
-      CurrentTM.SemaphoreWait(FSem);
-    end else begin
-      FSuspendedExternal := true;
-      SuspendThread(FHandle);
-    end;
-  end;
-end;
-
-
-procedure TThread.Resume;
-begin
-  if (not FSuspendedExternal) then begin
-    if FSuspended then begin
-      FSuspended := False;
-      CurrentTM.SemaphorePost(FSem);
-    end;
-  end else begin
-    FSuspendedExternal := false;
-    ResumeThread(FHandle);
-  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.SetPriority(Value: TThreadPriority);
-begin
-  ThreadSetPriority(FHandle, Priorities[Value]);
-end;
-

rtl/netbsd/tthread.inc

@@ -1,252 +0,0 @@
-{
-   This file is part of the Free Pascal run time library.
-   (c) 2000-2003 by Marco van de Voort
-   member of the Free Pascal development team.
-
-   See the file COPYING.FPC, included in this distribution,
-   for details about the copyright.
-
-   TThread implementation old (1.0) and new (pthreads) style
-
-   This program is distributed in the hope that it will be useful,
-   but WITHOUT ANY WARRANTY;without even the implied warranty of
-   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-}
-
-
-{
-  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
-}
-
-{ 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}
-
-var
-  ThreadsInited: boolean = false;
-  CurrentTM: TThreadManager;
-  
-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
-    GetThreadManager(CurrentTM);
-    ThreadsInited := true;
-  end;
-end;
-
-procedure DoneThreads;
-begin
-  ThreadsInited := false;
-end;
-
-function ThreadFunc(parameter: Pointer): LongInt;
-var
-  LThread: TThread;
-  c: char;
-begin
-  WRITE_DEBUG('ThreadFunc is here...');
-  LThread := TThread(parameter);
-  WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
-  try
-    if LThread.FInitialSuspended then begin
-      CurrentTM.SemaphoreWait(LThread.FSem);
-      if not LThread.FSuspended then begin
-        LThread.FInitialSuspended := false;
-        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 calling EndThread');
-  EndThread(Result);
-end;
-
-{ TThread }
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
-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 := CurrentTM.SemaphoreInit();
-  FSuspended := CreateSuspended;
-  FSuspendedExternal := false;
-  FInitialSuspended := CreateSuspended;
-  FFatalException := nil;
-  WRITE_DEBUG('creating thread, self = ',PtrInt(self));
-  FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID,StackSize);
-  WRITE_DEBUG('TThread.Create done');
-end;
-
-
-destructor TThread.Destroy;
-begin
-  if (FThreadID = GetCurrentThreadID) and not(FFreeOnTerminate) and not ffinished 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.
-    CurrentTM.SemaphorePost(FSem);
-    WaitFor;
-  end;
-  FFatalException.Free;
-  FFatalException := nil;
-  CurrentTM.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;
-      CurrentTM.SemaphoreWait(FSem);
-    end else begin
-      FSuspendedExternal := true;
-      SuspendThread(FHandle);
-    end;
-  end;
-end;
-
-
-procedure TThread.Resume;
-begin
-  if (not FSuspendedExternal) then begin
-    if FSuspended then begin
-      FSuspended := False;
-      CurrentTM.SemaphorePost(FSem);
-    end;
-  end else begin
-    FSuspendedExternal := false;
-    ResumeThread(FHandle);
-  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.SetPriority(Value: TThreadPriority);
-begin
-  ThreadSetPriority(FHandle, Priorities[Value]);
-end;
-

rtl/netwlibc/tthread.inc

@@ -218,8 +218,13 @@ begin
   {$ENDIF}
   WRITE_DEBUG('thread initing, parameter = %d'#13#10, LongInt(LThread));
   try
+    // wait until AfterConstruction has been called, so we cannot
+    // free ourselves before TThread.Create has finished
+    // (since that one may check our VTM in case of $R+, and
+    //  will call the AfterConstruction method in all cases)
+    LThread.Suspend;
     if LThread.FInitialSuspended then begin
-      SemaphoreWait(LThread.FSem);
+       LThread.Suspend;
       if not LThread.FInitialSuspended then begin
         WRITE_DEBUG('going into LThread.Execute'#13#10);
         LThread.Execute;
@@ -261,7 +266,7 @@ begin
   AddThread(self);
   inherited Create;
   FSem := SemaphoreInit;
-  FSuspended :=CreateSuspended;
+  FSuspended := False;
   FSuspendedExternal := false;
   FInitialSuspended := CreateSuspended;
   FFatalException := nil;

rtl/openbsd/tthread.inc

@@ -1,252 +0,0 @@
-{
-   This file is part of the Free Pascal run time library.
-   (c) 2000-2003 by Marco van de Voort
-   member of the Free Pascal development team.
-
-   See the file COPYING.FPC, included in this distribution,
-   for details about the copyright.
-
-   TThread implementation old (1.0) and new (pthreads) style
-
-   This program is distributed in the hope that it will be useful,
-   but WITHOUT ANY WARRANTY;without even the implied warranty of
-   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-}
-
-
-{
-  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
-}
-
-{ 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}
-
-var
-  ThreadsInited: boolean = false;
-  CurrentTM: TThreadManager;
-  
-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
-    GetThreadManager(CurrentTM);
-    ThreadsInited := true;
-  end;
-end;
-
-procedure DoneThreads;
-begin
-  ThreadsInited := false;
-end;
-
-function ThreadFunc(parameter: Pointer): LongInt;
-var
-  LThread: TThread;
-  c: char;
-begin
-  WRITE_DEBUG('ThreadFunc is here...');
-  LThread := TThread(parameter);
-  WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
-  try
-    if LThread.FInitialSuspended then begin
-      CurrentTM.SemaphoreWait(LThread.FSem);
-      if not LThread.FSuspended then begin
-        LThread.FInitialSuspended := false;
-        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 calling EndThread');
-  EndThread(Result);
-end;
-
-{ TThread }
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
-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 := CurrentTM.SemaphoreInit();
-  FSuspended := CreateSuspended;
-  FSuspendedExternal := false;
-  FInitialSuspended := CreateSuspended;
-  FFatalException := nil;
-  WRITE_DEBUG('creating thread, self = ',PtrInt(self));
-  FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID,StackSize);
-  WRITE_DEBUG('TThread.Create done');
-end;
-
-
-destructor TThread.Destroy;
-begin
-  if (FThreadID = GetCurrentThreadID) and not(FFreeOnTerminate) and not ffinished 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.
-    CurrentTM.SemaphorePost(FSem);
-    WaitFor;
-  end;
-  FFatalException.Free;
-  FFatalException := nil;
-  CurrentTM.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;
-      CurrentTM.SemaphoreWait(FSem);
-    end else begin
-      FSuspendedExternal := true;
-      SuspendThread(FHandle);
-    end;
-  end;
-end;
-
-
-procedure TThread.Resume;
-begin
-  if (not FSuspendedExternal) then begin
-    if FSuspended then begin
-      FSuspended := False;
-      CurrentTM.SemaphorePost(FSem);
-    end;
-  end else begin
-    FSuspendedExternal := false;
-    ResumeThread(FHandle);
-  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.SetPriority(Value: TThreadPriority);
-begin
-  ThreadSetPriority(FHandle, Priorities[Value]);
-end;
-

rtl/solaris/tthread.inc

@@ -1,252 +0,0 @@
-{
-   This file is part of the Free Pascal run time library.
-   (c) 2000-2003 by Marco van de Voort
-   member of the Free Pascal development team.
-
-   See the file COPYING.FPC, included in this distribution,
-   for details about the copyright.
-
-   TThread implementation old (1.0) and new (pthreads) style
-
-   This program is distributed in the hope that it will be useful,
-   but WITHOUT ANY WARRANTY;without even the implied warranty of
-   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-}
-
-
-{
-  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
-}
-
-{ 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}
-
-var
-  ThreadsInited: boolean = false;
-  CurrentTM: TThreadManager;
-  
-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
-    GetThreadManager(CurrentTM);
-    ThreadsInited := true;
-  end;
-end;
-
-procedure DoneThreads;
-begin
-  ThreadsInited := false;
-end;
-
-function ThreadFunc(parameter: Pointer): LongInt;
-var
-  LThread: TThread;
-  c: char;
-begin
-  WRITE_DEBUG('ThreadFunc is here...');
-  LThread := TThread(parameter);
-  WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
-  try
-    if LThread.FInitialSuspended then begin
-      CurrentTM.SemaphoreWait(LThread.FSem);
-      if not LThread.FSuspended then begin
-        LThread.FInitialSuspended := false;
-        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 calling EndThread');
-  EndThread(Result);
-end;
-
-{ TThread }
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
-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 := CurrentTM.SemaphoreInit();
-  FSuspended := CreateSuspended;
-  FSuspendedExternal := false;
-  FInitialSuspended := CreateSuspended;
-  FFatalException := nil;
-  WRITE_DEBUG('creating thread, self = ',PtrInt(self));
-  FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID,StackSize);
-  WRITE_DEBUG('TThread.Create done');
-end;
-
-
-destructor TThread.Destroy;
-begin
-  if (FThreadID = GetCurrentThreadID) and not(FFreeOnTerminate) and not ffinished 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.
-    CurrentTM.SemaphorePost(FSem);
-    WaitFor;
-  end;
-  FFatalException.Free;
-  FFatalException := nil;
-  CurrentTM.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;
-      CurrentTM.SemaphoreWait(FSem);
-    end else begin
-      FSuspendedExternal := true;
-      SuspendThread(FHandle);
-    end;
-  end;
-end;
-
-
-procedure TThread.Resume;
-begin
-  if (not FSuspendedExternal) then begin
-    if FSuspended then begin
-      FSuspended := False;
-      CurrentTM.SemaphorePost(FSem);
-    end;
-  end else begin
-    FSuspendedExternal := false;
-    ResumeThread(FHandle);
-  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.SetPriority(Value: TThreadPriority);
-begin
-  ThreadSetPriority(FHandle, Priorities[Value]);
-end;
-

rtl/unix/cthreads.pp

@@ -18,6 +18,24 @@
 {$define dynpthreads} // Useless on BSD, since they are in libc
 {$endif}
 
+
+{ sem_init is best, since it does not consume any file descriptors.    }
+{ sem_open is second best, since it consumes only one file descriptor  }
+{ per semaphore.                                                       }
+{ If neither is available, pipe is used as fallback, which consumes 2  }
+{ file descriptors per semaphore.                                      }
+
+{ Darwin doesn't support nameless semaphores in at least }
+{ Mac OS X 10.4.8/Darwin 8.8                             }
+{$ifndef darwin}
+{$define has_sem_init}
+{$define has_sem_getvalue}
+{$else }
+{$ifdef darwin}
+{$define has_sem_open}
+{$endif}
+{$endif}
+
 unit cthreads;
 interface
 {$S-}
@@ -213,10 +231,10 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
       { Initialize multithreading if not done }
       if not IsMultiThread then
         begin
-          if (InterLockedExchange(longint(IsMultiThread),1) = 0) then
+          if (InterLockedExchange(longint(IsMultiThread),ord(true)) = 0) then
             begin
               { We're still running in single thread mode, setup the TLS }
-               pthread_key_create(@TLSKey,nil);
+              pthread_key_create(@TLSKey,nil);
               InitThreadVars(@CRelocateThreadvar);
             end
         end;
@@ -239,9 +257,11 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
       // 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(ppthread_t(@threadid), @thread_attr, @ThreadMain,ti) <> 0 then begin
-        threadid := TThreadID(0);
-      end;
+      if pthread_create(ppthread_t(@threadid), @thread_attr, @ThreadMain,ti) <> 0 then
+        begin
+          dispose(ti);
+          threadid := TThreadID(0);
+        end;
       CBeginThread:=threadid;
 {$ifdef DEBUG_MT}
       writeln('BeginThread returning ',ptrint(CBeginThread));
@@ -366,6 +386,130 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
       end;
 
 
+{*****************************************************************************
+                           Semaphore routines
+*****************************************************************************}
+  
+
+procedure cSemaphoreWait(const FSem: Pointer);
+var
+  res: cint;
+  err: cint;
+{$if not defined(has_sem_init) and not defined(has_sem_open)}
+  b: byte;
+{$endif}
+begin
+{$if defined(has_sem_init) or defined(has_sem_open)}
+  repeat
+    res:=sem_wait(PSemaphore(FSem));
+    err:=fpgeterrno;
+  until (res<>-1) or (err<>ESysEINTR);
+{$else}
+  repeat
+    res:=fpread(PFilDes(FSem)^[0], b, 1);
+    err:=fpgeterrno;
+  until (res<>-1) or ((err<>ESysEINTR) and (err<>ESysEAgain));
+{$endif}
+end;
+
+procedure cSemaphorePost(const FSem: Pointer);
+{$if defined(has_sem_init) or defined(has_sem_open)}
+begin
+  sem_post(PSemaphore(FSem));
+end;
+{$else}
+var
+  writeres: cint;
+  err: cint;
+  b : byte;
+begin
+  b:=0;
+  repeat
+    writeres:=fpwrite(PFilDes(FSem)^[1], b, 1);
+    err:=fpgeterrno;
+  until (writeres<>-1) or ((err<>ESysEINTR) and (err<>ESysEAgain));
+end;
+{$endif}
+
+
+{$if defined(has_sem_open) and not defined(has_sem_init)}
+function cIntSemaphoreOpen(const name: pchar; initvalue: boolean): Pointer;
+var
+  err: cint;
+begin
+  repeat
+    cIntSemaphoreOpen := sem_open(name,O_CREAT,0,ord(initvalue));
+    err:=fpgeterrno;
+  until (ptrint(cIntSemaphoreOpen) <> SEM_FAILED) or (err <> ESysEINTR);
+  if (ptrint(cIntSemaphoreOpen) <> SEM_FAILED) then
+    { immediately unlink so the semaphore will be destroyed when the }
+    { the process exits                                              }
+    sem_unlink(name)
+  else
+    cIntSemaphoreOpen:=NIL;
+end;
+{$endif}
+
+
+function cIntSemaphoreInit(initvalue: boolean): Pointer;
+{$if defined(has_sem_open) and not defined(has_sem_init)}
+var
+  tid: string[31];
+  semname: string[63];
+  err: cint;
+{$endif}
+begin
+{$ifdef has_sem_init}
+  cIntSemaphoreInit := GetMem(SizeOf(TSemaphore));
+  if sem_init(PSemaphore(cIntSemaphoreInit), 0, ord(initvalue)) <> 0 then
+    begin
+      FreeMem(cIntSemaphoreInit);
+      cIntSemaphoreInit:=NIL;
+    end;
+{$else}
+{$ifdef has_sem_open}
+  { avoid a potential temporary nameclash with another process/thread }
+  str(fpGetPid,semname);
+  str(ptruint(pthread_self),tid);
+  semname:='/FPC'+semname+'T'+tid+#0;
+  cIntSemaphoreInit:=cIntSemaphoreOpen(@semname[1],initvalue);
+{$else}
+  cIntSemaphoreInit := GetMem(SizeOf(TFilDes));
+  if (fppipe(PFilDes(cIntSemaphoreInit)^) <> 0) then
+    begin
+      FreeMem(cIntSemaphoreInit);
+      cIntSemaphoreInit:=nil;
+    end
+  else if initvalue then
+    cSemaphorePost(cIntSemaphoreInit);
+{$endif}
+{$endif}
+end;
+
+
+function cSemaphoreInit: Pointer;
+begin
+  cSemaphoreInit:=cIntSemaphoreInit(false);
+end;
+
+
+procedure cSemaphoreDestroy(const FSem: Pointer);
+begin
+{$ifdef has_sem_init}
+  sem_destroy(PSemaphore(FSem));
+  FreeMem(FSem);
+{$else}
+{$ifdef has_sem_open}
+  sem_close(PSemaphore(FSem));
+{$else has_sem_init}
+  fpclose(PFilDes(FSem)^[0]);
+  fpclose(PFilDes(FSem)^[1]);
+  FreeMem(FSem);
+{$endif}
+{$endif}
+end;
+
+
 {*****************************************************************************
                            Heap Mutex Protection
 *****************************************************************************}
@@ -411,8 +555,8 @@ type
      TPthreadMutex = pthread_mutex_t;
      Tbasiceventstate=record
          FSem: Pointer;
-         FManualReset: Boolean;
          FEventSection: TPthreadMutex;
+         FManualReset: Boolean;
         end;
      plocaleventstate = ^tbasiceventstate;
 //     peventstate=pointer;
@@ -428,12 +572,35 @@ function IntBasicEventCreate(EventAttributes : Pointer; AManualReset,InitialStat
 var
   MAttr : pthread_mutexattr_t;
   res   : cint;
-
-
 begin
   new(plocaleventstate(result));
   plocaleventstate(result)^.FManualReset:=AManualReset;
-  plocaleventstate(result)^.FSem:=New(PSemaphore);  //sem_t.
+{$ifdef has_sem_init}
+  plocaleventstate(result)^.FSem:=cIntSemaphoreInit(true);
+  if plocaleventstate(result)^.FSem=nil then
+    begin
+      FreeMem(result);
+      runerror(6);
+    end;
+{$else}
+{$ifdef has_sem_open}
+  plocaleventstate(result)^.FSem:=cIntSemaphoreOpen(PChar(Name),InitialState);
+  if (plocaleventstate(result)^.FSem = NIL) then
+    begin
+      FreeMem(result);
+      runerror(6);
+    end;
+{$else}
+  plocaleventstate(result)^.FSem:=cSemaphoreInit;
+  if (plocaleventstate(result)^.FSem = NIL) then
+    begin
+      FreeMem(result);
+      runerror(6);
+    end;
+  if InitialState then
+    cSemaphorePost(plocaleventstate(result)^.FSem);
+{$endif}
+{$endif}
 //  plocaleventstate(result)^.feventsection:=nil;
   res:=pthread_mutexattr_init(@MAttr);
   if res=0 then
@@ -448,35 +615,93 @@ begin
     res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
   pthread_mutexattr_destroy(@MAttr);
   if res <> 0 then
-    runerror(6);
-  if sem_init(psem_t(plocaleventstate(result)^.FSem),ord(False),Ord(InitialState)) <> 0 then
-    runerror(6);
+    begin
+      cSemaphoreDestroy(plocaleventstate(result)^.FSem);
+      FreeMem(result);
+      runerror(6);
+    end;
 end;
 
 procedure Intbasiceventdestroy(state:peventstate);
 
 begin
-  sem_destroy(psem_t(  plocaleventstate(state)^.FSem));
+  cSemaphoreDestroy(plocaleventstate(state)^.FSem);
+  FreeMem(state);
 end;
 
 procedure IntbasiceventResetEvent(state:peventstate);
 
+{$if defined(has_sem_init) or defined(has_sem_open)}
+var
+  res: cint;
+  err: cint;
 begin
-  While sem_trywait(psem_t( plocaleventstate(state)^.FSem))=0 do
-    ;
+  repeat
+    res:=sem_trywait(psem_t(plocaleventstate(state)^.FSem));
+    err:=fpgeterrno;
+  until (res<>0) and ((res<>-1) or (err<>ESysEINTR));
+{$else has_sem_init or has_sem_open}
+var
+  fds: TFDSet;
+  tv : timeval;
+begin
+  tv.tv_sec:=0;
+  tv.tv_usec:=0;
+  fpFD_ZERO(fds);
+  fpFD_SET(PFilDes(plocaleventstate(state)^.FSem)^[0],fds);
+  pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
+  Try
+    while fpselect(PFilDes(plocaleventstate(state)^.FSem)^[0],@fds,nil,nil,@tv) > 0 do
+      cSemaphoreWait(plocaleventstate(state)^.FSem);
+  finally
+    pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
+  end;
+{$endif has_sem_init or has_sem_open}
 end;
 
 procedure IntbasiceventSetEvent(state:peventstate);
 
 Var
+{$if defined(has_sem_init) or defined(has_sem_open)}
   Value : Longint;
-
+  res : cint;
+  err : cint;
+{$else}
+  fds: TFDSet;
+  tv : timeval;
+{$endif}
 begin
   pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
   Try
-    sem_getvalue(plocaleventstate(state)^.FSem,@value);
-    if Value=0 then
-      sem_post(psem_t( plocaleventstate(state)^.FSem));
+{$if defined(has_sem_init) or defined(has_sem_open)}
+    if (sem_getvalue(plocaleventstate(state)^.FSem,@value) <> -1) then
+      begin
+        if Value=0 then
+          cSemaphorePost(plocaleventstate(state)^.FSem);
+      end
+    else if (fpgeterrno = ESysENOSYS) then
+      { not yet implemented on Mac OS X 10.4.8 }
+      begin
+        repeat
+          res:=sem_trywait(psem_t(plocaleventstate(state)^.FSem));
+          err:=fpgeterrno;
+        until ((res<>-1) or (err<>ESysEINTR));
+        { now we've either decreased the semaphore by 1 (if it was  }
+        { not zero), or we've done nothing (if it was already zero) }
+        { -> increase by 1 and we have the same result as           }
+        { increasing by 1 only if it was 0                          }
+        cSemaphorePost(plocaleventstate(state)^.FSem);
+      end
+    else
+      runerror(6);
+{$else has_sem_init or has_sem_open}
+    tv.tv_sec:=0;
+    tv.tv_usec:=0;
+    fpFD_ZERO(fds);
+    fpFD_SET(PFilDes(plocaleventstate(state)^.FSem)^[0],fds);
+    if fpselect(PFilDes(plocaleventstate(state)^.FSem)^[0],@fds,nil,nil,@tv)=0 then
+      cSemaphorePost(plocaleventstate(state)^.FSem);
+{$endif has_sem_init or has_sem_open}
   finally
     pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
   end;
@@ -489,16 +714,16 @@ begin
     result:=wrError
   else
     begin
-      sem_wait(psem_t(plocaleventstate(state)^.FSem));
+      cSemaphoreWait(plocaleventstate(state)^.FSem);
       result:=wrSignaled;
       if plocaleventstate(state)^.FManualReset then
         begin
           pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
           Try
-              intbasiceventresetevent(State);
-              sem_post(psem_t( plocaleventstate(state)^.FSem));
-            Finally
-          pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
+            intbasiceventresetevent(State);
+            cSemaphorePost(plocaleventstate(state)^.FSem);
+          Finally
+            pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
         end;
       end;
     end;
@@ -582,36 +807,7 @@ procedure intRTLEventWaitForTimeout(AEvent: PRTLEvent;timeout : longint);
     if (errres=0) or (errres=ESysETIMEDOUT) then
       pthread_mutex_unlock(@p^.mutex);
   end;
-  
-function cSemaphoreInit: Pointer;
-var
-  s: PSemaphore;
-begin
-  GetMem(s, SizeOf(TSemaphore));
-  if sem_init(s, 0, 0) = 0 then
-    cSemaphoreInit:=s
-  else
-    cSemaphoreInit:=nil;
-end;
 
-procedure cSemaphoreWait(const FSem: Pointer);
-begin
-  sem_wait(PSemaphore(FSem));
-end;
-
-procedure cSemaphorePost(const FSem: Pointer);
-begin
-  sem_post(PSemaphore(FSem));
-end;
-
-procedure cSemaphoreDestroy(const FSem: Pointer);
-var
-  s: PSemaphore;
-begin
-  s:=FSem;
-  sem_destroy(PSemaphore(FSem));
-  FreeMem(s);
-end;
 
 type
   threadmethod = procedure of object;

rtl/darwin/tthread.inc → rtl/unix/tthread.inc

@@ -1,8 +1,10 @@
 {
-    This file is part of the Free Component Library (FCL)
+    This file is part of the Free Pascal run time library.
     Copyright (c) 1999-2000 by Peter Vreman
+    Copyright (c) 2006 by Jonas Maebe
+    members of the Free Pascal development team.
 
-    Darwin TThread implementation
+    Generic *nix TThread implementation
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -14,6 +16,7 @@
  **********************************************************************}
 
 
+
 {
   What follows, is a short description on my implementation of TThread.
   Most information can also be found by reading the source and accompanying
@@ -31,25 +34,6 @@
   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
 }
@@ -73,10 +57,12 @@ const
 
 procedure InitThreads;
 begin
-  if not ThreadsInited then begin
+  { This is not thread safe, but it doesn't matter if this is executed }
+  { multiple times. Conversely, if one thread goes by this without the }
+  { operation having been finished by another thread already, it will  }
+  { use an uninitialised thread manager -> leave as it is              }
+  if not ThreadsInited then
     GetThreadManager(CurrentTM);
-    ThreadsInited := true;
-  end;
 end;
 
 procedure DoneThreads;
@@ -92,9 +78,15 @@ begin
   LThread := TThread(parameter);
   WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
   try
+    // wait until AfterConstruction has been called, so we cannot
+    // free ourselves before TThread.Create has finished
+    // (since that one may check our VTM in case of $R+, and
+    //  will call the AfterConstruction method in all cases)
+    LThread.Suspend;
+    WRITE_DEBUG('AfterConstruction should have been called for ',ptrint(lthread));
     if LThread.FInitialSuspended then
       begin
-        CurrentTM.SemaphoreWait(LThread.FSem);
+        LThread.Suspend;
         if not(LThread.FTerminated) then
           begin
             if not LThread.FSuspended then
@@ -113,7 +105,7 @@ begin
   except
     on e: exception do begin
       WRITE_DEBUG('got exception: ',e.message);
-      LThread.FFatalException :=  TObject(AcquireExceptionObject);
+      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;
@@ -124,14 +116,19 @@ begin
   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');
+  if LThread.FreeOnTerminate then
+    begin
+      WRITE_DEBUG('Thread ',ptrint(lthread),' should be freed');
+      LThread.Free;
+      WRITE_DEBUG('Thread freed');
 //    tthread.destroy already frees all things and terminates the thread
 //    WRITE_DEBUG('thread func calling EndThread');
 //    EndThread(Result);
-  end;
+    end
+  else
+    begin
+      FlushThread;
+    end;
 end;
 
 { TThread }
@@ -143,35 +140,49 @@ begin
   InitThreads;
   inherited Create;
   FSem := CurrentTM.SemaphoreInit();
-  FSuspended := CreateSuspended;
+  if FSem = nil then
+    raise EThread.create('Semaphore init failed (possibly too many concurrent threads)');
+  FSuspended := True;
   FSuspendedExternal := false;
   FInitialSuspended := CreateSuspended;
   FFatalException := nil;
   WRITE_DEBUG('creating thread, self = ',longint(self));
   FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID, StackSize);
-  WRITE_DEBUG('TThread.Create done');
+  if FHandle = TThreadID(0) then
+    raise EThread.create('Failed to create new thread');
+  WRITE_DEBUG('TThread.Create done, fhandle = ', ptrint(fhandle));
 end;
 
 
 destructor TThread.Destroy;
 begin
-  if (FThreadID = GetCurrentThreadID) and not(FFreeOnTerminate) and not ffinished then begin
+  if (FSem = nil) then
+    { exception in constructor }
+    begin
+      inherited destroy;
+      exit;
+    end;
+  CurrentTM.SemaphoreDestroy(FSem);
+  if (FHandle = TThreadID(0)) then
+  { another exception in constructor }
+    begin
+      inherited destroy;
+      exit;
+    end;
+  if (FThreadID = GetCurrentThreadID) and not(FFreeOnTerminate) and not FFinished then
     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 (FInitialSuspended) then
-    // thread was created suspended but never woken up.
-    Resume;
-  if not FFinished and not FSuspended then
+  if not FFinished then
     begin
       Terminate;
+      if (FInitialSuspended) then
+        Resume;
       WaitFor;
     end;
   FFatalException.Free;
   FFatalException := nil;
-  CurrentTM.SemaphoreDestroy(FSem);
   { threadvars have been released by cthreads.ThreadMain -> DoneThread }
   inherited Destroy;
 end;
@@ -201,15 +212,20 @@ end;
 
 procedure TThread.Resume;
 begin
-  if (not FSuspendedExternal) then begin
-    if FSuspended then begin
-      FSuspended := False;
-      CurrentTM.SemaphorePost(FSem);
+  if (not FSuspendedExternal) then
+    begin
+      if FSuspended then
+        begin
+          WRITE_DEBUG('resuming ',ptrint(self));
+          FSuspended := False;
+          CurrentTM.SemaphorePost(FSem);
+        end;
+    end
+  else
+    begin
+      FSuspendedExternal := false;
+      ResumeThread(FHandle);
     end;
-  end else begin
-    FSuspendedExternal := false;
-    ResumeThread(FHandle);
-  end;
 end;
 
 
@@ -255,4 +271,3 @@ procedure TThread.SetPriority(Value: TThreadPriority);
 begin
   ThreadSetPriority(FHandle, Priorities[Value]);
 end;
-

tests/test/tbrtlevt.pp

@@ -0,0 +1,46 @@
+{$mode objfpc}
+
+uses
+{$ifdef unix}
+ cthreads,
+{$endif}
+  sysutils,
+  classes;
+
+type
+  tc = class(tthread)
+    procedure execute; override;
+  end;
+
+var
+  event: pEventState;
+  waiting: boolean;
+
+procedure tc.execute;
+begin
+  { avoid deadlocks/bugs from causing this test to never quit }
+  sleep(1000*20);
+  halt(1);
+end;
+
+
+begin
+  tc.create(false);
+  event := BasicEventCreate(nil,false,false,'bla');;
+  basiceventSetEvent(event);
+  if (basiceventWaitFor(cardinal(-1),event) <> 0) then
+    begin
+      writeln('error');
+      halt(1);
+    end;
+  { shouldn't change anything }
+  basiceventResetEvent(event);
+  basiceventSetEvent(event);
+  { shouldn't change anything }
+  basiceventSetEvent(event);
+  if (basiceventWaitFor(cardinal(-1),event) <> 0) then
+    begin
+      writeln('error');
+      halt(1);
+    end;
+end.