paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-16 11:39:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

* missing includes

Browse Source 
git-svn-id: trunk@2491 -
This commit is contained in:
peter 2006-02-09 07:04:12 +00:00
parent cf4b0a2185
commit 91ab7f151a
3 changed files with 383 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -4391,6 +4391,7 @@ rtl/solaris/i386/sighndh.inc svneol=native#text/plain
rtl/solaris/osdefs.inc svneol=native#text/plain
rtl/solaris/osmacro.inc svneol=native#text/plain
rtl/solaris/ostypes.inc svneol=native#text/plain
rtl/solaris/pthread.inc svneol=native#text/plain
rtl/solaris/ptypes.inc svneol=native#text/plain
rtl/solaris/signal.inc svneol=native#text/plain
rtl/solaris/sparc/sighnd.inc svneol=native#text/plain
@ -4403,6 +4404,7 @@ 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/sparc/int64p.inc svneol=native#text/plain

78
rtl/solaris/pthread.inc Normal file
View File

@ -0,0 +1,78 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Peter Vreman
member of the Free Pascal development team.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This file contains a pthread.h headerconversion,
and should contain an interface to the threading library to be
used by systhrd, preferably in a somewhat compatible notation
(compared to the other OSes).
As a start, I simply used libc_r
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.
**********************************************************************}
CONST PTHREAD_EXPLICIT_SCHED = 0;
PTHREAD_CREATE_DETACHED = 1;
PTHREAD_SCOPE_PROCESS = 0;
TYPE
ppthread_t = ^pthread_t;
ppthread_key_t = ^pthread_key_t;
ppthread_mutex_t = ^pthread_mutex_t;
ppthread_attr_t = ^pthread_attr_t;
__destr_func_t = procedure (p :pointer);cdecl;
__startroutine_t = function (p :pointer):pointer;cdecl;
ppthread_mutexattr_t = ^pthread_mutexattr_t;
ppthread_cond_t = ^pthread_cond_t;
ppthread_condattr_t = ^pthread_condattr_t;
sem_t = cint;
psem_t = ^sem_t;
TSemaphore = sem_t;
PSemaphore = ^TSemaphore;
function pthread_getspecific (t : pthread_key_t):pointer; cdecl; external 'c';
function pthread_setspecific (t : pthread_key_t;p:pointer):cint; cdecl; external 'c';
function pthread_key_create (p : ppthread_key_t;f: __destr_func_t):cint; cdecl;external 'c';
function pthread_attr_init (p : ppthread_key_t):cint; cdecl; external 'c';
function pthread_attr_setinheritsched(p : ppthread_attr_t;i:cint):cint; cdecl; external 'c';
function pthread_attr_setscope (p : ppthread_attr_t;i:cint):cint;cdecl;external 'c';
function pthread_attr_setdetachstate (p : ppthread_attr_t;i:cint):cint;cdecl;external 'c';
function pthread_create ( p: ppthread_t;attr : ppthread_attr_t;f:__startroutine_t;arg:pointer):cint;cdecl;external 'c';
procedure pthread_exit ( p: pointer); cdecl;external 'c';
function pthread_self:cint; cdecl;external 'c';
function pthread_mutex_init (p:ppthread_mutex_t;o:ppthread_mutexattr_t):cint; cdecl;external 'c';
function pthread_mutex_destroy (p:ppthread_mutexattr_t):cint; cdecl;external 'c';
function pthread_mutex_lock (p:ppthread_mutexattr_t):cint; cdecl;external 'c';
function pthread_mutex_unlock (p:ppthread_mutexattr_t):cint; cdecl;external 'c';
function pthread_cancel(_para1:pthread_t):cint;cdecl;external 'c';
function pthread_detach(_para1:pthread_t):cint;cdecl;external 'c';
function pthread_join(_para1:pthread_t; _para2:Ppointer):cint;cdecl;external 'c';
function pthread_cond_destroy(_para1:Ppthread_cond_t):cint;cdecl;external 'c' name 'pthread_cond_destroy';
function pthread_cond_init(_para1:Ppthread_cond_t;_para2:Ppthread_condattr_t):cint;cdecl;external 'c' name 'pthread_cond_init';
function pthread_cond_signal(_para1:Ppthread_cond_t):cint;cdecl;external 'c' name 'pthread_cond_signal';
function pthread_cond_wait(_para1:Ppthread_cond_t;_para2:Ppthread_mutex_t):cint;cdecl;external 'c' name 'pthread_cond_wait';
function sem_init(__sem:Psem_t; __pshared:cint;__value:cuint):cint;cdecl; external 'c' name 'sem_init';
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';
function sem_wait(__sem:Psem_t):cint;cdecl;external 'c' name 'sem_wait';
function sem_trywait(__sem:Psem_t):cint;cdecl;external 'c' name 'sem_trywait';
function sem_post(__sem:Psem_t):cint;cdecl;external 'c' name 'sem_post';
function sem_getvalue(__sem:Psem_t; __sval:Pcint):cint;cdecl;external 'c' name 'sem_getvalue';
function pthread_mutexattr_init(_para1:Ppthread_mutexattr_t):cint;cdecl;external 'c' name 'pthread_mutexattr_init';
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';

