AROS: introduced threading without additional library

git-svn-id: trunk@28682 -

.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

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}
+

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;

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
     

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);

rtl/aros/systemthreadh.inc

@@ -0,0 +1,2 @@
+
+

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;
+
+
+

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
-
-    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);
+{$include execd.inc}
+{$include execf.inc}
+{$include timerd.inc}
+{$include doslibd.inc}
+{$include doslibf.inc}
+{$include arosthreads.inc}
+
+function ThreadFunc(Data: Pointer): Pointer; cdecl;
+var
+  LThread: TThread;
+  LFreeOnTerminate: Boolean;
+  ISuspended: Boolean;
 begin
- Dec (ThreadCount);
+  //Debugln('Enter ThreadFunc');
+  Result := nil;
+  LThread := TThread(Data);
+  ISuspended := LThread.FInitialSuspended;
+  if ISuspended then
+  begin
+    if not LThread.FTerminated then
+    begin
+      LockMutex(LThread.FSem);
+      WaitCondition(LThread.FCond, LThread.FSem);
+      UnlockMutex(LThread.FSem);
+    end;  
+  end;
+  //Sleep(1);
+  if not LThread.FTerminated then
+  begin
+    //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.CallOnTerminate;
+procedure TThread.SysCreate(CreateSuspended: Boolean; const StackSize: SizeUInt);
 begin
- FOnTerminate (Self);
+  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;
 
 
-function TThread.GetPriority: TThreadPriority;
-var
-{ PTIB: PThreadInfoBlock;
- PPIB: PProcessInfoBlock;}
- I: TThreadPriority;
+procedure TThread.SysDestroy;
 begin
-{
- DosGetInfoBlocks (@PTIB, @PPIB);
- with PTIB^.TIB2^ do
-  if Priority >= $300 then GetPriority := tpTimeCritical else
-      if Priority < $200 then GetPriority := tpIdle else
+  if FHandle <> 0 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 FFinished then
+    begin
+      Terminate;
+      if FSuspended then
+      begin
+        SignalCondition(FCond);
+        Sleep(0);
+      end;
+      WaitFor;
+    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);}
+  FHandle := 0;
+  DestroyCondition(FCond);
+  DestroyMutex(FSem);
+  FFatalException := nil;
 end;
 
-
-procedure TThread.SetSuspended(Value: Boolean);
+procedure TThread.CallOnTerminate;
 begin
- if Value <> FSuspended then
- begin
-  if Value then Suspend else Resume;
- end;
+  FOnTerminate(Self);
 end;
 
-
 procedure TThread.DoTerminate;
 begin
- if Assigned (FOnTerminate) then Synchronize (@CallOnTerminate);
+  if Assigned(FOnTerminate) then
+    Synchronize(@CallOnTerminate);
 end;
 
-
-procedure TThread.SysCreate(CreateSuspended: Boolean;
-                            const StackSize: SizeUInt);
-var
-  Flags: cardinal;
+function TThread.GetPriority: TThreadPriority;
 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;
+procedure TThread.SetPriority(Value: TThreadPriority);
 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;
+procedure TThread.SetSuspended(Value: Boolean);
 begin
-{ FSuspended := not (DosResumeThread (cardinal (FHandle)) = 0);}
+  if Value <> FSuspended then
+    if Value then
+      Suspend
+    else
+      Resume;
 end;
 
-
 procedure TThread.Suspend;
 begin
-{ FSuspended := DosSuspendThread (cardinal (FHandle)) = 0;}
+  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
+  if FSuspended then
+  begin
+    SignalCondition(FCond);
+    Sleep(100);
+  end;
+  FSuspended := False;
+  FInitialSuspended := False;
+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;
-
-

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;