diff --git a/.gitattributes b/.gitattributes index c4a4857623..b5864551af 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/rtl/solaris/pthread.inc b/rtl/solaris/pthread.inc new file mode 100644 index 0000000000..7adef130b5 --- /dev/null +++ b/rtl/solaris/pthread.inc @@ -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'; + diff --git a/rtl/solaris/tthread.inc b/rtl/solaris/tthread.inc new file mode 100644 index 0000000000..cb538d2121 --- /dev/null +++ b/rtl/solaris/tthread.inc @@ -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 , 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; +