303
rtl/solaris/tthread.inc Normal file
View File

@ -0,0 +1,303 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2000 by Peter Vreman
Darwin TThread implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
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}
// ========== semaphore stuff ==========
{
I don't like this. It eats up 2 filedescriptors for each thread,
and those are a limited resource. If you have a server programm
handling client connections (one per thread) it will not be able
to handle many if we use 2 fds already for internal structures.
However, right now I don't see a better option unless some sem_*
functions are added to systhrds.
I encapsulated all used functions here to make it easier to
change them completely.
}
function SemaphoreInit: Pointer;
begin
SemaphoreInit := GetMem(SizeOf(TFilDes));
fppipe(PFilDes(SemaphoreInit)^);
WRITE_DEBUG('Opened file descriptor ',PFilDes(SemaphoreInit)^[0]);
end;
procedure SemaphoreWait(const FSem: Pointer);
var
b: byte;
begin
WRITE_DEBUG('Waiting for file descriptor ',PFilDes(FSem)^[0]);
repeat
if fpread(PFilDes(FSem)^[0], b, 1) = -1 then
WRITE_DEBUG('Error reading from semaphore ',PFilDes(FSem)^[0],' error = ',fpgeterrno);
until fpgeterrno <> ESysEIntr;
end;
procedure SemaphorePost(const FSem: Pointer);
{$ifdef VER2_0}
var
b : byte;
{$endif}
begin
WRITE_DEBUG('Activating file descriptor ',PFilDes(FSem)^[0]);
{$ifdef VER2_0}
b:=0;
fpwrite(PFilDes(FSem)^[1], b, 1);
{$else}
if fpwrite(PFilDes(FSem)^[1], #0, 1) = -1 then
WRITE_DEBUG('Error writing file descriptor ',PFilDes(FSem)^[0],' error = ',fpgeterrno);
{$endif}
end;
procedure SemaphoreDestroy(const FSem: Pointer);
begin
WRITE_DEBUG('Closing file descriptor ',PFilDes(FSem)^[0]);
fpclose(PFilDes(FSem)^[0]);
fpclose(PFilDes(FSem)^[1]);
FreeMemory(FSem);
end;
// =========== semaphore end ===========
var
ThreadsInited: boolean = false;
const
// stupid, considering its not even implemented...
Priorities: array [TThreadPriority] of Integer =
(-20,-19,-10,0,9,18,19);
procedure InitThreads;
begin
if not ThreadsInited then begin
ThreadsInited := true;
end;
end;
procedure DoneThreads;
begin
ThreadsInited := false;
end;
function ThreadFunc(parameter: Pointer): LongInt;
var
LThread: TThread;
begin
WRITE_DEBUG('ThreadFunc is here...');
LThread := TThread(parameter);
WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
try
if LThread.FInitialSuspended then begin
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 exiting');
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 := SemaphoreInit;
FSuspended := CreateSuspended;
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');
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.
SemaphorePost(FSem);
WaitFor;
end;
FFatalException.Free;
FFatalException := nil;
SemaphoreDestroy(FSem);
inherited Destroy;
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend
else
Resume;
end;
procedure TThread.Suspend;
begin
if not FSuspended then begin
if FThreadID = GetCurrentThreadID then begin
FSuspended := true;
SemaphoreWait(FSem);
end else begin
FSuspendedExternal := true;
SuspendThread(FHandle);
end;
end;
end;
procedure TThread.Resume;
begin
if (not FSuspendedExternal) then begin
if FSuspended then begin
FSuspended := False;
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 ',ptrint(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;