paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-03 06:49:26 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ implementation of cSemaphore* and BasicRTLEvent based on

Browse Source 
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 -
This commit is contained in:
Jonas Maebe 2006-12-21 18:22:47 +00:00
parent 3253e7464a
commit 0c3afc0cf4
13 changed files with 381 additions and 1380 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.gitattributes vendored
View File

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

8
rtl/darwin/pthread.inc
View File

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

252
rtl/freebsd/tthread.inc
View File

@ -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 <johannes@sipsolutions.de>, 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;

8
rtl/inc/thread.inc
View File

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

1
rtl/inc/threadh.inc
View File

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

258
rtl/linux/tthread.inc
View File

@ -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 <johannes@sipsolutions.de>, 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;

252
rtl/netbsd/tthread.inc
View File

@ -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 <johannes@sipsolutions.de>, 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;

9
rtl/netwlibc/tthread.inc
View File

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

252
rtl/openbsd/tthread.inc
View File

@ -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 <johannes@sipsolutions.de>, 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;

252
rtl/solaris/tthread.inc
View File

@ -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 <johannes@sipsolutions.de>, 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;

302
rtl/unix/cthreads.pp
View File

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

113
rtl/darwin/tthread.inc → rtl/unix/tthread.inc
View File

@ -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 <johannes@sipsolutions.de>, 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;

46
tests/test/tbrtlevt.pp Normal file
View File

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