mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-08 04:48:07 +02:00
bsd
This commit is contained in:
marco
parent
3ab069324a
commit
0db9132414
@ -206,7 +206,7 @@ end;
|
||||
|
||||
function GetDomainName(Name:PChar; NameLen:Cint):cint; [public,alias:'FPC_SYSC_GETDOMAINNAME'];
|
||||
|
||||
Const Mib_GetDomainName : array[0..1] of cint=(CTL_KERN,KERN_NISDOMAINNAME);
|
||||
Const Mib_GetDomainName : array[0..1] of cint=(CTL_KERN,{$ifdef OpenBSD}KERN_DOMAINNAME{$ELSE}KERN_NISDOMAINNAME{$endif});
|
||||
|
||||
VAR
|
||||
tsize : size_t;
|
||||
@ -458,7 +458,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.7 2003-12-30 12:26:21 marco
|
||||
Revision 1.8 2004-01-22 13:46:14 marco
|
||||
bsd
|
||||
|
||||
Revision 1.7 2003/12/30 12:26:21 marco
|
||||
* FPC_USE_LIBC
|
||||
|
||||
Revision 1.6 2003/11/18 10:12:25 marco
|
||||
|
||||
@ -57,6 +57,18 @@ function geterrnolocation: Plibcint; cdecl;external clib name '__errno';
|
||||
{$ifdef Darwin}
|
||||
function geterrnolocation: Plibcint; cdecl;external clib name '__error';
|
||||
{$else}
|
||||
{$ifdef OpenBSD}
|
||||
|
||||
var libcerrno : libcint; cvar;
|
||||
|
||||
function geterrnolocation: Plibcint; cdecl;
|
||||
|
||||
begin
|
||||
geterrnolocation:=@libcerrno;
|
||||
end;
|
||||
|
||||
{$else}
|
||||
{$endif}
|
||||
{$endif}
|
||||
{$endif}
|
||||
{$endif}
|
||||
@ -173,7 +185,10 @@ End.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.13 2004-01-20 23:09:14 hajny
|
||||
Revision 1.14 2004-01-22 13:46:14 marco
|
||||
bsd
|
||||
|
||||
Revision 1.13 2004/01/20 23:09:14 hajny
|
||||
* ExecuteProcess fixes, ProcessID and ThreadID added
|
||||
|
||||
Revision 1.12 2004/01/04 20:32:05 jonas
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/01/05]
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/01/10]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
|
||||
@ -232,7 +232,7 @@ GRAPHDIR=$(INC)/graph
|
||||
ifndef USELIBGGI
|
||||
USELIBGGI=NO
|
||||
endif
|
||||
override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings syscall sysctl baseunix unixutil unix initc dos dl termio objects printer sysutils typinfo systhrds classes math varutils cpu mmx charset ucomplex crt getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard console serial variants types sysctl dateutils sysconst cthreads
|
||||
override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings syscall sysctl baseunix unixutil unix rtlconst initc dos dl termio objects printer sysutils typinfo systhrds classes math varutils cpu mmx charset ucomplex crt getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard console serial variants types sysctl dateutils sysconst cthreads
|
||||
override TARGET_LOADERS+=prt0 cprt0 gprt0
|
||||
override TARGET_RSTS+=math varutils typinfo classes variants dateutils sysconst
|
||||
override INSTALL_FPCPACKAGE=y y
|
||||
@ -1382,8 +1382,10 @@ printer$(PPUEXT) : $(UNIXINC)/printer.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYST
|
||||
sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
|
||||
objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT) $(OBJPASDIR)/sysconst$(PPUEXT)
|
||||
$(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
|
||||
rtlconst$(PPUEXT) : $(OBJPASDIR)/rtlconst.pp
|
||||
$(COMPILER): $(OBJPASDIR)/rtlconst.pp
|
||||
classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
|
||||
sysutils$(PPUEXT) typinfo$(PPUEXT)
|
||||
sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconst$(PPUEXT)
|
||||
$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
|
||||
|
||||
@ -11,7 +11,7 @@ fpcpackage=y
|
||||
[target]
|
||||
loaders=prt0 cprt0 gprt0
|
||||
units=$(SYSTEMUNIT) objpas strings syscall sysctl baseunix unixutil \
|
||||
unix initc \
|
||||
unix rtlconst initc \
|
||||
dos dl termio objects printer \
|
||||
sysutils typinfo systhrds classes math varutils \
|
||||
cpu mmx charset ucomplex crt getopts heaptrc lineinfo \
|
||||
@ -179,8 +179,11 @@ sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.in
|
||||
objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT) $(OBJPASDIR)/sysconst$(PPUEXT)
|
||||
$(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
|
||||
|
||||
rtlconst$(PPUEXT) : $(OBJPASDIR)/rtlconst.pp
|
||||
$(COMPILER): $(OBJPASDIR)/rtlconst.pp
|
||||
|
||||
classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
|
||||
sysutils$(PPUEXT) typinfo$(PPUEXT)
|
||||
sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconst$(PPUEXT)
|
||||
$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
|
||||
|
||||
Classes unit for linux
|
||||
Classes unit for OpenBSD
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
@ -33,11 +33,7 @@ uses
|
||||
implementation
|
||||
|
||||
uses
|
||||
{$ifdef ver1_0}
|
||||
linux
|
||||
{$else}
|
||||
unix
|
||||
{$endif}
|
||||
baseunix,unix,Systhrds
|
||||
;
|
||||
|
||||
{ OS - independent class implementations are in /inc directory. }
|
||||
@ -50,22 +46,43 @@ initialization
|
||||
finalization
|
||||
CommonCleanup;
|
||||
|
||||
{$ifndef ver1_0}
|
||||
if ThreadsInited then
|
||||
DoneThreads;
|
||||
|
||||
{$endif}
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2004-01-10 20:15:21 michael
|
||||
Revision 1.3 2004-01-22 13:46:14 marco
|
||||
bsd
|
||||
|
||||
Revision 1.6 2004/01/10 20:13:40 michael
|
||||
+ Some more fixes to rtlconst. Const strings moved from classes to rtlconst
|
||||
|
||||
Revision 1.5 2004/01/03 12:18:29 marco
|
||||
* a lot of copyright notices and CVS logs added and fixed
|
||||
|
||||
Revision 1.4 2003/12/22 16:16:33 marco
|
||||
* small 1.0 compat fix
|
||||
|
||||
Revision 1.3 2003/11/17 10:05:51 marco
|
||||
* threads for FreeBSD. Not working tho
|
||||
|
||||
Revision 1.2 2003/10/09 10:55:20 marco
|
||||
* fix for moving classes to rtl while cycling with 1.0 start
|
||||
|
||||
Revision 1.1 2003/10/06 21:01:06 peter
|
||||
* moved classes unit to rtl
|
||||
|
||||
Revision 1.2 2002/09/07 15:15:27 peter
|
||||
Revision 1.1 2003/10/06 20:33:58 peter
|
||||
* classes moved to rtl for 1.1
|
||||
* classes .inc and classes.pp files moved to fcl/classes for
|
||||
backwards 1.0.x compatiblity to have it in the fcl
|
||||
|
||||
Revision 1.6 2003/09/20 12:38:29 marco
|
||||
* FCL now compiles for FreeBSD with new 1.1. Now Linux.
|
||||
|
||||
Revision 1.5 2002/09/07 15:15:24 peter
|
||||
* old logs removed and tabs fixed
|
||||
|
||||
Revision 1.1 2002/07/30 16:03:29 marco
|
||||
* Added for OpenBSD. Plain copy of NetBSD
|
||||
|
||||
}
|
||||
|
||||
@ -20,47 +20,106 @@
|
||||
{ POSIX TYPE DEFINITIONS }
|
||||
{***********************************************************************}
|
||||
|
||||
{$I ctypes.inc}
|
||||
|
||||
type
|
||||
{ the following type definitions are compiler dependant }
|
||||
{ and system dependant }
|
||||
|
||||
cint8 = shortint;
|
||||
cuint8 = byte;
|
||||
cuint16= word;
|
||||
cint16 = smallint;
|
||||
cint32 = longint;
|
||||
cuint32= cardinal;
|
||||
cint64 = int64;
|
||||
{$ifndef VER_1_0}
|
||||
cuint64= qword;
|
||||
{$endif}
|
||||
dev_t = cuint32; { used for device numbers }
|
||||
TDev = dev_t;
|
||||
pDev = ^dev_t;
|
||||
|
||||
cint = longint; { minimum range is : 32-bit }
|
||||
cuint = Cardinal; { minimum range is : 32-bit }
|
||||
clong = longint;
|
||||
culong = Cardinal;
|
||||
|
||||
dev_t = cint32; { used for device numbers }
|
||||
gid_t = cuint32; { used for group IDs }
|
||||
ino_t = cuint32; { used for file serial numbers }
|
||||
mode_t = cuint16; { used for file attributes }
|
||||
nlink_t = cuint16; { used for link counts }
|
||||
TGid = gid_t;
|
||||
pGid = ^gid_t;
|
||||
|
||||
ino_t = clong; { used for file serial numbers }
|
||||
TIno = ino_t;
|
||||
pIno = ^ino_t;
|
||||
|
||||
mode_t = cuint32; { used for file attributes }
|
||||
TMode = mode_t;
|
||||
pMode = ^mode_t;
|
||||
|
||||
nlink_t = cuint32; { used for link counts }
|
||||
TnLink = nlink_t;
|
||||
pnLink = ^nlink_t;
|
||||
|
||||
off_t = cint64; { used for file sizes }
|
||||
TOff = off_t;
|
||||
pOff = ^off_t;
|
||||
|
||||
pid_t = cint32; { used as process identifier }
|
||||
TPid = pid_t;
|
||||
pPid = ^pid_t;
|
||||
|
||||
size_t = cuint32; { as definied in the C standard}
|
||||
TSize = size_t;
|
||||
pSize = ^size_t;
|
||||
|
||||
ssize_t = cint32; { used by function for returning number of bytes }
|
||||
TsSize = ssize_t;
|
||||
psSize = ^ssize_t;
|
||||
|
||||
uid_t = cuint32; { used for user ID type }
|
||||
TUid = Uid_t;
|
||||
pUid = ^Uid_t;
|
||||
|
||||
clock_t = culong;
|
||||
TClock = clock_t;
|
||||
pClock = ^clock_t;
|
||||
|
||||
time_t = clong; { used for returning the time }
|
||||
TTime = time_t;
|
||||
pTime = ^time_t;
|
||||
ptime_t = ^time_t;
|
||||
|
||||
socklen_t= cuint32;
|
||||
TSocklen = socklen_t;
|
||||
pSocklen = ^socklen_t;
|
||||
|
||||
timeval = packed record
|
||||
tv_sec,
|
||||
tv_usec : clong;
|
||||
end;
|
||||
ptimeval= ^timeval;
|
||||
TTimeval= timeval;
|
||||
|
||||
timespec = packed record
|
||||
tv_sec : time_t;
|
||||
tv_nsec : clong;
|
||||
end;
|
||||
ptimespec= ^timespec;
|
||||
Ttimespec= timespec;
|
||||
|
||||
CONST
|
||||
{ System limits, POSIX value in parentheses, used for buffer and stack allocation }
|
||||
ARG_MAX = 256*1024;{4096} { Maximum number of argument size }
|
||||
NAME_MAX = 255; {14} { Maximum number of bytes in filename }
|
||||
PATH_MAX = 1024; {255} { Maximum number of bytes in pathname }
|
||||
ARG_MAX = 256*1024; {4096} { Maximum number of argument size }
|
||||
NAME_MAX = 255; {14} { Maximum number of bytes in filename }
|
||||
PATH_MAX = 1024; {255} { Maximum number of bytes in pathname }
|
||||
|
||||
SYS_NMLN = 256; {BSD utsname struct limit}
|
||||
SYS_NMLN = 32; {BSD utsname struct limit}
|
||||
|
||||
SIG_MAXSIG = 128; // highest signal version
|
||||
wordsinsigset = 4; // words in sigset_t
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.4 2004-01-22 13:46:14 marco
|
||||
bsd
|
||||
|
||||
Revision 1.5 2004/01/04 20:08:45 jonas
|
||||
* moved SIG_MAXSIG and wordsinsigset constants from bunxtype.inc to
|
||||
ptypes.inc (already there for Darwin)
|
||||
|
||||
Revision 1.4 2004/01/04 01:11:28 marco
|
||||
* a new qod port of the freebsd rtl. To be refined in the coming days.
|
||||
|
||||
Revision 1.3 2003/01/17 22:13:47 marco
|
||||
* some updates
|
||||
|
||||
Revision 1.5 2003/01/03 13:11:32 marco
|
||||
* split into ptypes and ctypes
|
||||
|
||||
|
||||
}
|
||||
@ -27,6 +27,7 @@ Const
|
||||
syscall_nr_open = 5 ;
|
||||
syscall_nr_close = 6 ;
|
||||
syscall_nr_wait4 = 7 ;
|
||||
syscall_nr_waitpid = 8 ; // added: ease of notation purposes
|
||||
syscall_nr_link = 9 ;
|
||||
syscall_nr_unlink = 10 ;
|
||||
syscall_nr_chdir = 12 ;
|
||||
|
||||
@ -1,19 +1,21 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 1999-2000 by Peter Vreman
|
||||
{
|
||||
$Id$
|
||||
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.
|
||||
|
||||
Linux TThread implementation
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
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.
|
||||
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.
|
||||
}
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{$IFDEF VER1_0} // leaving the old implementation in for now...
|
||||
type
|
||||
PThreadRec=^TThreadRec;
|
||||
TThreadRec=record
|
||||
@ -32,7 +34,7 @@ Const
|
||||
function ThreadSelf:TThread;
|
||||
var
|
||||
hp : PThreadRec;
|
||||
sp : longint;
|
||||
sp : Pointer;
|
||||
begin
|
||||
sp:=SPtr;
|
||||
hp:=ThreadRoot;
|
||||
@ -52,13 +54,14 @@ end;
|
||||
|
||||
//function SIGCHLDHandler(Sig: longint): longint; cdecl;//this is std linux C declaration as function
|
||||
procedure SIGCHLDHandler(Sig: longint); cdecl;
|
||||
|
||||
begin
|
||||
waitpid(-1, nil, WNOHANG);
|
||||
fpwaitpid(-1, nil, WNOHANG);
|
||||
end;
|
||||
|
||||
procedure InitThreads;
|
||||
var
|
||||
Act, OldAct: PSigActionRec;
|
||||
Act, OldAct: Baseunix.PSigActionRec;
|
||||
begin
|
||||
ThreadRoot:=nil;
|
||||
ThreadsInited:=true;
|
||||
@ -71,11 +74,10 @@ begin
|
||||
GetMem(Act, SizeOf(SigActionRec));
|
||||
GetMem(OldAct, SizeOf(SigActionRec));
|
||||
|
||||
Act^.handler.sh := @SIGCHLDHandler;
|
||||
Act^.sa_handler := TSigAction(@SIGCHLDHandler);
|
||||
Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART};
|
||||
Act^.sa_mask := 0; //Do not block all signals ??. Don't need if SA_NOMASK in flags
|
||||
|
||||
SigAction(SIGCHLD, Act, OldAct);
|
||||
Fillchar(Act^.sa_mask,sizeof(Act^.sa_mask),0); //Do not block all signals ??. Don't need if SA_NOMASK in flags
|
||||
FpSigAction(SIGCHLD, Act, OldAct);
|
||||
|
||||
FreeMem(Act, SizeOf(SigActionRec));
|
||||
FreeMem(OldAct, SizeOf(SigActionRec));
|
||||
@ -147,6 +149,8 @@ var
|
||||
FreeThread: Boolean;
|
||||
Thread : TThread absolute args;
|
||||
begin
|
||||
while Thread.FHandle = 0 do fpsleep(1);
|
||||
if Thread.FSuspended then Thread.suspend();
|
||||
try
|
||||
Thread.Execute;
|
||||
except
|
||||
@ -158,7 +162,7 @@ begin
|
||||
Thread.DoTerminate;
|
||||
if FreeThread then
|
||||
Thread.Free;
|
||||
ExitProcess(Result);
|
||||
fpexit(Result);
|
||||
end;
|
||||
|
||||
|
||||
@ -172,12 +176,12 @@ begin
|
||||
Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
|
||||
{ Setup 16k of stack }
|
||||
FStackSize:=16384;
|
||||
Getmem(pointer(FStackPointer),FStackSize);
|
||||
Getmem(FStackPointer,FStackSize);
|
||||
inc(FStackPointer,FStackSize);
|
||||
FCallExitProcess:=false;
|
||||
{ Clone }
|
||||
FHandle:= Clone(@ThreadProc,pointer(FStackPointer),Flags,self);
|
||||
if FSuspended then Suspend;
|
||||
FHandle:= Clone(@ThreadProc,FStackPointer,Flags,self);
|
||||
// if FSuspended then Suspend;
|
||||
FThreadID := FHandle;
|
||||
IsMultiThread := TRUE;
|
||||
FFatalException := nil;
|
||||
@ -192,9 +196,9 @@ begin
|
||||
WaitFor;
|
||||
end;
|
||||
if FHandle <> -1 then
|
||||
Kill(FHandle, SIGKILL);
|
||||
fpkill(FHandle, SIGKILL);
|
||||
dec(FStackPointer,FStackSize);
|
||||
Freemem(pointer(FStackPointer),FStackSize);
|
||||
Freemem(FStackPointer);
|
||||
FFatalException.Free;
|
||||
FFatalException := nil;
|
||||
inherited Destroy;
|
||||
@ -225,7 +229,7 @@ var
|
||||
P: Integer;
|
||||
I: TThreadPriority;
|
||||
begin
|
||||
P := {$ifdef ver1_0}Linux{$else}Unix{$endif}.GetPriority(Prio_Process,FHandle);
|
||||
P := fpGetPriority(Prio_Process,FHandle);
|
||||
Result := tpNormal;
|
||||
for I := Low(TThreadPriority) to High(TThreadPriority) do
|
||||
if Priorities[I] = P then
|
||||
@ -235,7 +239,7 @@ end;
|
||||
|
||||
procedure TThread.SetPriority(Value: TThreadPriority);
|
||||
begin
|
||||
{$ifdef ver1_0}Linux{$else}Unix{$endif}.SetPriority(Prio_Process,FHandle, Priorities[Value]);
|
||||
fpSetPriority(Prio_Process,FHandle,Priorities[Value]);
|
||||
end;
|
||||
|
||||
|
||||
@ -261,14 +265,14 @@ end;
|
||||
|
||||
procedure TThread.Suspend;
|
||||
begin
|
||||
Kill(FHandle, SIGSTOP);
|
||||
FSuspended := true;
|
||||
fpKill(FHandle, SIGSTOP);
|
||||
end;
|
||||
|
||||
|
||||
procedure TThread.Resume;
|
||||
begin
|
||||
Kill(FHandle, SIGCONT);
|
||||
fpKill(FHandle, SIGCONT);
|
||||
FSuspended := False;
|
||||
end;
|
||||
|
||||
@ -283,24 +287,362 @@ var
|
||||
status : longint;
|
||||
begin
|
||||
if FThreadID = MainThreadID then
|
||||
WaitPid(0,@status,0)
|
||||
fpwaitpid(0,@status,0)
|
||||
else
|
||||
WaitPid(FHandle,@status,0);
|
||||
fpwaitpid(FHandle,@status,0);
|
||||
Result:=status;
|
||||
end;
|
||||
{$ELSE}
|
||||
|
||||
{
|
||||
What follows, is a short description on my implementation of TThread.
|
||||
Most information can also be found by reading the source and accompanying
|
||||
comments.
|
||||
|
||||
A thread is created using BeginThread, which in turn calls
|
||||
pthread_create. So the threads here are always posix threads.
|
||||
Posix doesn't define anything for suspending threads as this is
|
||||
inherintly unsafe. Just don't suspend threads at points they cannot
|
||||
control. Therefore, I didn't implement .Suspend() if its called from
|
||||
outside the threads execution flow (except on Linux _without_ NPTL).
|
||||
|
||||
The implementation for .suspend uses a semaphore, which is initialized
|
||||
at thread creation. If the thread tries to suspend itself, we simply
|
||||
let it wait on the semaphore until it is unblocked by someone else
|
||||
who calls .Resume.
|
||||
|
||||
If a thread is supposed to be suspended (from outside its own path of
|
||||
execution) on a system where the symbol LINUX is defined, two things
|
||||
are possible.
|
||||
1) the system has the LinuxThreads pthread implementation
|
||||
2) the system has NPTL as the pthread implementation.
|
||||
|
||||
In the first case, each thread is a process on its own, which as far as
|
||||
know actually violates posix with respect to signal handling.
|
||||
But we can detect this case, because getpid(2) will
|
||||
return a different PID for each thread. In that case, sending SIGSTOP
|
||||
to the PID associated with a thread will actually stop that thread
|
||||
only.
|
||||
In the second case, this is not possible. But getpid(2) returns the same
|
||||
PID across all threads, which is detected, and TThread.Suspend() does
|
||||
nothing in that case. This should probably be changed, but I know of
|
||||
no way to suspend a thread when using NPTL.
|
||||
|
||||
If the symbol LINUX is not defined, then the unimplemented
|
||||
function SuspendThread is called.
|
||||
|
||||
Johannes Berg <johannes@sipsolutions.de>, Sunday, November 16 2003
|
||||
}
|
||||
|
||||
// ========== semaphore stuff ==========
|
||||
{
|
||||
I don't like this. It eats up 2 filedescriptors for each thread,
|
||||
and those are a limited resource. If you have a server programm
|
||||
handling client connections (one per thread) it will not be able
|
||||
to handle many if we use 2 fds already for internal structures.
|
||||
However, right now I don't see a better option unless some sem_*
|
||||
functions are added to systhrds.
|
||||
I encapsulated all used functions here to make it easier to
|
||||
change them completely.
|
||||
}
|
||||
|
||||
function SemaphoreInit: Pointer;
|
||||
begin
|
||||
SemaphoreInit := GetMem(SizeOf(TFilDes));
|
||||
fppipe(PFilDes(SemaphoreInit)^);
|
||||
end;
|
||||
|
||||
procedure SemaphoreWait(const FSem: Pointer);
|
||||
var
|
||||
b: byte;
|
||||
begin
|
||||
fpread(PFilDes(FSem)^[0], b, 1);
|
||||
end;
|
||||
|
||||
procedure SemaphorePost(const FSem: Pointer);
|
||||
begin
|
||||
fpwrite(PFilDes(FSem)^[1], #0, 1);
|
||||
end;
|
||||
|
||||
procedure SemaphoreDestroy(const FSem: Pointer);
|
||||
begin
|
||||
fpclose(PFilDes(FSem)^[0]);
|
||||
fpclose(PFilDes(FSem)^[1]);
|
||||
FreeMemory(FSem);
|
||||
end;
|
||||
|
||||
// =========== semaphore end ===========
|
||||
|
||||
var
|
||||
ThreadsInited: boolean = false;
|
||||
{$IFDEF LINUX}
|
||||
GMainPID: LongInt = 0;
|
||||
{$ENDIF}
|
||||
const
|
||||
// stupid, considering its not even implemented...
|
||||
Priorities: array [TThreadPriority] of Integer =
|
||||
(-20,-19,-10,0,9,18,19);
|
||||
|
||||
procedure InitThreads;
|
||||
begin
|
||||
if not ThreadsInited then begin
|
||||
ThreadsInited := true;
|
||||
{$IFDEF LINUX}
|
||||
GMainPid := fpgetpid();
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DoneThreads;
|
||||
begin
|
||||
ThreadsInited := false;
|
||||
end;
|
||||
|
||||
{ ok, so this is a hack, but it works nicely. Just never use
|
||||
a multiline argument with WRITE_DEBUG! }
|
||||
{$MACRO ON}
|
||||
{$IFDEF DEBUG_MT}
|
||||
{$define WRITE_DEBUG := writeln} // actually write something
|
||||
{$ELSE}
|
||||
{$define WRITE_DEBUG := //} // just comment out those lines
|
||||
{$ENDIF}
|
||||
|
||||
function ThreadFunc(parameter: Pointer): LongInt; cdecl;
|
||||
var
|
||||
LThread: TThread;
|
||||
c: char;
|
||||
begin
|
||||
WRITE_DEBUG('ThreadFunc is here...');
|
||||
LThread := TThread(parameter);
|
||||
{$IFDEF LINUX}
|
||||
// save the PID of the "thread"
|
||||
// this is different from the PID of the main thread if
|
||||
// the LinuxThreads implementation is used
|
||||
LThread.FPid := fpgetpid();
|
||||
{$ENDIF}
|
||||
WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
|
||||
try
|
||||
if LThread.FInitialSuspended then begin
|
||||
SemaphoreWait(LThread.FSem);
|
||||
if not LThread.FInitialSuspended then begin
|
||||
WRITE_DEBUG('going into LThread.Execute');
|
||||
LThread.Execute;
|
||||
end;
|
||||
end else begin
|
||||
WRITE_DEBUG('going into LThread.Execute');
|
||||
LThread.Execute;
|
||||
end;
|
||||
except
|
||||
on e: exception do begin
|
||||
WRITE_DEBUG('got exception: ',e.message);
|
||||
LThread.FFatalException := TObject(AcquireExceptionObject);
|
||||
// not sure if we should really do this...
|
||||
// but .Destroy was called, so why not try FreeOnTerminate?
|
||||
if e is EThreadDestroyCalled then LThread.FFreeOnTerminate := true;
|
||||
end;
|
||||
end;
|
||||
WRITE_DEBUG('thread done running');
|
||||
Result := LThread.FReturnValue;
|
||||
WRITE_DEBUG('Result is ',Result);
|
||||
LThread.FFinished := True;
|
||||
LThread.DoTerminate;
|
||||
if LThread.FreeOnTerminate then begin
|
||||
WRITE_DEBUG('Thread should be freed');
|
||||
LThread.Free;
|
||||
WRITE_DEBUG('Thread freed');
|
||||
end;
|
||||
WRITE_DEBUG('thread func exiting');
|
||||
end;
|
||||
|
||||
{ TThread }
|
||||
constructor TThread.Create(CreateSuspended: Boolean);
|
||||
begin
|
||||
// lets just hope that the user doesn't create a thread
|
||||
// via BeginThread and creates the first TThread Object in there!
|
||||
InitThreads;
|
||||
inherited Create;
|
||||
FSem := SemaphoreInit;
|
||||
FSuspended := CreateSuspended;
|
||||
FSuspendedExternal := false;
|
||||
FInitialSuspended := CreateSuspended;
|
||||
FFatalException := nil;
|
||||
WRITE_DEBUG('creating thread, self = ',longint(self));
|
||||
FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID);
|
||||
WRITE_DEBUG('TThread.Create done');
|
||||
end;
|
||||
|
||||
|
||||
destructor TThread.Destroy;
|
||||
begin
|
||||
if FThreadID = GetCurrentThreadID then begin
|
||||
raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!');
|
||||
end;
|
||||
// if someone calls .Free on a thread with
|
||||
// FreeOnTerminate, then don't crash!
|
||||
FFreeOnTerminate := false;
|
||||
if not FFinished and not FSuspended then begin
|
||||
Terminate;
|
||||
WaitFor;
|
||||
end;
|
||||
if (FInitialSuspended) then begin
|
||||
// thread was created suspended but never woken up.
|
||||
SemaphorePost(FSem);
|
||||
WaitFor;
|
||||
end;
|
||||
FFatalException.Free;
|
||||
FFatalException := nil;
|
||||
SemaphoreDestroy(FSem);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TThread.SetSuspended(Value: Boolean);
|
||||
begin
|
||||
if Value <> FSuspended then
|
||||
if Value then
|
||||
Suspend
|
||||
else
|
||||
Resume;
|
||||
end;
|
||||
|
||||
procedure TThread.Suspend;
|
||||
begin
|
||||
if not FSuspended then begin
|
||||
if FThreadID = GetCurrentThreadID then begin
|
||||
FSuspended := true;
|
||||
SemaphoreWait(FSem);
|
||||
end else begin
|
||||
FSuspendedExternal := true;
|
||||
{$IFDEF LINUX}
|
||||
// naughty hack if the user doesn't have Linux with NPTL...
|
||||
// in that case, the PID of threads will not be identical
|
||||
// to the other threads, which means that our thread is a normal
|
||||
// process that we can suspend via SIGSTOP...
|
||||
// this violates POSIX, but is the way it works on the
|
||||
// LinuxThreads pthread implementation. Not with NPTL, but in that case
|
||||
// getpid(2) also behaves properly and returns the same PID for
|
||||
// all threads. Thats actually (FINALLY!) native thread support :-)
|
||||
if FPid <> GMainPID then begin
|
||||
FSuspended := true;
|
||||
fpkill(FPid, SIGSTOP);
|
||||
end;
|
||||
{$ELSE}
|
||||
SuspendThread(FHandle);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TThread.Resume;
|
||||
begin
|
||||
if (not FSuspendedExternal) then begin
|
||||
if FSuspended then begin
|
||||
SemaphorePost(FSem);
|
||||
FInitialSuspended := false;
|
||||
FSuspended := False;
|
||||
end;
|
||||
end else begin
|
||||
{$IFDEF LINUX}
|
||||
// see .Suspend
|
||||
if FPid <> GMainPID then begin
|
||||
fpkill(FPid, SIGCONT);
|
||||
FSuspended := False;
|
||||
end;
|
||||
{$ELSE}
|
||||
ResumeThread(FHandle);
|
||||
{$ENDIF}
|
||||
FSuspendedExternal := false;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TThread.Terminate;
|
||||
begin
|
||||
FTerminated := True;
|
||||
end;
|
||||
|
||||
function TThread.WaitFor: Integer;
|
||||
begin
|
||||
WRITE_DEBUG('waiting for thread ',FHandle);
|
||||
WaitFor := WaitForThreadTerminate(FHandle, 0);
|
||||
WRITE_DEBUG('thread terminated');
|
||||
end;
|
||||
|
||||
procedure TThread.CallOnTerminate;
|
||||
begin
|
||||
// no need to check if FOnTerminate <> nil, because
|
||||
// thats already done in DoTerminate
|
||||
FOnTerminate(self);
|
||||
end;
|
||||
|
||||
procedure TThread.DoTerminate;
|
||||
begin
|
||||
if Assigned(FOnTerminate) then
|
||||
Synchronize(@CallOnTerminate);
|
||||
end;
|
||||
|
||||
function TThread.GetPriority: TThreadPriority;
|
||||
var
|
||||
P: Integer;
|
||||
I: TThreadPriority;
|
||||
begin
|
||||
P := ThreadGetPriority(FHandle);
|
||||
Result := tpNormal;
|
||||
for I := Low(TThreadPriority) to High(TThreadPriority) do
|
||||
if Priorities[I] = P then
|
||||
Result := I;
|
||||
end;
|
||||
|
||||
procedure TThread.Synchronize(Method: TThreadMethod);
|
||||
begin
|
||||
{$TODO someone with more clue of the GUI stuff will have to do this}
|
||||
end;
|
||||
|
||||
procedure TThread.SetPriority(Value: TThreadPriority);
|
||||
begin
|
||||
ThreadSetPriority(FHandle, Priorities[Value]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2003-10-06 21:01:06 peter
|
||||
Revision 1.2 2004-01-22 13:46:14 marco
|
||||
bsd
|
||||
|
||||
Revision 1.8 2004/01/03 12:18:29 marco
|
||||
* a lot of copyright notices and CVS logs added and fixed
|
||||
|
||||
Revision 1.7 2003/11/22 11:04:08 marco
|
||||
* Johill: suspend fix
|
||||
|
||||
Revision 1.6 2003/11/19 10:12:02 marco
|
||||
* more cleanups
|
||||
|
||||
Revision 1.5 2003/11/17 10:05:51 marco
|
||||
* threads for FreeBSD. Not working tho
|
||||
|
||||
Revision 1.4 2003/11/17 08:27:49 marco
|
||||
* pthreads based ttread from Johannes Berg
|
||||
|
||||
Revision 1.3 2003/11/10 16:54:28 marco
|
||||
* new oldlinux unit. 1_0 defines killed in some former FCL parts.
|
||||
|
||||
Revision 1.2 2003/11/03 09:42:28 marco
|
||||
* Peter's Cardinal<->Longint fixes patch
|
||||
|
||||
Revision 1.1 2003/10/06 21:01:06 peter
|
||||
* moved classes unit to rtl
|
||||
|
||||
Revision 1.3 2003/10/06 17:06:55 florian
|
||||
Revision 1.9 2003/10/06 17:06:55 florian
|
||||
* applied Johannes Berg's patch for exception handling in threads
|
||||
|
||||
Revision 1.2 2002/09/07 15:15:27 peter
|
||||
Revision 1.8 2003/09/20 15:10:30 marco
|
||||
* small fixes. fcl now compiles
|
||||
|
||||
Revision 1.7 2002/12/18 20:44:36 peter
|
||||
* use fillchar to clear sigset
|
||||
|
||||
Revision 1.6 2002/09/07 15:15:27 peter
|
||||
* old logs removed and tabs fixed
|
||||
|
||||
Revision 1.1 2002/07/30 16:03:29 marco
|
||||
* Added for OpenBSD. Plain copy of NetBSD
|
||||
|
||||
}
|
||||
|
||||
@ -20,9 +20,7 @@ Uses UnixUtil,BaseUnix;
|
||||
|
||||
{ Get Types and Constants }
|
||||
{$i sysconst.inc}
|
||||
{$ifndef FPC_USE_LIBC}
|
||||
{$i systypes.inc}
|
||||
{$endif not FPC_USE_LIBC}
|
||||
|
||||
{Get error numbers, some more signal definitions and other OS dependant
|
||||
types (that are not POSIX) }
|
||||
@ -1411,7 +1409,10 @@ End.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.58 2004-01-04 21:05:01 jonas
|
||||
Revision 1.59 2004-01-22 13:46:14 marco
|
||||
bsd
|
||||
|
||||
Revision 1.58 2004/01/04 21:05:01 jonas
|
||||
* declare C-library routines as external in libc so we generate proper
|
||||
import entries for Darwin
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user