mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-14 11:09:19 +02:00
* moved more targets
This commit is contained in:
peter
parent
08d913f656
commit
69a956c5b6
@ -55,7 +55,10 @@ finalization
|
|||||||
end.
|
end.
|
||||||
{
|
{
|
||||||
$Log$
|
$Log$
|
||||||
Revision 1.2 2002-09-07 15:15:27 peter
|
Revision 1.1 2003-10-06 20:56:45 peter
|
||||||
|
* moved more targets
|
||||||
|
|
||||||
|
Revision 1.2 2002/09/07 15:15:27 peter
|
||||||
* old logs removed and tabs fixed
|
* old logs removed and tabs fixed
|
||||||
|
|
||||||
}
|
}
|
||||||
@ -55,7 +55,10 @@ finalization
|
|||||||
end.
|
end.
|
||||||
{
|
{
|
||||||
$Log$
|
$Log$
|
||||||
Revision 1.2 2002-09-07 15:15:27 peter
|
Revision 1.1 2003-10-06 20:56:45 peter
|
||||||
|
* moved more targets
|
||||||
|
|
||||||
|
Revision 1.2 2002/09/07 15:15:27 peter
|
||||||
* old logs removed and tabs fixed
|
* old logs removed and tabs fixed
|
||||||
|
|
||||||
Revision 1.1 2002/07/30 16:03:29 marco
|
Revision 1.1 2002/07/30 16:03:29 marco
|
||||||
@ -1,317 +0,0 @@
|
|||||||
{
|
|
||||||
$Id$
|
|
||||||
This file is part of the Free Component Library (FCL)
|
|
||||||
Copyright (c) 1999-2000 by Peter Vreman
|
|
||||||
|
|
||||||
Linux 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.
|
|
||||||
|
|
||||||
**********************************************************************}
|
|
||||||
|
|
||||||
type
|
|
||||||
PThreadRec=^TThreadRec;
|
|
||||||
TThreadRec=record
|
|
||||||
thread : TThread;
|
|
||||||
next : PThreadRec;
|
|
||||||
end;
|
|
||||||
|
|
||||||
var
|
|
||||||
ThreadRoot : PThreadRec;
|
|
||||||
ThreadsInited : boolean;
|
|
||||||
// MainThreadID: longint;
|
|
||||||
|
|
||||||
Const
|
|
||||||
ThreadCount: longint = 0;
|
|
||||||
|
|
||||||
function ThreadSelf:TThread;
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
sp : longint;
|
|
||||||
begin
|
|
||||||
sp:=SPtr;
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
while assigned(hp) do
|
|
||||||
begin
|
|
||||||
if (sp<=hp^.Thread.FStackPointer) and
|
|
||||||
(sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then
|
|
||||||
begin
|
|
||||||
Result:=hp^.Thread;
|
|
||||||
exit;
|
|
||||||
end;
|
|
||||||
hp:=hp^.next;
|
|
||||||
end;
|
|
||||||
Result:=nil;
|
|
||||||
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);
|
|
||||||
end;
|
|
||||||
|
|
||||||
Const sigzero : sigset_t = (0,0,0,0); //Do not block all signals ??. Don't need if SA_NOMASK in flags
|
|
||||||
|
|
||||||
procedure InitThreads;
|
|
||||||
var
|
|
||||||
Act, OldAct: PSigActionRec;
|
|
||||||
begin
|
|
||||||
ThreadRoot:=nil;
|
|
||||||
ThreadsInited:=true;
|
|
||||||
|
|
||||||
|
|
||||||
// This will install SIGCHLD signal handler
|
|
||||||
// signal() installs "one-shot" handler,
|
|
||||||
// so it is better to install and set up handler with sigaction()
|
|
||||||
|
|
||||||
GetMem(Act, SizeOf(SigActionRec));
|
|
||||||
GetMem(OldAct, SizeOf(SigActionRec));
|
|
||||||
|
|
||||||
{$ifdef ver1_0}
|
|
||||||
Act^.handler.sh := @SIGCHLDHandler;
|
|
||||||
{$else}
|
|
||||||
Act^.sa_handler := @SIGCHLDHandler;
|
|
||||||
{$endif}
|
|
||||||
|
|
||||||
Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART};
|
|
||||||
|
|
||||||
{$ifdef VER1_0}
|
|
||||||
Act^.sa_mask[0] := 0; //Do not block all signals ??. Don't need if SA_NOMASK in flags
|
|
||||||
{$else}
|
|
||||||
Act^.sa_mask := sigzero;
|
|
||||||
{$endif}
|
|
||||||
SigAction(SIGCHLD, Act, OldAct);
|
|
||||||
|
|
||||||
FreeMem(Act, SizeOf(SigActionRec));
|
|
||||||
FreeMem(OldAct, SizeOf(SigActionRec));
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure DoneThreads;
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
while assigned(ThreadRoot) do
|
|
||||||
begin
|
|
||||||
ThreadRoot^.Thread.Destroy;
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
ThreadRoot:=ThreadRoot^.Next;
|
|
||||||
dispose(hp);
|
|
||||||
end;
|
|
||||||
ThreadsInited:=false;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure AddThread(t:TThread);
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
{ Need to initialize threads ? }
|
|
||||||
if not ThreadsInited then
|
|
||||||
InitThreads;
|
|
||||||
|
|
||||||
{ Put thread in the linked list }
|
|
||||||
new(hp);
|
|
||||||
hp^.Thread:=t;
|
|
||||||
hp^.next:=ThreadRoot;
|
|
||||||
ThreadRoot:=hp;
|
|
||||||
|
|
||||||
inc(ThreadCount, 1);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure RemoveThread(t:TThread);
|
|
||||||
var
|
|
||||||
lasthp,hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
lasthp:=nil;
|
|
||||||
while assigned(hp) do
|
|
||||||
begin
|
|
||||||
if hp^.Thread=t then
|
|
||||||
begin
|
|
||||||
if assigned(lasthp) then
|
|
||||||
lasthp^.next:=hp^.next
|
|
||||||
else
|
|
||||||
ThreadRoot:=hp^.next;
|
|
||||||
dispose(hp);
|
|
||||||
exit;
|
|
||||||
end;
|
|
||||||
lasthp:=hp;
|
|
||||||
hp:=hp^.next;
|
|
||||||
end;
|
|
||||||
|
|
||||||
Dec(ThreadCount, 1);
|
|
||||||
if ThreadCount = 0 then DoneThreads;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
{ TThread }
|
|
||||||
function ThreadProc(args:pointer): Integer;cdecl;
|
|
||||||
var
|
|
||||||
FreeThread: Boolean;
|
|
||||||
Thread : TThread absolute args;
|
|
||||||
begin
|
|
||||||
try
|
|
||||||
Thread.Execute;
|
|
||||||
except
|
|
||||||
Thread.FFatalException := TObject(AcquireExceptionObject);
|
|
||||||
end;
|
|
||||||
FreeThread := Thread.FFreeOnTerminate;
|
|
||||||
Result := Thread.FReturnValue;
|
|
||||||
Thread.FFinished := True;
|
|
||||||
Thread.DoTerminate;
|
|
||||||
if FreeThread then
|
|
||||||
Thread.Free;
|
|
||||||
ExitProcess(Result);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
constructor TThread.Create(CreateSuspended: Boolean);
|
|
||||||
var
|
|
||||||
Flags: Integer;
|
|
||||||
begin
|
|
||||||
inherited Create;
|
|
||||||
AddThread(self);
|
|
||||||
FSuspended := CreateSuspended;
|
|
||||||
Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
|
|
||||||
{ Setup 16k of stack }
|
|
||||||
FStackSize:=16384;
|
|
||||||
Getmem(pointer(FStackPointer),FStackSize);
|
|
||||||
inc(FStackPointer,FStackSize);
|
|
||||||
FCallExitProcess:=false;
|
|
||||||
{ Clone }
|
|
||||||
FHandle:= Clone(@ThreadProc,pointer(FStackPointer),Flags,self);
|
|
||||||
if FSuspended then Suspend;
|
|
||||||
FThreadID := FHandle;
|
|
||||||
IsMultiThread := TRUE;
|
|
||||||
FFatalException := nil;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
destructor TThread.Destroy;
|
|
||||||
begin
|
|
||||||
if not FFinished and not Suspended then
|
|
||||||
begin
|
|
||||||
Terminate;
|
|
||||||
WaitFor;
|
|
||||||
end;
|
|
||||||
if FHandle <> -1 then
|
|
||||||
Kill(FHandle, SIGKILL);
|
|
||||||
dec(FStackPointer,FStackSize);
|
|
||||||
Freemem(pointer(FStackPointer),FStackSize);
|
|
||||||
FFatalException.Free;
|
|
||||||
FFatalException := nil;
|
|
||||||
inherited Destroy;
|
|
||||||
RemoveThread(self);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.CallOnTerminate;
|
|
||||||
begin
|
|
||||||
FOnTerminate(Self);
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TThread.DoTerminate;
|
|
||||||
begin
|
|
||||||
if Assigned(FOnTerminate) then
|
|
||||||
Synchronize(@CallOnTerminate);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
const
|
|
||||||
{ I Don't know idle or timecritical, value is also 20, so the largest other
|
|
||||||
possibility is 19 (PFV) }
|
|
||||||
Priorities: array [TThreadPriority] of Integer =
|
|
||||||
(-20,-19,-10,9,10,19,20);
|
|
||||||
|
|
||||||
function TThread.GetPriority: TThreadPriority;
|
|
||||||
var
|
|
||||||
P: Integer;
|
|
||||||
I: TThreadPriority;
|
|
||||||
begin
|
|
||||||
P := {$ifdef ver1_0}Linux{$else}Unix{$endif}.GetPriority(Prio_Process,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
|
|
||||||
{$ifdef ver1_0}Linux{$else}Unix{$endif}.SetPriority(Prio_Process,FHandle, Priorities[Value]);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Synchronize(Method: TThreadMethod);
|
|
||||||
begin
|
|
||||||
FSynchronizeException := nil;
|
|
||||||
FMethod := Method;
|
|
||||||
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
|
|
||||||
if Assigned(FSynchronizeException) then
|
|
||||||
raise FSynchronizeException;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.SetSuspended(Value: Boolean);
|
|
||||||
begin
|
|
||||||
if Value <> FSuspended then
|
|
||||||
if Value then
|
|
||||||
Suspend
|
|
||||||
else
|
|
||||||
Resume;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Suspend;
|
|
||||||
begin
|
|
||||||
Kill(FHandle, SIGSTOP);
|
|
||||||
FSuspended := true;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Resume;
|
|
||||||
begin
|
|
||||||
Kill(FHandle, SIGCONT);
|
|
||||||
FSuspended := False;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Terminate;
|
|
||||||
begin
|
|
||||||
FTerminated := True;
|
|
||||||
end;
|
|
||||||
|
|
||||||
function TThread.WaitFor: Integer;
|
|
||||||
var
|
|
||||||
status : longint;
|
|
||||||
begin
|
|
||||||
if FThreadID = MainThreadID then
|
|
||||||
WaitPid(0,@status,0)
|
|
||||||
else
|
|
||||||
WaitPid(FHandle,@status,0);
|
|
||||||
Result:=status;
|
|
||||||
end;
|
|
||||||
|
|
||||||
{
|
|
||||||
$Log$
|
|
||||||
Revision 1.6 2003-10-06 17:06:55 florian
|
|
||||||
* applied Johannes Berg's patch for exception handling in threads
|
|
||||||
|
|
||||||
Revision 1.5 2003/01/31 14:49:56 pierre
|
|
||||||
* adapt 1.0 to change in signal.inc
|
|
||||||
|
|
||||||
Revision 1.4 2003/01/24 21:13:31 marco
|
|
||||||
* More bugs, but now gmake all works.
|
|
||||||
|
|
||||||
Revision 1.3 2002/09/07 15:15:27 peter
|
|
||||||
* old logs removed and tabs fixed
|
|
||||||
|
|
||||||
}
|
|
||||||
@ -1,47 +0,0 @@
|
|||||||
{
|
|
||||||
$Id$
|
|
||||||
This file is part of the Free Component Library (FCL)
|
|
||||||
Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
|
|
||||||
|
|
||||||
Classes unit for win32
|
|
||||||
|
|
||||||
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.
|
|
||||||
|
|
||||||
**********************************************************************}
|
|
||||||
|
|
||||||
{$mode objfpc}
|
|
||||||
|
|
||||||
{ determine the type of the resource/form file }
|
|
||||||
{$define Win16Res}
|
|
||||||
|
|
||||||
unit Classes;
|
|
||||||
|
|
||||||
interface
|
|
||||||
|
|
||||||
uses
|
|
||||||
sysutils,
|
|
||||||
typinfo,
|
|
||||||
systhrds;
|
|
||||||
|
|
||||||
{$i classesh.inc}
|
|
||||||
|
|
||||||
implementation
|
|
||||||
|
|
||||||
{ OS - independent class implementations are in /inc directory. }
|
|
||||||
{$i classes.inc}
|
|
||||||
|
|
||||||
end.
|
|
||||||
{
|
|
||||||
$Log$
|
|
||||||
Revision 1.1 2003-03-25 17:56:19 armin
|
|
||||||
* first fcl implementation for netware
|
|
||||||
|
|
||||||
Revision 1.3 2002/09/07 15:15:28 peter
|
|
||||||
* old logs removed and tabs fixed
|
|
||||||
|
|
||||||
}
|
|
||||||
@ -1,278 +0,0 @@
|
|||||||
{
|
|
||||||
$Id$
|
|
||||||
This file is part of the Free Component Library (FCL)
|
|
||||||
Copyright (c) 1999-2003 by the Free Pascal development team
|
|
||||||
|
|
||||||
Netware 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.
|
|
||||||
|
|
||||||
**********************************************************************}
|
|
||||||
|
|
||||||
|
|
||||||
type
|
|
||||||
PThreadRec=^TThreadRec;
|
|
||||||
TThreadRec=record
|
|
||||||
thread : TThread;
|
|
||||||
next : PThreadRec;
|
|
||||||
end;
|
|
||||||
|
|
||||||
var
|
|
||||||
ThreadRoot : PThreadRec;
|
|
||||||
ThreadsInited : boolean;
|
|
||||||
// MainThreadID: longint;
|
|
||||||
|
|
||||||
Const
|
|
||||||
ThreadCount: longint = 0;
|
|
||||||
|
|
||||||
{function ThreadSelf:TThread;
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
sp : longint;
|
|
||||||
begin
|
|
||||||
sp:=SPtr;
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
while assigned(hp) do
|
|
||||||
begin
|
|
||||||
if (sp<=hp^.Thread.FStackPointer) and
|
|
||||||
(sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then
|
|
||||||
begin
|
|
||||||
Result:=hp^.Thread;
|
|
||||||
exit;
|
|
||||||
end;
|
|
||||||
hp:=hp^.next;
|
|
||||||
end;
|
|
||||||
Result:=nil;
|
|
||||||
end;}
|
|
||||||
|
|
||||||
|
|
||||||
procedure InitThreads;
|
|
||||||
begin
|
|
||||||
ThreadRoot:=nil;
|
|
||||||
ThreadsInited:=true;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure DoneThreads;
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
while assigned(ThreadRoot) do
|
|
||||||
begin
|
|
||||||
ThreadRoot^.Thread.Destroy;
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
ThreadRoot:=ThreadRoot^.Next;
|
|
||||||
dispose(hp);
|
|
||||||
end;
|
|
||||||
ThreadsInited:=false;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure AddThread(t:TThread);
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
{ Need to initialize threads ? }
|
|
||||||
if not ThreadsInited then
|
|
||||||
InitThreads;
|
|
||||||
|
|
||||||
{ Put thread in the linked list }
|
|
||||||
new(hp);
|
|
||||||
hp^.Thread:=t;
|
|
||||||
hp^.next:=ThreadRoot;
|
|
||||||
ThreadRoot:=hp;
|
|
||||||
|
|
||||||
inc(ThreadCount, 1);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure RemoveThread(t:TThread);
|
|
||||||
var
|
|
||||||
lasthp,hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
lasthp:=nil;
|
|
||||||
while assigned(hp) do
|
|
||||||
begin
|
|
||||||
if hp^.Thread=t then
|
|
||||||
begin
|
|
||||||
if assigned(lasthp) then
|
|
||||||
lasthp^.next:=hp^.next
|
|
||||||
else
|
|
||||||
ThreadRoot:=hp^.next;
|
|
||||||
dispose(hp);
|
|
||||||
exit;
|
|
||||||
end;
|
|
||||||
lasthp:=hp;
|
|
||||||
hp:=hp^.next;
|
|
||||||
end;
|
|
||||||
|
|
||||||
Dec(ThreadCount, 1);
|
|
||||||
if ThreadCount = 0 then DoneThreads;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
{ TThread }
|
|
||||||
function ThreadProc(args:pointer): Integer;cdecl;
|
|
||||||
var
|
|
||||||
FreeThread: Boolean;
|
|
||||||
Thread : TThread absolute args;
|
|
||||||
begin
|
|
||||||
try
|
|
||||||
Thread.Execute;
|
|
||||||
except
|
|
||||||
Thread.FFatalException := TObject(AcquireExceptionObject);
|
|
||||||
end;
|
|
||||||
FreeThread := Thread.FFreeOnTerminate;
|
|
||||||
Result := Thread.FReturnValue;
|
|
||||||
Thread.FFinished := True;
|
|
||||||
Thread.DoTerminate;
|
|
||||||
if FreeThread then
|
|
||||||
Thread.Free;
|
|
||||||
EndThread(Result);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
constructor TThread.Create(CreateSuspended: Boolean);
|
|
||||||
var
|
|
||||||
Flags: Integer;
|
|
||||||
begin
|
|
||||||
inherited Create;
|
|
||||||
AddThread(self);
|
|
||||||
FSuspended := CreateSuspended;
|
|
||||||
{ Create new thread }
|
|
||||||
FHandle := BeginThread (@ThreadProc,self);
|
|
||||||
if FSuspended then Suspend;
|
|
||||||
FThreadID := FHandle;
|
|
||||||
//IsMultiThread := TRUE; {already set by systhrds}
|
|
||||||
FFatalException := nil;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
destructor TThread.Destroy;
|
|
||||||
begin
|
|
||||||
if not FFinished {and not Suspended} then
|
|
||||||
begin
|
|
||||||
if Suspended then ResumeThread (FHandle); {netware can not kill a thread}
|
|
||||||
Terminate;
|
|
||||||
WaitFor;
|
|
||||||
end;
|
|
||||||
if FHandle <> -1 then
|
|
||||||
KillThread (FHandle); {something went wrong, kill the thread (not possible on netware)}
|
|
||||||
FFatalException.Free;
|
|
||||||
FFatalException := nil;
|
|
||||||
inherited Destroy;
|
|
||||||
RemoveThread(self);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.CallOnTerminate;
|
|
||||||
begin
|
|
||||||
FOnTerminate(Self);
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TThread.DoTerminate;
|
|
||||||
begin
|
|
||||||
if Assigned(FOnTerminate) then
|
|
||||||
Synchronize(@CallOnTerminate);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
const
|
|
||||||
Priorities: array [TThreadPriority] of Integer =
|
|
||||||
(THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
|
|
||||||
THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
|
|
||||||
THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
|
|
||||||
|
|
||||||
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;
|
|
||||||
|
|
||||||
{does not make sense for netware}
|
|
||||||
procedure TThread.Synchronize(Method: TThreadMethod);
|
|
||||||
begin
|
|
||||||
{$ifndef netware}
|
|
||||||
FSynchronizeException := nil;
|
|
||||||
FMethod := Method;
|
|
||||||
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
|
|
||||||
{$warning Synchronize needs implementation}
|
|
||||||
if Assigned(FSynchronizeException) then
|
|
||||||
raise FSynchronizeException;
|
|
||||||
{$endif}
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.SetSuspended(Value: Boolean);
|
|
||||||
begin
|
|
||||||
if Value <> FSuspended then
|
|
||||||
if Value then
|
|
||||||
Suspend
|
|
||||||
else
|
|
||||||
Resume;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Suspend;
|
|
||||||
begin
|
|
||||||
SuspendThread (FHandle);
|
|
||||||
FSuspended := true;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Resume;
|
|
||||||
begin
|
|
||||||
ResumeThread (FHandle);
|
|
||||||
FSuspended := False;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Terminate;
|
|
||||||
begin
|
|
||||||
FTerminated := True;
|
|
||||||
ThreadSwitch;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
function TThread.WaitFor: Integer;
|
|
||||||
begin
|
|
||||||
Result := WaitForThreadTerminate (FHandle,0);
|
|
||||||
if Result = 0 then
|
|
||||||
FHandle := -1;
|
|
||||||
end;
|
|
||||||
|
|
||||||
{
|
|
||||||
$Log$
|
|
||||||
Revision 1.3 2003-10-06 17:06:55 florian
|
|
||||||
* applied Johannes Berg's patch for exception handling in threads
|
|
||||||
|
|
||||||
Revision 1.2 2003/03/27 17:14:27 armin
|
|
||||||
* more platform independent thread routines, needs to be implemented for unix
|
|
||||||
|
|
||||||
Revision 1.1 2003/03/25 17:56:19 armin
|
|
||||||
* first fcl implementation for netware
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
}
|
|
||||||
@ -1,303 +0,0 @@
|
|||||||
{
|
|
||||||
$Id$
|
|
||||||
This file is part of the Free Component Library (FCL)
|
|
||||||
Copyright (c) 1999-2000 by Peter Vreman
|
|
||||||
|
|
||||||
Linux 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.
|
|
||||||
|
|
||||||
**********************************************************************}
|
|
||||||
|
|
||||||
type
|
|
||||||
PThreadRec=^TThreadRec;
|
|
||||||
TThreadRec=record
|
|
||||||
thread : TThread;
|
|
||||||
next : PThreadRec;
|
|
||||||
end;
|
|
||||||
|
|
||||||
var
|
|
||||||
ThreadRoot : PThreadRec;
|
|
||||||
ThreadsInited : boolean;
|
|
||||||
// MainThreadID: longint;
|
|
||||||
|
|
||||||
Const
|
|
||||||
ThreadCount: longint = 0;
|
|
||||||
|
|
||||||
function ThreadSelf:TThread;
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
sp : longint;
|
|
||||||
begin
|
|
||||||
sp:=SPtr;
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
while assigned(hp) do
|
|
||||||
begin
|
|
||||||
if (sp<=hp^.Thread.FStackPointer) and
|
|
||||||
(sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then
|
|
||||||
begin
|
|
||||||
Result:=hp^.Thread;
|
|
||||||
exit;
|
|
||||||
end;
|
|
||||||
hp:=hp^.next;
|
|
||||||
end;
|
|
||||||
Result:=nil;
|
|
||||||
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);
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure InitThreads;
|
|
||||||
var
|
|
||||||
Act, OldAct: PSigActionRec;
|
|
||||||
begin
|
|
||||||
ThreadRoot:=nil;
|
|
||||||
ThreadsInited:=true;
|
|
||||||
|
|
||||||
|
|
||||||
// This will install SIGCHLD signal handler
|
|
||||||
// signal() installs "one-shot" handler,
|
|
||||||
// so it is better to install and set up handler with sigaction()
|
|
||||||
|
|
||||||
GetMem(Act, SizeOf(SigActionRec));
|
|
||||||
GetMem(OldAct, SizeOf(SigActionRec));
|
|
||||||
|
|
||||||
Act^.handler.sh := @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);
|
|
||||||
|
|
||||||
FreeMem(Act, SizeOf(SigActionRec));
|
|
||||||
FreeMem(OldAct, SizeOf(SigActionRec));
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure DoneThreads;
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
while assigned(ThreadRoot) do
|
|
||||||
begin
|
|
||||||
ThreadRoot^.Thread.Destroy;
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
ThreadRoot:=ThreadRoot^.Next;
|
|
||||||
dispose(hp);
|
|
||||||
end;
|
|
||||||
ThreadsInited:=false;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure AddThread(t:TThread);
|
|
||||||
var
|
|
||||||
hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
{ Need to initialize threads ? }
|
|
||||||
if not ThreadsInited then
|
|
||||||
InitThreads;
|
|
||||||
|
|
||||||
{ Put thread in the linked list }
|
|
||||||
new(hp);
|
|
||||||
hp^.Thread:=t;
|
|
||||||
hp^.next:=ThreadRoot;
|
|
||||||
ThreadRoot:=hp;
|
|
||||||
|
|
||||||
inc(ThreadCount, 1);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure RemoveThread(t:TThread);
|
|
||||||
var
|
|
||||||
lasthp,hp : PThreadRec;
|
|
||||||
begin
|
|
||||||
hp:=ThreadRoot;
|
|
||||||
lasthp:=nil;
|
|
||||||
while assigned(hp) do
|
|
||||||
begin
|
|
||||||
if hp^.Thread=t then
|
|
||||||
begin
|
|
||||||
if assigned(lasthp) then
|
|
||||||
lasthp^.next:=hp^.next
|
|
||||||
else
|
|
||||||
ThreadRoot:=hp^.next;
|
|
||||||
dispose(hp);
|
|
||||||
exit;
|
|
||||||
end;
|
|
||||||
lasthp:=hp;
|
|
||||||
hp:=hp^.next;
|
|
||||||
end;
|
|
||||||
|
|
||||||
Dec(ThreadCount, 1);
|
|
||||||
if ThreadCount = 0 then DoneThreads;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
{ TThread }
|
|
||||||
function ThreadProc(args:pointer): Integer;cdecl;
|
|
||||||
var
|
|
||||||
FreeThread: Boolean;
|
|
||||||
Thread : TThread absolute args;
|
|
||||||
begin
|
|
||||||
try
|
|
||||||
Thread.Execute;
|
|
||||||
except
|
|
||||||
Thread.FFatalException := TObject(AcquireExceptionObject);
|
|
||||||
end;
|
|
||||||
FreeThread := Thread.FFreeOnTerminate;
|
|
||||||
Result := Thread.FReturnValue;
|
|
||||||
Thread.FFinished := True;
|
|
||||||
Thread.DoTerminate;
|
|
||||||
if FreeThread then
|
|
||||||
Thread.Free;
|
|
||||||
ExitProcess(Result);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
constructor TThread.Create(CreateSuspended: Boolean);
|
|
||||||
var
|
|
||||||
Flags: Integer;
|
|
||||||
begin
|
|
||||||
inherited Create;
|
|
||||||
AddThread(self);
|
|
||||||
FSuspended := CreateSuspended;
|
|
||||||
Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
|
|
||||||
{ Setup 16k of stack }
|
|
||||||
FStackSize:=16384;
|
|
||||||
Getmem(pointer(FStackPointer),FStackSize);
|
|
||||||
inc(FStackPointer,FStackSize);
|
|
||||||
FCallExitProcess:=false;
|
|
||||||
{ Clone }
|
|
||||||
FHandle:= Clone(@ThreadProc,pointer(FStackPointer),Flags,self);
|
|
||||||
if FSuspended then Suspend;
|
|
||||||
FThreadID := FHandle;
|
|
||||||
IsMultiThread := TRUE;
|
|
||||||
FFatalException := nil;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
destructor TThread.Destroy;
|
|
||||||
begin
|
|
||||||
if not FFinished and not Suspended then
|
|
||||||
begin
|
|
||||||
Terminate;
|
|
||||||
WaitFor;
|
|
||||||
end;
|
|
||||||
if FHandle <> -1 then
|
|
||||||
Kill(FHandle, SIGKILL);
|
|
||||||
dec(FStackPointer,FStackSize);
|
|
||||||
Freemem(pointer(FStackPointer),FStackSize);
|
|
||||||
FFatalException.Free;
|
|
||||||
FFatalException := nil;
|
|
||||||
inherited Destroy;
|
|
||||||
RemoveThread(self);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.CallOnTerminate;
|
|
||||||
begin
|
|
||||||
FOnTerminate(Self);
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TThread.DoTerminate;
|
|
||||||
begin
|
|
||||||
if Assigned(FOnTerminate) then
|
|
||||||
Synchronize(@CallOnTerminate);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
const
|
|
||||||
{ I Don't know idle or timecritical, value is also 20, so the largest other
|
|
||||||
possibility is 19 (PFV) }
|
|
||||||
Priorities: array [TThreadPriority] of Integer =
|
|
||||||
(-20,-19,-10,9,10,19,20);
|
|
||||||
|
|
||||||
function TThread.GetPriority: TThreadPriority;
|
|
||||||
var
|
|
||||||
P: Integer;
|
|
||||||
I: TThreadPriority;
|
|
||||||
begin
|
|
||||||
P := {$ifdef ver1_0}Linux{$else}Unix{$endif}.GetPriority(Prio_Process,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
|
|
||||||
{$ifdef ver1_0}Linux{$else}Unix{$endif}.SetPriority(Prio_Process,FHandle, Priorities[Value]);
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Synchronize(Method: TThreadMethod);
|
|
||||||
begin
|
|
||||||
FSynchronizeException := nil;
|
|
||||||
FMethod := Method;
|
|
||||||
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
|
|
||||||
if Assigned(FSynchronizeException) then
|
|
||||||
raise FSynchronizeException;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.SetSuspended(Value: Boolean);
|
|
||||||
begin
|
|
||||||
if Value <> FSuspended then
|
|
||||||
if Value then
|
|
||||||
Suspend
|
|
||||||
else
|
|
||||||
Resume;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Suspend;
|
|
||||||
begin
|
|
||||||
Kill(FHandle, SIGSTOP);
|
|
||||||
FSuspended := true;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Resume;
|
|
||||||
begin
|
|
||||||
Kill(FHandle, SIGCONT);
|
|
||||||
FSuspended := False;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
procedure TThread.Terminate;
|
|
||||||
begin
|
|
||||||
FTerminated := True;
|
|
||||||
end;
|
|
||||||
|
|
||||||
function TThread.WaitFor: Integer;
|
|
||||||
var
|
|
||||||
status : longint;
|
|
||||||
begin
|
|
||||||
if FThreadID = MainThreadID then
|
|
||||||
WaitPid(0,@status,0)
|
|
||||||
else
|
|
||||||
WaitPid(FHandle,@status,0);
|
|
||||||
Result:=status;
|
|
||||||
end;
|
|
||||||
|
|
||||||
{
|
|
||||||
$Log$
|
|
||||||
Revision 1.3 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
|
|
||||||
* old logs removed and tabs fixed
|
|
||||||
|
|
||||||
Revision 1.1 2002/07/30 16:03:29 marco
|
|
||||||
* Added for OpenBSD. Plain copy of NetBSD
|
|
||||||
|
|
||||||
}
|
|
||||||
Loading…
Reference in New Issue
Block a user