paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 12:49:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

AROS: introduced threading without additional library

Browse Source 
git-svn-id: trunk@28682 -
This commit is contained in:
marcus 2014-09-16 19:32:56 +00:00
parent 67aed9ac3d
commit 980abaa9ba
9 changed files with 1115 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -7925,6 +7925,7 @@ rtl/arm/thumb.inc svneol=native#text/plain
rtl/arm/thumb2.inc svneol=native#text/plain
rtl/aros/Makefile svneol=native#text/plain
rtl/aros/Makefile.fpc svneol=native#text/plain
rtl/aros/arosthreads.inc svneol=native#text/plain
rtl/aros/doslibd.inc svneol=native#text/plain
rtl/aros/i386/doslibf.inc svneol=native#text/plain
rtl/aros/i386/execd.inc svneol=native#text/plain
@ -7934,6 +7935,8 @@ rtl/aros/i386/utild1.inc svneol=native#text/plain
rtl/aros/i386/utild2.inc svneol=native#text/plain
rtl/aros/i386/utilf.inc svneol=native#text/plain
rtl/aros/system.pp svneol=native#text/plain
rtl/aros/systemthreadh.inc svneol=native#text/plain
rtl/aros/systhrd.inc svneol=native#text/plain
rtl/aros/timerd.inc svneol=native#text/plain
rtl/aros/tthread.inc svneol=native#text/plain
rtl/atari/Makefile svneol=native#text/plain

588
rtl/aros/arosthreads.inc Normal file
View File

