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

amicommon: have a generic tthread.inc which even works, given there is a reasonably advanced ThreadManager

Browse Source 
git-svn-id: trunk@30914 -
This commit is contained in:
Károly Balogh 2015-05-25 21:06:53 +00:00
parent 45ce4538fa
commit 632c46bcb6
5 changed files with 130 additions and 316 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -8041,6 +8041,7 @@ rtl/amicommon/sysheap.inc svneol=native#text/plain
rtl/amicommon/sysos.inc svneol=native#text/plain rtl/amicommon/sysos.inc svneol=native#text/plain
rtl/amicommon/sysosh.inc svneol=native#text/plain rtl/amicommon/sysosh.inc svneol=native#text/plain
rtl/amicommon/sysutils.pp svneol=native#text/plain rtl/amicommon/sysutils.pp svneol=native#text/plain
rtl/amicommon/tthread.inc svneol=native#text/plain
rtl/amiga/Makefile svneol=native#text/plain rtl/amiga/Makefile svneol=native#text/plain
rtl/amiga/Makefile.fpc svneol=native#text/plain rtl/amiga/Makefile.fpc svneol=native#text/plain
rtl/amiga/doslibd.inc svneol=native#text/plain rtl/amiga/doslibd.inc svneol=native#text/plain
@ -8061,7 +8062,6 @@ rtl/amiga/powerpc/utild2.inc svneol=native#text/plain
rtl/amiga/powerpc/utilf.inc svneol=native#text/plain rtl/amiga/powerpc/utilf.inc svneol=native#text/plain
rtl/amiga/system.pp svneol=native#text/plain rtl/amiga/system.pp svneol=native#text/plain
rtl/amiga/timerd.inc svneol=native#text/plain rtl/amiga/timerd.inc svneol=native#text/plain
rtl/amiga/tthread.inc svneol=native#text/plain
rtl/android/Makefile svneol=native#text/plain rtl/android/Makefile svneol=native#text/plain
rtl/android/Makefile.fpc svneol=native#text/plain rtl/android/Makefile.fpc svneol=native#text/plain
rtl/android/arm/dllprt0.as svneol=native#text/plain rtl/android/arm/dllprt0.as svneol=native#text/plain
@ -8867,7 +8867,6 @@ rtl/morphos/prt0.as svneol=native#text/plain
rtl/morphos/system.pp svneol=native#text/plain rtl/morphos/system.pp svneol=native#text/plain
rtl/morphos/timerd.inc svneol=native#text/plain rtl/morphos/timerd.inc svneol=native#text/plain
rtl/morphos/timerf.inc svneol=native#text/plain rtl/morphos/timerf.inc svneol=native#text/plain
rtl/morphos/tthread.inc svneol=native#text/plain
rtl/morphos/utild1.inc svneol=native#text/plain rtl/morphos/utild1.inc svneol=native#text/plain
rtl/morphos/utild2.inc svneol=native#text/plain rtl/morphos/utild2.inc svneol=native#text/plain
rtl/morphos/utilf.inc svneol=native#text/plain rtl/morphos/utilf.inc svneol=native#text/plain

125
rtl/amicommon/tthread.inc Normal file
View File

@ -0,0 +1,125 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2015 by Karoly Balogh,
member of the Free Pascal development team.
native TThread implementation for Amiga-like systems
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.
**********************************************************************}
{ Thread management routines }
{ Based on the Win32 version, but since that mostly just wraps to a stock
ThreadManager, it was relatively straightforward to get this working,
after we had a ThreadManager (AThreads) (KB) }
procedure TThread.SysCreate(CreateSuspended: Boolean;
const StackSize: SizeUInt);
begin
FSuspended := CreateSuspended;
FInitialSuspended := CreateSuspended;
{ Always start in suspended state, will be resumed in AfterConstruction if necessary
See Mantis #16884 }
FHandle := BeginThread(nil, StackSize, @ThreadProc, pointer(self), 1{CREATE_SUSPENDED},
FThreadID);
if FHandle = TThreadID(0) then
raise EThread.CreateFmt(SThreadCreateError, ['Cannot create thread.']);
FFatalException := nil;
end;
procedure TThread.SysDestroy;
begin
if FHandle<>0 then
begin
{ Don't check Suspended. If the thread has been externally suspended (which is
deprecated and strongly discouraged), it's better to deadlock here than
to silently free the object and leave OS resources leaked. }
if not FFinished {and not Suspended} then
begin
Terminate;
{ Allow the thread function to perform the necessary cleanup. Since
we've just set Terminated flag, it won't call Execute. }
if FInitialSuspended then
Start;
WaitFor;
end;
end;
FFatalException.Free;
FFatalException := nil;
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 := GetThreadPriority(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
// SetThreadPriority(FHandle, Priorities[Value]);
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend
else
Resume;
end;
procedure TThread.Suspend;
begin
{ Unsupported, but lets have it... }
FSuspended := True;
SuspendThread(FHandle);
end;
procedure TThread.Resume;
begin
if ResumeThread(FHandle) = 1 then FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
begin
result:=WaitForThreadTerminate(FThreadID,0);
FFinished:=(result = 0);
end;

157
rtl/amiga/tthread.inc
View File

@ -1,157 +0,0 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2002 by the Free Pascal development team
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.
**********************************************************************}
{****************************************************************************}
{* TThread *}
{****************************************************************************}
{$WARNING This file is only a stub, and will not work!}
const
ThreadCount: longint = 0;
(* Implementation of exported functions *)
procedure AddThread (T: TThread);
begin
Inc (ThreadCount);
end;
procedure RemoveThread (T: TThread);
begin
Dec (ThreadCount);
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate (Self);
end;
function TThread.GetPriority: TThreadPriority;
var
{ PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;}
I: TThreadPriority;
begin
{
DosGetInfoBlocks (@PTIB, @PPIB);
with PTIB^.TIB2^ do
if Priority >= $300 then GetPriority := tpTimeCritical else
if Priority < $200 then GetPriority := tpIdle else
begin
I := Succ (Low (TThreadPriority));
while (I < High (TThreadPriority)) and
(Priority - Priorities [I] <= Priorities [Succ (I)] - Priority) do Inc (I);
GetPriority := I;
end;
}
end;
procedure TThread.SetPriority(Value: TThreadPriority);
{var
PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;}
begin
{ DosGetInfoBlocks (@PTIB, @PPIB);}
(*
PTIB^.TIB2^.Priority := Priorities [Value];
*)
{
DosSetPriority (2, High (Priorities [Value]),
Low (Priorities [Value]) - PTIB^.TIB2^.Priority, FHandle);}
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
begin
if Value then Suspend else Resume;
end;
end;
procedure TThread.DoTerminate;
begin
if Assigned (FOnTerminate) then Synchronize (@CallOnTerminate);
end;
procedure TThread.SysCreate(CreateSuspended: Boolean;
const StackSize: SizeUInt);
var
Flags: cardinal;
begin
AddThread (Self);
{
FSuspended := CreateSuspended;
Flags := dtStack_Commited;
if FSuspended then Flags := Flags or dtSuspended;
if DosCreateThread (cardinal (FThreadID), @ThreadProc, pointer (Self),
Flags, 16384) <> 0 then
begin
FFinished := true;
Destroy;
end else FHandle := FThreadID;
IsMultiThread := true;
FFatalException := nil;
}
end;
procedure TThread.SysDestroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
{
if FHandle <> -1 then DosKillThread (cardinal (FHandle));
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread (Self);
}
end;
procedure TThread.Resume;
begin
{ FSuspended := not (DosResumeThread (cardinal (FHandle)) = 0);}
end;
procedure TThread.Suspend;
begin
{ FSuspended := DosSuspendThread (cardinal (FHandle)) = 0;}
end;
procedure TThread.Terminate;
begin
FTerminated := true;
end;
function TThread.WaitFor: Integer;
var
FH: cardinal;
begin
{ WaitFor := DosWaitThread (FH, dtWait);}
end;

