diff --git a/.gitattributes b/.gitattributes index db5e212388..4065ca8efe 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/rtl/aros/arosthreads.inc b/rtl/aros/arosthreads.inc new file mode 100644 index 0000000000..fc8b6295d1 --- /dev/null +++ b/rtl/aros/arosthreads.inc @@ -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} + diff --git a/rtl/aros/doslibd.inc b/rtl/aros/doslibd.inc index e8cacf22f5..8e01a3c23b 100644 --- a/rtl/aros/doslibd.inc +++ b/rtl/aros/doslibd.inc @@ -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; diff --git a/rtl/aros/i386/execd.inc b/rtl/aros/i386/execd.inc index 1b10d33b8f..c7a00ee80b 100644 --- a/rtl/aros/i386/execd.inc +++ b/rtl/aros/i386/execd.inc @@ -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 diff --git a/rtl/aros/system.pp b/rtl/aros/system.pp index 856226311e..2416637104 100644 --- a/rtl/aros/system.pp +++ b/rtl/aros/system.pp @@ -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); diff --git a/rtl/aros/systemthreadh.inc b/rtl/aros/systemthreadh.inc new file mode 100644 index 0000000000..139597f9cb --- /dev/null +++ b/rtl/aros/systemthreadh.inc @@ -0,0 +1,2 @@ + + diff --git a/rtl/aros/systhrd.inc b/rtl/aros/systhrd.inc new file mode 100755 index 0000000000..904d1eb617 --- /dev/null +++ b/rtl/aros/systhrd.inc @@ -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; + + + diff --git a/rtl/aros/tthread.inc b/rtl/aros/tthread.inc index cbbe3d6953..a319821d5e 100644 --- a/rtl/aros/tthread.inc +++ b/rtl/aros/tthread.inc @@ -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; - - diff --git a/rtl/objpas/classes/classesh.inc b/rtl/objpas/classes/classesh.inc index a58e137a04..b0155f9288 100644 --- a/rtl/objpas/classes/classesh.inc +++ b/rtl/objpas/classes/classesh.inc @@ -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;