@ -0,0 +1,588 @@
type
TThreadEntryfunction = function(data: Pointer): Pointer; cdecl;
TMutextKind = (mkExclusive, mkShared);
TAROSMutex = record
Semaphore: TSignalSemaphore;
end;
PAROSMutex = ^TAROSMutex;
TCondition = record
Lock: TSignalSemaphore;
Waiters: array of Pointer;
end;
PCondition = ^TCondition;
TAROSThread = record
Entry: TThreadEntryfunction;
Data: Pointer;
ThreadID: LongWord;
Priority: LongInt;
StackSize: LongInt;
Task: PProcess;
Lock: TSignalSemaphore;
StartupSemaphore: TSignalSemaphore;
EndCondition: PCondition;
EndMutex: PAROSMutex;
EndCount: Integer;
end;
PAROSThread = ^TAROSThread;
TAROSThreadStruct = record
MutexListSem: TSignalSemaphore;
MutexList: array of PAROSMutex;
//
ThreadListSem: TSignalSemaphore;
ThreadList: array of PAROSThread;
//
ConditionListSem: TSignalSemaphore;
ConditionList: array of PCondition;
//
ThreadMemSem: TSignalSemaphore;
EmptySemaphore: TSignalSemaphore;
//
LastThreadNum: LongWord;
end;
PAROSThreadStruct = ^TAROSThreadStruct;
var
AROSThreadStruct: PAROSThreadStruct;
function CreateNewProcTags(const Tags: array of PtrUInt): PProcess;
begin
CreateNewProcTags := CreateNewProc(@Tags[0]);
end;
// Mutexe
function CreateMutex: PAROSMutex;
var
Mutex: PAROSMutex;
Idx, i: Integer;
begin
if not Assigned(AROSThreadStruct) then
Exit;
New(Mutex);
InitSemaphore(@(Mutex^.Semaphore));
ObtainSemaphore(@(AROSThreadStruct^.MutexListSem));
Idx := -1;
for i := 0 to High(AROSThreadStruct^.MutexList) do
begin
if not Assigned(AROSThreadStruct^.MutexList[i]) then
begin
Idx := i;
Break;
end;
end;
if Idx < 0 then
begin
Idx := Length(AROSThreadStruct^.MutexList);
SetLength(AROSThreadStruct^.MutexList, Idx + 1);
end;
AROSThreadStruct^.MutexList[Idx] := Mutex;
ReleaseSemaphore(@(AROSThreadStruct^.MutexListSem));
Result := Mutex;
end;
procedure DestroyMutex(Mutex: PAROSMutex);
var
i: Integer;
begin
if not Assigned(AROSThreadStruct) then
Exit;
ObtainSemaphore(@(AROSThreadStruct^.MutexListSem));
for i := 0 to High(AROSThreadStruct^.MutexList) do
begin
if AROSThreadStruct^.MutexList[i] = Mutex then
begin
FillChar(Mutex^.Semaphore, SizeOf(TSignalSemaphore), 0);
Dispose(Mutex);
AROSThreadStruct^.MutexList[i] := nil;
end;
end;
ReleaseSemaphore(@(AROSThreadStruct^.MutexListSem));
end;
function IsValidMutex(Mutex: PAROSMutex): Boolean;
var
i: Integer;
begin
Result := False;
if not Assigned(AROSThreadStruct) then
Exit;
ObtainSemaphore(@(AROSThreadStruct^.MutexListSem));
for i := 0 to High(AROSThreadStruct^.MutexList) do
begin
if AROSThreadStruct^.MutexList[i] = Mutex then
begin
Result := True;
Break;
end;
end;
ReleaseSemaphore(@(AROSThreadStruct^.MutexListSem));
end;
procedure LockMutex(Mutex: PAROSMutex);
begin
if IsValidMutex(Mutex) then
begin
ObtainSemaphore(@(Mutex^.Semaphore));
end;
end;
function TryLockMutex(Mutex: PAROSMutex): Boolean;
begin
Result := False;
if IsValidMutex(Mutex) then
begin
Result := AttemptSemaphore(@(Mutex^.Semaphore)) <> 0;
end;
end;
procedure UnLockMutex(Mutex: PAROSMutex);
begin
if IsValidMutex(Mutex) then
begin
ReleaseSemaphore(@(Mutex^.Semaphore));
end;
end;
// Conditions
function CreateCondition: PCondition;
var
Idx, i: Integer;
NewCond: PCondition;
begin
if not Assigned(AROSThreadStruct) then
Exit;
New(NewCond);
SetLength(NewCond^.Waiters, 0);
InitSemaphore(@(NewCond^.Lock));
ObtainSemaphore(@(AROSThreadStruct^.ConditionListSem));
Idx := -1;
for i := 0 to High(AROSThreadStruct^.ConditionList) do
begin
if not Assigned(AROSThreadStruct^.ConditionList[i]) then
begin
Idx := i;
Break;
end;
end;
if Idx < 0 then
begin
Idx := Length(AROSThreadStruct^.ConditionList);
SetLength(AROSThreadStruct^.ConditionList, Idx + 1);
end;
AROSThreadStruct^.ConditionList[Idx] := NewCond;
ReleaseSemaphore(@(AROSThreadStruct^.ConditionListSem));
Result := NewCond;
end;
function DestroyCondition(Cond: PCondition): boolean;
var
Idx, i: Integer;
begin
if not Assigned(AROSThreadStruct) then
Exit;
ObtainSemaphore(@(Cond^.Lock));
if Length(Cond^.Waiters) > 0 then
begin
ReleaseSemaphore(@(Cond^.Lock));
Result := False;
Exit;
end;
ObtainSemaphore(@(AROSThreadStruct^.ConditionListSem));
Idx := -1;
for i := 0 to High(AROSThreadStruct^.ConditionList) do
begin
if AROSThreadStruct^.ConditionList[i] = Cond then
begin
AROSThreadStruct^.ConditionList[i] := nil;
Dispose(Cond);
Break;
end;
end;
ReleaseSemaphore(@(AROSThreadStruct^.ConditionListSem));
Result := True;
end;
function WaitCondition(Cond: PCondition; Mutex: PAROSMutex): boolean;
var
Idx: Integer;
begin
if (not Assigned(Cond)) or (not Assigned(Mutex)) then
begin
Result := False;
Exit;
end;
ObtainSemaphore(@Cond^.Lock);
Idx := Length(Cond^.Waiters);
SetLength(Cond^.Waiters, Idx + 1);
Cond^.Waiters[Idx] := FindTask(nil);
ReleaseSemaphore(@Cond^.Lock);
Forbid();
UnLockMutex(Mutex);
Wait(SIGF_SINGLE);
Permit();
LockMutex(Mutex);
Result := True;
end;
procedure SignalCondition(Cond: PCondition);
var
Waiter: PTask;
Idx: Integer;
begin
if not Assigned(Cond) then
Exit;
ObtainSemaphore(@Cond^.Lock);
Waiter := nil;
//debugln(' found ' + IntToStr(Cond^.Waiters.Count) + ' Waiter');
if Length(Cond^.Waiters) > 0 then
begin
Idx := High(Cond^.Waiters);
Waiter := Cond^.Waiters[Idx];
SetLength(Cond^.Waiters, Idx);
end;
ReleaseSemaphore(@Cond^.Lock);
if not Assigned(Waiter) then
begin
//debugln('Waiter not assigned');
Exit;
end;
//debugln('Signal Waiter');
Signal(Waiter, SIGF_SINGLE);
end;
procedure BroadcastCondition(Cond: PCondition);
var
Waiter: PTask;
I: Integer;
begin
if not Assigned(Cond) then
Exit;
Waiter := nil;
ObtainSemaphore(@Cond^.Lock);
for i := 0 to High(Cond^.Waiters) do
begin
Waiter := Cond^.Waiters[i];
Signal(Waiter, SIGF_SINGLE);
end;
SetLength(Cond^.Waiters, 0);
ReleaseSemaphore(@Cond^.Lock);
end;
// Threads
procedure StarterFunc; cdecl;
var
NewThread: PAROSThread;
StackMem: Pointer;
sswap: TStackSwapStruct;
Proc: PTask;
begin
Proc := FindTask(nil);
NewThread := PAROSThread(Proc^.tc_UserData);
// create New Stack
StackMem := GetMem(NewThread^.StackSize);
sswap.stk_Lower := StackMem;
sswap.stk_Upper := Pointer(PtrUInt(sswap.stk_Lower) + 256*1024);
sswap.stk_Pointer := sswap.stk_Upper;
ReleaseSemaphore(@AROSThreadStruct^.ThreadMemSem);
// semaphore against too fast startup
ReleaseSemaphore(@(NewThread^.StartupSemaphore));
// swap stack, run program, swap stack back
Stackswap(@sswap);
NewThread^.Entry(NewThread^.Data);
Stackswap(@sswap);
//debugln('5');
// Free stack memory
ObtainSemaphore(@AROSThreadStruct^.ThreadMemSem);
FreeMem(StackMem);
ReleaseSemaphore(@AROSThreadStruct^.ThreadMemSem);
// finished mark as finished
ObtainSemaphore(@NewThread^.Lock);
NewThread^.Task := nil;
ReleaseSemaphore(@NewThread^.Lock);
// tell the others we are finished!
//Debugln('wait for end ' + IntToStr(NewThread^.ThreadId));
LockMutex(NewThread^.EndMutex);
BroadcastCondition(NewThread^.EndCondition);
UnLockMutex(NewThread^.EndMutex);
//Debugln('End ' + IntToStr(NewThread^.ThreadId));
end;
procedure EmptyFunc;
begin
Delay(1);
ReleaseSemaphore(@AROSThreadStruct^.EmptySemaphore);
end;
function AROSCreateThread(Entry: TThreadEntryfunction; data: Pointer; StackSize: Integer = 262144; Priority: Integer = 0): LongWord;
var
NewThread: PAROSThread;
Idx, i: Integer;
begin
if not Assigned(AROSThreadStruct) then
Exit;
New(NewThread);
ObtainSemaphore(@AROSThreadStruct^.ThreadListSem);
Idx := -1;
for i := 0 to High(AROSThreadStruct^.ThreadList) do
begin
if not Assigned(AROSThreadStruct^.ThreadList[i]) then
begin
Idx := i;
Break;
end;
end;
if Idx < 0 then
begin
Idx := Length(AROSThreadStruct^.ThreadList);
SetLength(AROSThreadStruct^.ThreadList, Idx + 1);
end;
Inc(AROSThreadStruct^.LastThreadNum);
AROSThreadStruct^.ThreadList[Idx] := NewThread;
NewThread^.ThreadID := AROSThreadStruct^.LastThreadNum;
NewThread^.Entry := Entry;
NewThread^.Data := Data;
NewThread^.Priority := Priority;
NewThread^.StackSize := StackSize;
InitSemaphore(@(NewThread^.Lock));
InitSemaphore(@(NewThread^.StartupSemaphore));
NewThread^.EndCondition := CreateCondition;
NewThread^.EndMutex := CreateMutex;
NewThread^.EndCount := 0;
ReleaseSemaphore(@AROSThreadStruct^.ThreadListSem);
ObtainSemaphore(@AROSThreadStruct^.ThreadMemSem);
// Semaphore for too fast startup
ObtainSemaphore(@(NewThread^.StartupSemaphore));
if NewThread^.ThreadID = 1 then
begin
//debugln('make empty thread');
ObtainSemaphore(@AROSThreadStruct^.EmptySemaphore);
NewThread^.Task := CreateNewProcTags([
NP_Entry, PtrUInt(@EmptyFunc),
TAG_DONE, TAG_END]);
ObtainSemaphore(@AROSThreadStruct^.EmptySemaphore);
Delay(10);
end;
//
NewThread^.Task := CreateNewProcTags([
NP_Entry, PtrUInt(@StarterFunc),
//NP_Name, PtrUInt(PChar('Thread' + IntToStr(LastThreadNum))),
//NP_StackSize, 256 * 1024,
NP_Priority, Priority,
NP_UserData, PtrUInt(NewThread),
TAG_DONE, TAG_END]);
Result := NewThread^.ThreadID;
end;
function AROSCurrentThread: LongInt;
var
Task: PProcess;
i: Integer;
begin
Result := 0;
Task := PProcess(FindTask(nil));
ObtainSemaphore(@AROSThreadStruct^.ThreadListSem);
for i := 0 to High(AROSThreadStruct^.ThreadList) do
begin
if Assigned(AROSThreadStruct^.ThreadList[i]) then
begin
if AROSThreadStruct^.ThreadList[i]^.Task = Task then
begin
Result := AROSThreadStruct^.ThreadList[i]^.ThreadID;
Break;
end;
end;
end;
ReleaseSemaphore(@AROSThreadStruct^.ThreadListSem);
end;
function AROSWaitThread(ThreadID: LongWord): Boolean;
var
Thread: PAROSThread;
Idx, i: Integer;
begin
if not Assigned(AROSThreadStruct) then
Exit;
ObtainSemaphore(@AROSThreadStruct^.ThreadListSem);
Thread := nil;
Idx := -1;
for i := 0 to High(AROSThreadStruct^.ThreadList) do
begin
if Assigned(AROSThreadStruct^.ThreadList[i]) then
begin
if AROSThreadStruct^.ThreadList[i]^.ThreadID = ThreadID then
begin
Thread := AROSThreadStruct^.ThreadList[i];
Idx := i;
break;
end;
end;
end;
ReleaseSemaphore(@AROSThreadStruct^.ThreadListSem);
if Thread = nil then
begin
//debugln('Thread not found');
Result := False;
Exit;
end;
// check some
ObtainSemaphore(@Thread^.Lock);
// hmm thats me... I do not wait for myself
if Thread^.Task = PProcess(FindTask(nil)) then
begin
//debugln(' hmm its me :O ' + IntToStr(ThreadID));
ReleaseSemaphore(@Thread^.Lock);
Result := False;
Exit;
end;
// wait that the thread start is finished somehow ;)
ObtainSemaphore(@(Thread^.StartupSemaphore));
ReleaseSemaphore(@(Thread^.StartupSemaphore));
// check if Task is still running
if Thread^.Task <> nil then
begin
Inc(Thread^.EndCount);
ReleaseSemaphore(@Thread^.Lock);
LockMutex(Thread^.EndMutex);
//debugln(' Wait condition ' + IntToStr(ThreadID));
WaitCondition(Thread^.EndCondition, Thread^.EndMutex);
//debugln(' got condition ' + IntToStr(ThreadID));
UnlockMutex(Thread^.EndMutex);
ObtainSemaphore(@Thread^.Lock);
Dec(Thread^.EndCount);
end;
if Thread^.EndCount > 0 then
begin
ReleaseSemaphore(@Thread^.Lock);
Result := True;
Exit;
end;
if Assigned(AROSThreadStruct) then
begin
// destroy Thread
ObtainSemaphore(@AROSThreadStruct^.ThreadListSem);
AROSThreadStruct^.ThreadList[Idx] := nil;
ReleaseSemaphore(@AROSThreadStruct^.ThreadListSem);
end;
DestroyCondition(Thread^.EndCondition);
DestroyMutex(Thread^.EndMutex);
Dispose(Thread);
Result := true;
end;
function AROSCurrentThread: LongWord;
var
i: Integer;
CurTask: PProcess;
begin
if not Assigned(AROSThreadStruct) then
Exit;
Result := 0;
ObtainSemaphore(@AROSThreadStruct^.ThreadListSem);
CurTask := PProcess(FindTask(nil));
for i := 0 to High(AROSThreadStruct^.ThreadList) do
begin
if Assigned(AROSThreadStruct^.ThreadList[i]) then
begin
if AROSThreadStruct^.ThreadList[i]^.Task = CurTask then
begin
Result := AROSThreadStruct^.ThreadList[i]^.ThreadID;
Break;
end;
end;
end;
ReleaseSemaphore(@AROSThreadStruct^.ThreadListSem);
end;
procedure WaitAllThreads;
var
i: Integer;
begin
if not Assigned(AROSThreadStruct) then
Exit;
ObtainSemaphore(@AROSThreadStruct^.ThreadListSem);
i := 0;
while i <= High(AROSThreadStruct^.ThreadList) do
begin
if Assigned(AROSThreadStruct^.ThreadList[i]) then
begin
ReleaseSemaphore(@AROSThreadStruct^.ThreadListSem);
//
ObtainSemaphore(@(AROSThreadStruct^.ThreadList[i]^.StartupSemaphore));
ReleaseSemaphore(@(AROSThreadStruct^.ThreadList[i]^.StartupSemaphore));
//
AROSWaitThread(AROSThreadStruct^.ThreadList[i]^.ThreadID);
ObtainSemaphore(@AROSThreadStruct^.ThreadListSem);
end;
Inc(i);
end;
ReleaseSemaphore(@AROSThreadStruct^.ThreadListSem);
end;
{$ifdef THREAD_SYSTEM}
procedure InitThreadLib;
begin
New(AROSThreadStruct);
AROS_ThreadLib := AROSThreadStruct;
AROSThreadStruct^.LastThreadNum := 0;
InitSemaphore(@(AROSThreadStruct^.MutexListSem));
InitSemaphore(@(AROSThreadStruct^.ConditionListSem));
InitSemaphore(@(AROSThreadStruct^.ThreadListSem));
InitSemaphore(@(AROSThreadStruct^.ThreadMemSem));
InitSemaphore(@(AROSThreadStruct^.EmptySemaphore));
end;
procedure FinishThreadLib;
var
i: Integer;
begin
if not Assigned(AROSThreadStruct) then
Exit;
WaitAllThreads;
ObtainSemaphore(@AROSThreadStruct^.MutexListSem);
i := 0;
for i := 0 to High(AROSThreadStruct^.MutexList) do
begin
if Assigned(AROSThreadStruct^.MutexList[i]) then
begin
Dispose(AROSThreadStruct^.MutexList[i]);
end;
end;
ReleaseSemaphore(@AROSThreadStruct^.MutexListSem);
ObtainSemaphore(@AROSThreadStruct^.ConditionListSem);
i := 0;
for i := 0 to High(AROSThreadStruct^.ConditionList) do
begin
if Assigned(AROSThreadStruct^.ConditionList[i]) then
begin
Dispose(AROSThreadStruct^.ConditionList[i]);
end;
end;
ReleaseSemaphore(@AROSThreadStruct^.ConditionListSem);
Dispose(AROSThreadStruct);
AROSThreadStruct := nil;
AROS_ThreadLib := nil;
end;
{$endif THREAD_SYSTEM}