157
rtl/morphos/tthread.inc
View File

@ -1,157 +0,0 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2002 by the Free Pascal development team
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.
**********************************************************************}
{****************************************************************************}
{* TThread *}
{****************************************************************************}
{$WARNING This file is only a stub, and will not work!}
const
ThreadCount: longint = 0;
(* Implementation of exported functions *)
procedure AddThread (T: TThread);
begin
Inc (ThreadCount);
end;
procedure RemoveThread (T: TThread);
begin
Dec (ThreadCount);
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate (Self);
end;
function TThread.GetPriority: TThreadPriority;
var
{ PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;}
I: TThreadPriority;
begin
{
DosGetInfoBlocks (@PTIB, @PPIB);
with PTIB^.TIB2^ do
if Priority >= $300 then GetPriority := tpTimeCritical else
if Priority < $200 then GetPriority := tpIdle else
begin
I := Succ (Low (TThreadPriority));
while (I < High (TThreadPriority)) and
(Priority - Priorities [I] <= Priorities [Succ (I)] - Priority) do Inc (I);
GetPriority := I;
end;
}
end;
procedure TThread.SetPriority(Value: TThreadPriority);
{var
PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;}
begin
{ DosGetInfoBlocks (@PTIB, @PPIB);}
(*
PTIB^.TIB2^.Priority := Priorities [Value];
*)
{
DosSetPriority (2, High (Priorities [Value]),
Low (Priorities [Value]) - PTIB^.TIB2^.Priority, FHandle);}
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
begin
if Value then Suspend else Resume;
end;
end;
procedure TThread.DoTerminate;
begin
if Assigned (FOnTerminate) then Synchronize (@CallOnTerminate);
end;
procedure TThread.SysCreate(CreateSuspended: Boolean;
const StackSize: SizeUInt);
var
Flags: cardinal;
begin
AddThread (Self);
{
FSuspended := CreateSuspended;
Flags := dtStack_Commited;
if FSuspended then Flags := Flags or dtSuspended;
if DosCreateThread (cardinal (FThreadID), @ThreadProc, pointer (Self),
Flags, 16384) <> 0 then
begin
FFinished := true;
Destroy;
end else FHandle := FThreadID;
IsMultiThread := true;
FFatalException := nil;
}
end;
procedure TThread.SysDestroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
{
if FHandle <> -1 then DosKillThread (cardinal (FHandle));
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread (Self);
}
end;
procedure TThread.Resume;
begin
{ FSuspended := not (DosResumeThread (cardinal (FHandle)) = 0);}
end;
procedure TThread.Suspend;
begin
{ FSuspended := DosSuspendThread (cardinal (FHandle)) = 0;}
end;
procedure TThread.Terminate;
begin
FTerminated := true;
end;
function TThread.WaitFor: Integer;
var
FH: cardinal;
begin
{ WaitFor := DosWaitThread (FH, dtWait);}
end;

4
rtl/objpas/classes/classesh.inc
View File

@ -1641,6 +1641,10 @@ type
FSem: Pointer; FSem: Pointer;
FCond: Pointer; FCond: Pointer;
FInitialSuspended: boolean; FInitialSuspended: boolean;
{$endif}
{$if defined(amiga) or defined(morphos)}
private
FInitialSuspended: boolean;
{$endif} {$endif}
public public
constructor Create(CreateSuspended: Boolean; constructor Create(CreateSuspended: Boolean;