2
rtl/aros/doslibd.inc
View File

@ -564,7 +564,7 @@ type // Checked OK 05.08.2011 ALB
dl_NulLock : PUnit;
// LDDemon private Data
dl_LDObjectsListSigSem : TSignalSemaphore;
dl_LDObjectsList : TList;
dl_LDObjectsList : TEList;
dl_LDHandler : TInterrupt;
dl_LDDemonPort : PMsgPort;
dl_LDDemonTask : PProcess;

28
rtl/aros/i386/execd.inc
View File

@ -85,8 +85,8 @@ const // Checked OK 05.08.2011 ALB
type // Checked OK 05.08.2011 ALB
PList = ^TList;
TList = record
PList = ^TEList;
TEList = record
lh_Head : PNode;
lh_Tail : PNode;
lh_TailPred: PNode;
@ -574,7 +574,7 @@ type // Checked OK 05.08.2011 ALB
mp_Flags : Byte;
mp_SigBit : Byte;
mp_SigTask: Pointer;
mp_MsgList: TList;
mp_MsgList: TEList;
end;
@ -627,7 +627,7 @@ type
tc_SPUpper : Pointer;
tc_Switch : Pointer; { *** OBSOLETE *** }
tc_Launch : Pointer; { *** OBSOLETE *** }
tc_MemEntry : TList;
tc_MemEntry : TEList;
tc_UserData : Pointer;
end;
@ -1012,7 +1012,7 @@ type // Checked OK 05.08.2011 ALB
type // Checked OK 05.08.2011 ALB
PSoftIntList = ^TSoftIntList;
TSoftIntList = record
sh_List: TList;
sh_List: TEList;
sh_Pad : Word;
end;
@ -1566,14 +1566,14 @@ type // Checked OK 05.08.2011 ALB
// Private Lists
MemList : TList;
ResourceList: TList;
DeviceList : TList;
IntrList : TList;
LibList : TList;
PortList : TList;
TaskReady : TList;
TaskWait : TList;
MemList : TEList;
ResourceList: TEList;
DeviceList : TEList;
IntrList : TEList;
LibList : TEList;
PortList : TEList;
TaskReady : TEList;
TaskWait : TEList;
SoftInts : Array[0..4] Of TSoftIntList;
//stuff
@ -1582,7 +1582,7 @@ type // Checked OK 05.08.2011 ALB
VBlankFrequency : Byte;
PowerSupplyFrequency: Byte; // AROS PRIVATE: VBlankFreq * PowerSupplyFreq = Timer Tick Rate
SemaphoreList : TList;
SemaphoreList : TEList;
// Kickstart

11
rtl/aros/system.pp
View File

@ -25,7 +25,7 @@ interface
{$define FPC_IS_SYSTEM}
{.$define DISABLE_NO_THREAD_MANAGER}
{$define DISABLE_NO_THREAD_MANAGER}
{$I systemh.inc}
@ -63,7 +63,7 @@ var
AOS_ExecBase : Pointer; external name '_ExecBase';
AOS_DOSBase : Pointer;
AOS_UtilityBase: Pointer;
AROS_ThreadLib : Pointer = nil;
ASYS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
ASYS_origDir : LongInt; { original directory on startup }
@ -71,8 +71,6 @@ var
AOS_ConName : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
AOS_ConHandle: THandle;
AOS_ThreadBase: Pointer;
argc: LongInt;
argv: PPChar;
envp: PPChar;
@ -141,9 +139,6 @@ begin
if AOS_DOSBase<>nil then
CloseLibrary(AOS_DOSBase);
AOS_DOSBase := nil;
if AOS_ThreadBase <> nil then
CloseLibrary(AOS_ThreadBase);
AOS_ThreadBase := nil;
//
HaltProc(ExitCode);
end;
@ -399,8 +394,6 @@ begin
AOS_UtilityBase := OpenLibrary('utility.library', 0);
if AOS_UtilityBase = nil then
Halt(1);
if AOS_ThreadBase = nil then
AOS_ThreadBase := OpenLibrary('thread.library', 0);
{ Creating the memory pool for growing heap }
ASYS_heapPool := CreatePool(MEMF_ANY or MEMF_SEM_PROTECTED, growheapsize2, growheapsize1);

2
rtl/aros/systemthreadh.inc Normal file
View File

@ -0,0 +1,2 @@

359
rtl/aros/systhrd.inc Executable file
View File

@ -0,0 +1,359 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2013 by Marcus Sackrow.
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
// TThreadEntryfunction = function(data: Pointer): Pointer; cdecl;
const
threadvarblocksize : dword = 0; // total size of allocated threadvars
thredvarsmainthread: pointer = nil; // to free the threadvars in the signal handler
var
ThreadsVarList: array of Pointer;
{$define THREAD_SYSTEM}
{$I arosthreads.inc}
// Thread manager:
procedure SysInitThreadvar(var offset : dword;size : dword);
begin
//offset:=threadvarblocksize;
//inc(threadvarblocksize,size);
end;
procedure SaveThreadVars(t: Pointer);
var
Idx: Integer;
begin
{Idx := AROSCurrentThread();
if Idx >= 0 then
begin
if Idx > High(ThreadsVarList) then
SetLength(ThreadsVarList, Idx + 1);
ThreadsVarList[Idx] := t;
end;}
end;
function GetThreadV: Pointer;
var
Idx: Integer;
begin
{
Result := nil;
Idx := AROSCurrentThread();
if (Idx >= 0) and (Idx <= High(ThreadsVarList)) then
begin
Result := ThreadsVarList[Idx];
end;
}
end;
function SysRelocateThreadvar (offset: dword): Pointer;
begin
//SysRelocateThreadvar:= GetThreadV + offset;
end;
procedure SaveThreadV(t: Pointer);
var
Idx: Integer;
begin
{Idx := AROSCurrentThread();
if Idx >= 0 then
begin
if Idx > High(ThreadsVarList) then
SetLength(ThreadsVarList, Idx + 1);
ThreadsVarList[Idx] := t;
end;}
end;
procedure SysAllocateThreadVars;
var
threadvars: Pointer;
begin
{threadvars := AllocPooled(AOS_heapPool, threadvarblocksize);
FillChar(threadvars^, threadvarblocksize, 0);
SaveThreadV(threadvars);
if thredvarsmainthread = nil then
thredvarsmainthread := threadvars;}
end;
procedure SysReleaseThreadVars;
var
threadvars: Pointer;
begin
{ release thread vars }
{
if threadvarblocksize > 0 then
begin
threadvars := GetThreadV;
if threadvars <> nil then
begin
FreePooled(AOS_heapPool, threadvars, threadvarblocksize);
SaveThreadVars(nil);
end;
end;}
end;
type
TThreadInfo = record
F: TThreadfunc;
P: Pointer;
end;
PThreadinfo = ^TThreadinfo;
function ThreadFunc(Data: Pointer): Pointer; cdecl;
var
Ti: TThreadinfo;
begin
{SysAllocateThreadVars;
ti := PThreadInfo(Data)^;
Dispose(PThreadInfo(Data));
// execute
ThreadFunc := Pointer(Ti.f(Ti.p));
DoneThread;}
end;
function SysBeginThread(Sa: Pointer; StackSize: PtrUInt; ThreadFunction: TThreadfunc; p: Pointer; CreationFlags: dword; var ThreadId: TThreadID): TThreadID;
var
Ti: PThreadinfo;
begin
Result := 0;
if not IsMultiThread then
begin
InitThreadVars(@SysRelocateThreadvar);
IsMultithread:=true;
end;
New(Ti);
Ti^.f := ThreadFunction;
Ti^.p := p;
SetLength(ThreadsVarList, 200);
//SysBeginThread := CreateThread(@ThreadFunc, Ti);
ThreadID := SysBeginThread;
end;
procedure SysEndThread(ExitCode : DWord);
begin
DoneThread;
//ExitThread(Pointer(ExitCode));
end;
procedure SysThreadSwitch;
begin
Delay(0);
end;
function SysSuspendThread(ThreadHandle: THandle): dword;
begin
Result := 0;
end;
function SysResumeThread(ThreadHandle: THandle): dword;
begin
Result := 0;
end;
function SysKillThread(threadHandle: THandle): dword;
begin
SysKillThread := 0; {not supported for AROS}
end;
function SysWaitForThreadTerminate(threadHandle: THandle; TimeoutMs: LongInt): dword;
begin
Result := 0;
end;
function SysThreadSetPriority (threadHandle : THandle; Prio: longint): boolean; {-15..+15, 0=normal}
begin
SysThreadSetPriority := true;
end;
function SysThreadGetPriority (threadHandle : THandle): Longint;
begin
SysThreadGetPriority := 0;
end;
function SysGetCurrentThreadId: LongInt;
begin
SysGetCurrentThreadId := AROSCurrentThread;
end;
// Close all Semaphores
procedure SysCloseAllRemainingSemaphores;
var
i: Integer;
begin
ObtainSemaphore(@AROSThreadStruct^.MutexListSem);
i := 0;
for i := 0 to High(AROSThreadStruct^.MutexList) do
begin
if Assigned(AROSThreadStruct^.MutexList[i]) then
begin
Dispose(AROSThreadStruct^.MutexList[i]);
end;
end;
ReleaseSemaphore(@AROSThreadStruct^.MutexListSem);
end;
// Critical Sections (done by Mutex)
procedure SysInitCriticalSection(var cs: TRTLCriticalSection);
begin
cs := CreateMutex;
//DebugLn('Create Mutex');
end;
procedure SysDoneCriticalsection(var cs: TRTLCriticalSection);
begin
//DebugLn('Destroy Mutex');
if Assigned(cs) then
DestroyMutex(TRTLCriticalSection(cs));
cs := nil;
end;
procedure SysEnterCriticalsection(var cs: TRTLCriticalSection);
begin
//DebugLn('EnterMutex');
if Assigned(cs) then
LockMutex(cs);
end;
function SysTryEnterCriticalsection(var cs: TRTLCriticalSection): longint;
begin
//DebugLn('TryEnter Mutex');
Result := 0;
if Assigned(cs) then
Result := LongInt(TryLockMutex(cs));
end;
procedure SysLeaveCriticalsection(var cs: TRTLCriticalSection);
begin
//DebugLn('Leave Mutex');
if Assigned(cs) then
UnlockMutex(cs);
end;
function SysSetThreadDataAreaPtr (newPtr:pointer):pointer;
begin
end;
function intBasicEventCreate(EventAttributes : Pointer;
AManualReset,InitialState : Boolean;const Name : ansistring):pEventState;
begin
end;
procedure intbasiceventdestroy(state:peventstate);
begin
end;
procedure intbasiceventResetEvent(state:peventstate);
begin
end;
procedure intbasiceventSetEvent(state:peventstate);
begin
end;
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
begin
end;
function intRTLEventCreate: PRTLEvent;
begin
end;
procedure intRTLEventDestroy(AEvent: PRTLEvent);
begin
end;
procedure intRTLEventSetEvent(AEvent: PRTLEvent);
begin
end;
procedure intRTLEventResetEvent(AEvent: PRTLEvent);
begin
end;
procedure intRTLEventWaitFor(AEvent: PRTLEvent);
begin
end;
procedure intRTLEventWaitForTimeout(AEvent: PRTLEvent;timeout : longint);
begin
end;
function SysInitManager: Boolean;
begin
InitThreadLib;
Result := True;
end;
function SysDoneManager: Boolean;
begin
FinishThreadLib;
Result := True;
end;
Var
AROSThreadManager : TThreadManager;
procedure InitSystemThreads;
begin
with AROSThreadManager do
begin
InitManager :=@SysInitManager;
DoneManager :=@SysDoneManager;
BeginThread :=@SysBeginThread;
EndThread :=@SysEndThread;
SuspendThread :=@SysSuspendThread;
ResumeThread :=@SysResumeThread;
KillThread :=@SysKillThread;
ThreadSwitch :=@SysThreadSwitch;
WaitForThreadTerminate :=@SysWaitForThreadTerminate;
ThreadSetPriority :=@SysThreadSetPriority;
ThreadGetPriority :=@SysThreadGetPriority;
GetCurrentThreadId :=@SysGetCurrentThreadId;
InitCriticalSection :=TCriticalSectionHandler(@SysInitCriticalSection);
DoneCriticalSection :=TCriticalSectionHandler(@SysDoneCriticalSection);
EnterCriticalSection :=TCriticalSectionHandler(@SysEnterCriticalSection);
LeaveCriticalSection :=TCriticalSectionHandler(@SysLeaveCriticalSection);
InitThreadVar :=@SysInitThreadVar;
RelocateThreadVar :=@SysRelocateThreadVar;
AllocateThreadVars :=@SysAllocateThreadVars;
ReleaseThreadVars :=@SysReleaseThreadVars;
BasicEventCreate :=@intBasicEventCreate;
basiceventdestroy :=@intbasiceventdestroy;
basiceventResetEvent :=@intbasiceventResetEvent;
basiceventSetEvent :=@intbasiceventSetEvent;
basiceventWaitFor :=@intbasiceventWaitFor;
RTLEventCreate :=@intRTLEventCreate;
RTLEventDestroy :=@intRTLEventDestroy;
RTLEventSetEvent :=@intRTLEventSetEvent;
RTLEventResetEvent :=@intRTLEventResetEvent;
RTLEventWaitFor :=@intRTLEventWaitFor;
RTLEventWaitForTimeout :=@intRTLEventWaitForTimeout;
end;
SetThreadManager(AROSThreadManager);
end;

271
rtl/aros/tthread.inc
View File

@ -1,157 +1,164 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2002 by the Free Pascal development team
{$include execd.inc}
{$include execf.inc}
{$include timerd.inc}
{$include doslibd.inc}
{$include doslibf.inc}
{$include arosthreads.inc}
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;
function ThreadFunc(Data: Pointer): Pointer; cdecl;
var
{ PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;}
I: TThreadPriority;
LThread: TThread;
LFreeOnTerminate: Boolean;
ISuspended: Boolean;
begin
{
DosGetInfoBlocks (@PTIB, @PPIB);
with PTIB^.TIB2^ do
if Priority >= $300 then GetPriority := tpTimeCritical else
if Priority < $200 then GetPriority := tpIdle else
//Debugln('Enter ThreadFunc');
Result := nil;
LThread := TThread(Data);
ISuspended := LThread.FInitialSuspended;
if ISuspended then
begin
I := Succ (Low (TThreadPriority));
while (I < High (TThreadPriority)) and
(Priority - Priorities [I] <= Priorities [Succ (I)] - Priority) do Inc (I);
GetPriority := I;
if not LThread.FTerminated then
begin
LockMutex(LThread.FSem);
WaitCondition(LThread.FCond, LThread.FSem);
UnlockMutex(LThread.FSem);
end;
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
//Sleep(1);
if not LThread.FTerminated then
begin
FFinished := true;
Destroy;
end else FHandle := FThreadID;
IsMultiThread := true;
//Debugln('Execute Thread');
try
LThread.Execute;
except
on E: Exception do
begin
//DebugLn('Exception in Thread '+ e.Classname + e.MEssage);
LThread.FFatalException := TObject(AcquireExceptionObject);
if E is EThreadDestroyCalled then
LThread.FFreeOnTerminate := true;
end;
end;
//Debugln('Back from Thread');
//Sleep(1);
end;
LFreeOnTerminate := LThread.FreeOnTerminate;
LThread.DoTerminate;
LThread.FFinished := True;
if LFreeOnTerminate then
LThread.Free;
//debugln('Finished Thread?, then what to do now?')
end;
procedure TThread.SysCreate(CreateSuspended: Boolean; const StackSize: SizeUInt);
begin
if not Assigned(AROSThreadStruct) then
AROSThreadStruct := AROS_ThreadLib;
if not Assigned(AROSThreadStruct) then
raise EThread.CreateFmt(SThreadCreateError, ['ThreadLib not found']);
FSuspended := CreateSuspended;
FInitialSuspended := CreateSuspended;
// Mutex for suspend actions
FSem := CreateMutex;
FCond := CreateCondition;
FHandle := AROSCreateThread(@ThreadFunc, Self, StackSize);
FThreadID := FHandle;
if FHandle = 0 then
raise EThread.CreateFmt(SThreadCreateError, ['Cannot Create Thread']);
// exception if Thread cannot be created
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);
}
if FHandle <> 0 then
begin
if not FFinished then
begin
Terminate;
if FSuspended then
begin
SignalCondition(FCond);
Sleep(0);
end;
WaitFor;
end;
end;
FHandle := 0;
DestroyCondition(FCond);
DestroyMutex(FSem);
FFatalException := nil;
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate(Self);
end;
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then
Synchronize(@CallOnTerminate);
end;
function TThread.GetPriority: TThreadPriority;
begin
//
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
//
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend
else
Resume;
end;
procedure TThread.Suspend;
begin
if FThreadID = GetCurrentThreadID then
begin
FSuspended := True;
LockMutex(FSem);
WaitCondition(FCond, FSem);
UnlockMutex(FSem);
end else
Raise EThread.create('Suspending one thread from inside another one is unsupported (because it is unsafe and deadlock prone) by AROS');
end;
procedure TThread.Resume;
begin
{ FSuspended := not (DosResumeThread (cardinal (FHandle)) = 0);}
if FSuspended then
begin
SignalCondition(FCond);
Sleep(100);
end;
FSuspended := False;
FInitialSuspended := False;
end;
procedure TThread.Suspend;
begin
{ FSuspended := DosSuspendThread (cardinal (FHandle)) = 0;}
end;
procedure TThread.Terminate;
begin
FTerminated := true;
FTerminated := True;
end;
function TThread.WaitFor: Integer;
var
FH: cardinal;
begin
{ WaitFor := DosWaitThread (FH, dtWait);}
Result := 0;
if (not FSuspended) and (FHandle <> 0) then
begin
Sleep(1);
AROSWaitThread(FHandle);
end;
end;

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

@ -1622,6 +1622,13 @@ type
FInitialSuspended: boolean;
FSuspendedExternal: boolean;
FPid: LongInt;
{$endif}
{$ifdef aros}
private
// see tthread.inc, ThreadFunc and TThread.Resume
FSem: Pointer;
FCond: Pointer;
FInitialSuspended: boolean;
{$endif}
public
constructor Create(CreateSuspended: Boolean;