--- Merging r30842 into '.':

U    packages/fcl-process/src/amicommon/process.inc
--- Recording mergeinfo for merge of r30842 into '.':
 U   .
--- Merging r30860 into '.':
U    packages/fcl-process/src/amicommon/simpleipc.inc
--- Recording mergeinfo for merge of r30860 into '.':
 G   .
--- Merging r30886 into '.':
U    rtl/aros/system.pp
--- Recording mergeinfo for merge of r30886 into '.':
 G   .
--- Merging r30899 into '.':
U    rtl/amiga/system.pp
U    rtl/morphos/system.pp
U    rtl/amicommon/sysfile.inc
G    rtl/aros/system.pp
--- Recording mergeinfo for merge of r30899 into '.':
 G   .
--- Merging r30901 into '.':
A    rtl/amiga/m68k/m68kamiga.inc
--- Recording mergeinfo for merge of r30901 into '.':
 G   .
--- Merging r30902 into '.':
U    rtl/amiga/m68k/m68kamiga.inc
--- Recording mergeinfo for merge of r30902 into '.':
 G   .
--- Merging r30903 into '.':
G    rtl/amiga/system.pp
U    rtl/m68k/m68k.inc
--- Recording mergeinfo for merge of r30903 into '.':
 G   .
--- Merging r30904 into '.':
D    rtl/morphos/sysosh.inc
--- Recording mergeinfo for merge of r30904 into '.':
 G   .
--- Merging r30905 into '.':
A    rtl/amicommon/athreads.pp
--- Recording mergeinfo for merge of r30905 into '.':
 G   .
--- Merging r30912 into '.':
U    rtl/amicommon/sysosh.inc
U    rtl/amicommon/athreads.pp
--- Recording mergeinfo for merge of r30912 into '.':
 G   .
--- Merging r30913 into '.':
G    rtl/amicommon/athreads.pp
--- Recording mergeinfo for merge of r30913 into '.':
 G   .
--- Merging r30914 into '.':
D    rtl/amiga/tthread.inc
U    rtl/objpas/classes/classesh.inc
A    rtl/amicommon/tthread.inc
D    rtl/morphos/tthread.inc
--- Recording mergeinfo for merge of r30914 into '.':
 G   .
--- Merging r30915 into '.':
U    packages/morphunits/src/exec.pas
--- Recording mergeinfo for merge of r30915 into '.':
 G   .
--- Merging r30916 into '.':
G    packages/morphunits/src/exec.pas
--- Recording mergeinfo for merge of r30916 into '.':
 G   .
--- Merging r30917 into '.':
U    rtl/morphos/execd.inc
--- Recording mergeinfo for merge of r30917 into '.':
 G   .
--- Merging r30921 into '.':
U    rtl/amicommon/osdebugh.inc
U    rtl/amicommon/osdebug.inc
--- Recording mergeinfo for merge of r30921 into '.':
 G   .
--- Merging r30922 into '.':
G    rtl/amicommon/athreads.pp
--- Recording mergeinfo for merge of r30922 into '.':
 G   .
--- Merging r30923 into '.':
U    rtl/amicommon/sysutils.pp
G    rtl/amicommon/sysosh.inc
U    rtl/aros/arosthreads.inc
U    rtl/aros/systhrd.inc
U    rtl/aros/i386/doslibf.inc
U    rtl/aros/i386/execf.inc
U    rtl/amiga/m68k/doslibf.inc
U    rtl/morphos/doslibf.inc
--- Recording mergeinfo for merge of r30923 into '.':
 G   .
--- Merging r30924 into '.':
G    rtl/amicommon/athreads.pp
--- Recording mergeinfo for merge of r30924 into '.':
 G   .
--- Merging r30933 into '.':
G    rtl/amicommon/athreads.pp
--- Recording mergeinfo for merge of r30933 into '.':
 G   .
--- Merging r30940 into '.':
G    rtl/amicommon/athreads.pp
--- Recording mergeinfo for merge of r30940 into '.':
 G   .

# revisions: 30842,30860,30886,30899,30901,30902,30903,30904,30905,30912,30913,30914,30915,30916,30917,30921,30922,30923,30924,30933,30940

git-svn-id: branches/fixes_3_0@31084 -

.gitattributes

@@ -7899,6 +7899,7 @@ rtl/aix/termiosproc.inc svneol=native#text/plain
 rtl/aix/unxconst.inc svneol=native#text/plain
 rtl/aix/unxfunc.inc svneol=native#text/plain
 rtl/amicommon/README.TXT svneol=native#text/plain
+rtl/amicommon/athreads.pp svneol=native#text/plain
 rtl/amicommon/classes.pp svneol=native#text/plain
 rtl/amicommon/dos.pp svneol=native#text/plain
 rtl/amicommon/osdebug.inc svneol=native#text/plain
@@ -7910,12 +7911,14 @@ rtl/amicommon/sysheap.inc svneol=native#text/plain
 rtl/amicommon/sysos.inc svneol=native#text/plain
 rtl/amicommon/sysosh.inc svneol=native#text/plain
 rtl/amicommon/sysutils.pp svneol=native#text/plain
+rtl/amicommon/tthread.inc svneol=native#text/plain
 rtl/amiga/Makefile svneol=native#text/plain
 rtl/amiga/Makefile.fpc svneol=native#text/plain
 rtl/amiga/doslibd.inc svneol=native#text/plain
 rtl/amiga/m68k/doslibf.inc svneol=native#text/plain
 rtl/amiga/m68k/execd.inc svneol=native#text/plain
 rtl/amiga/m68k/execf.inc svneol=native#text/plain
+rtl/amiga/m68k/m68kamiga.inc svneol=native#text/plain
 rtl/amiga/m68k/prt0.as svneol=native#text/plain
 rtl/amiga/m68k/utild1.inc svneol=native#text/plain
 rtl/amiga/m68k/utild2.inc svneol=native#text/plain
@@ -7929,7 +7932,6 @@ rtl/amiga/powerpc/utild2.inc svneol=native#text/plain
 rtl/amiga/powerpc/utilf.inc svneol=native#text/plain
 rtl/amiga/system.pp svneol=native#text/plain
 rtl/amiga/timerd.inc svneol=native#text/plain
-rtl/amiga/tthread.inc svneol=native#text/plain
 rtl/android/Makefile svneol=native#text/plain
 rtl/android/Makefile.fpc svneol=native#text/plain
 rtl/android/arm/dllprt0.as svneol=native#text/plain
@@ -8695,11 +8697,9 @@ rtl/morphos/emuld.inc svneol=native#text/plain
 rtl/morphos/execd.inc svneol=native#text/plain
 rtl/morphos/execf.inc svneol=native#text/plain
 rtl/morphos/prt0.as svneol=native#text/plain
-rtl/morphos/sysosh.inc svneol=native#text/plain
 rtl/morphos/system.pp svneol=native#text/plain
 rtl/morphos/timerd.inc svneol=native#text/plain
 rtl/morphos/timerf.inc svneol=native#text/plain
-rtl/morphos/tthread.inc svneol=native#text/plain
 rtl/morphos/utild1.inc svneol=native#text/plain
 rtl/morphos/utild2.inc svneol=native#text/plain
 rtl/morphos/utilf.inc svneol=native#text/plain

packages/fcl-process/src/amicommon/process.inc

@@ -117,7 +117,7 @@ begin
    cos := BPTR(0);
    repeat
      Inc(UID);
-     TempName := 'T:'+HexStr(FindTask(nil)) + '_'  + HexStr(Self) + '_'+ IntToStr(UID) + '_Starter.tmp';
+     TempName := 'T:PrO_'+ HexStr(FindTask(nil)) + '_' + IntToHex(UID,8);
    until not FileExists(TempName);   
    //sysdebugln('TProcess start: "' + ExecName + ' ' + Params+'"  >' + TempName);
    cos := AmigaDos.DosOpen(PChar(TempName), MODE_READWRITE);

packages/fcl-process/src/amicommon/simpleipc.inc

@@ -70,7 +70,7 @@ Type
     Procedure Connect; override;
     Procedure Disconnect; override;
     Procedure SendMessage(MsgType : TMessageType; AStream : TStream); override;
-    //Function  ServerRunning : Boolean; override;
+    Function  ServerRunning : Boolean; override;
   end;
 
   TAmigaServerComm = Class(TIPCServerComm)
@@ -90,19 +90,20 @@ Type
   
 // ####### CLIENT  
   
-function SafePutToPort(Msg: PMessage; Portname: string): Integer;
+function SafePutToPort(Msg: PMessage; Portname: string): Boolean;
  var
    Port: PMsgPort;
    PName: PChar;
  begin
-   Result := -1;
+   Result := False;
    PName := PChar(Portname + #0);
    Forbid();
    Port := FindPort(PName);
    if Assigned(Port) then
    begin
-     PutMsg(Port, Msg);
-     Result := 0;
+     if Assigned(Msg) then
+       PutMsg(Port, Msg);
+     Result := True;
    end;
    Permit();
  end;
@@ -133,7 +134,7 @@ var
   PortName: string;
 begin
   Size := AStream.Size - AStream.Position;
-  FullSize := Size + Sizeof(Exec.TMessage);
+  FullSize := Size + SizeOf(TMessageType) + Sizeof(Exec.TMessage);
   PortName := PORTNAMESTART + Owner.ServerID;
   Memory := System.AllocMem(FullSize);
   MP := CreateMsgPort;
@@ -143,8 +144,10 @@ begin
     MsgHead^.mn_Length := Size;
     Temp := Memory;
     Inc(Temp, SizeOf(Exec.TMessage));
+    Move(MsgType, Temp^, SizeOf(TMessageType));
+    Inc(Temp, SizeOf(TMessageType));
     AStream.Read(Temp^, Size);
-    if SafePutToPort(MsgHead, PortName) = 0 then
+    if SafePutToPort(MsgHead, PortName) then
       WaitPort(MP);
   finally
     System.FreeMem(Memory);
@@ -152,6 +155,11 @@ begin
   end;
 end;
 
+Function TAmigaClientComm.ServerRunning : Boolean;
+begin
+  Result := SafePutToPort(nil, PORTNAMESTART + Owner.ServerID); 
+end;
+
 // ###### SERVER
 
 Constructor TAmigaServerComm.Create(AOwner: TSimpleIPCServer);
@@ -213,8 +221,8 @@ begin
       Inc(Temp, SizeOf(Exec.TMessage));
       if Assigned(MsgBody) then
         System.FreeMem(MsgBody);
-      MsgBody := System.AllocMem(SizeOf(Exec.TMessage) + Msg^.mn_Length);
-      Move(Msg^, MsgBody^, SizeOf(Exec.TMessage) + Msg^.mn_Length);
+      MsgBody := System.AllocMem(SizeOf(Exec.TMessage) + SizeOf(TMessageType) + Msg^.mn_Length);
+      Move(Msg^, MsgBody^, SizeOf(Exec.TMessage) + SizeOf(TMessageType) + Msg^.mn_Length);
       ReplyMsg(Msg);
       break;
     end;
@@ -225,12 +233,16 @@ end;
 Procedure TAmigaServerComm.ReadMessage;
 var
   Temp: PByte;
+  MsgType: TMessageType;
 begin
   if Assigned(MsgBody) then
   begin
     Temp := Pointer(MsgBody);
     Inc(Temp, SizeOf(Exec.TMessage));
-    Owner.FMsgType := mtString;
+    MsgType := 0;
+    Move(Temp^, MsgType, SizeOf(TMessageType));
+    Inc(Temp, SizeOf(TMessageType));    
+    Owner.FMsgType := MsgType;
     Owner.FMsgData.Size := 0;
     Owner.FMsgData.Seek(0, soFrombeginning);
     Owner.FMsgData.WriteBuffer(temp^, MsgBody^.mn_Length);

packages/morphunits/src/exec.pas

@@ -544,7 +544,7 @@ type
   TMemEntry = packed record
     me_Un: packed record
     case Byte of
-      0 : (meu_Regs: DWord);
+      0 : (meu_Reqs: DWord);
       1 : (meu_Addr: Pointer)
     end;
     me_Length: DWord;
@@ -555,7 +555,7 @@ type
   TMemList = packed record
     ml_Node      : TNode;
     ml_NumEntries: Word;
-    ml_ME        : PMemEntry;
+    ml_ME        : array [0..0] of TMemEntry;
   end;
 
 

rtl/amicommon/athreads.pp

@@ -0,0 +1,990 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2015 by Karoly Balogh,
+    member of the Free Pascal development team.
+
+    native threadmanager implementation for Amiga-like systems
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+unit athreads;
+
+interface
+
+procedure SetAThreadBaseName(s: String);
+
+
+implementation
+
+{ enable this to compile athreads easily outside the RTL }
+{.$DEFINE ATHREADS_STANDALONE}
+
+{$IFDEF ATHREADS_STANDALONE}
+uses
+  exec, amigados, utility;
+{$ELSE}
+{ * Include required system specific includes * }
+{$include execd.inc}
+{$include execf.inc}
+{$include timerd.inc}
+{$include doslibd.inc}
+{$include doslibf.inc}
+{$ENDIF}
+
+const
+  threadvarblocksize : dword = 0;
+
+var
+  SubThreadBaseName: String = 'FPC Subthread';
+
+{.$define DEBUG_MT}
+type
+  TThreadOperation = ( toNone, toStart, toResume, toExit );
+
+type
+  PThreadMsg = ^TThreadMsg;
+
+  PThreadInfo = ^TThreadInfo;
+  TThreadInfo = record
+    threadVars: Pointer;     { have threadvars ptr as first field, so no offset is needed to access it (faster) }
+    threadVarsSize: DWord;   { size of the allocated threadvars block }
+    nextThread: PThreadInfo; { threadinfos are a linked list, using this field }
+    threadPtr: PProcess;     { our thread pointer, as returned by CreateNewProc(). invalid after exited field is true! }
+    threadID: TThreadID;     { thread Unique ID }
+    stackLen: PtrUInt;       { stack size the thread was construced with }
+    exitCode: Pointer;       { exitcode after the process has exited     }
+    f: TThreadFunc;          { ThreadFunc function pointer }
+    p: Pointer;              { ThreadFunc argument }
+    flags: dword;            { Flags this thread were created with }
+    num: longint;            { This was the "num"th thread to created }
+    mainthread: boolean;     { true if this is our main thread }
+    exited: boolean;         { true if the thread has exited, and can be cleaned up }
+    suspended: boolean;      { true if the thread was started suspended, and not resumed yet }
+    mutex: TSignalSemaphore; { thread's mutex. locked during the thread's life. }
+    name: String;            { Thread's name }
+  end;
+
+  TThreadMsg = record
+    tm_MsgNode   : TMessage;
+    tm_ThreadInfo: PThreadInfo;
+    tm_Operation : TThreadOperation;
+  end;
+
+var
+  AThreadManager: TThreadManager;
+  AThreadList: PThreadInfo;
+  AThreadListLen: LongInt;
+  AThreadNum: LongInt;
+  AThreadListSemaphore: TSignalSemaphore;
+
+
+{ Simple IntToStr() replacement which works with ShortStrings }
+function IToStr(const i: LongInt): String;
+begin
+  Str(I,result);
+end;
+
+{$IFDEF DEBUG_MT}
+function IToHStr(const i: LongInt): String;
+begin
+  result:=HexStr(Pointer(i));
+end;
+{$ENDIF}
+
+{ Function to add a thread to the running threads list }
+procedure AddToThreadList(var l: PThreadInfo; ti: PThreadInfo);
+var
+  p     : PThreadInfo;
+  inList: Boolean;
+begin
+  inList:=False;
+  ObtainSemaphore(@AThreadListSemaphore);
+
+  if l = nil then
+    { if the list is not yet allocated, the newly added
+      threadinfo will be the first item }
+    l:=ti
+  else
+    begin
+      { otherwise, look for the last item and append }
+      p:=l;
+      while (p^.nextThread<>nil) do p:=p^.nextThread;
+      p^.nextThread:=ti;
+    end;
+
+  inc(AThreadNum);
+  ti^.num:=AThreadNum;
+  inc(AThreadListLen);
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: thread ID:'+IToHStr(ti^.threadID)+' added, now '+IToStr(AThreadListLen)+' thread(s) in list.');
+{$ENDIF}
+  ReleaseSemaphore(@AThreadListSemaphore);
+end;
+
+{ Function to remove a thread from running threads list }
+function RemoveFromThreadList(var l: PThreadInfo; threadID: TThreadID): boolean;
+var
+  p      : PThreadInfo;
+  pprev  : PThreadInfo;
+  inList : Boolean;
+  tmpNext: PThreadInfo;
+  tmpInfo: PThreadInfo;
+begin
+  inList:=False;
+  if l=nil then
+    begin
+      RemoveFromThreadList:=inList;
+      exit;
+    end;
+
+  ObtainSemaphore(@AThreadListSemaphore);
+  p:=l;
+  pprev:=nil;
+  while (p <> nil) and (p^.threadID <> threadID) do
+    begin
+      pprev:=p;
+      p:=p^.nextThread;
+    end;
+
+  if p <> nil then
+    begin
+      tmpNext:=p^.nextThread;
+      if not p^.mainthread and p^.exited then
+        begin
+{$IFDEF DEBUG_MT}
+          SysDebugLn('FPC AThreads: Releasing resources for thread ID:'+IToHStr(threadID));
+          if (p^.threadVars <> nil) or (p^.threadVarsSize <> 0) then
+            SysDebugLn('FPC AThreads: WARNING, threadvars area wasn''t properly freed!'+IToHStr(threadID));
+{$ENDIF}
+          dispose(p);
+          if pprev <> nil then
+            pprev^.nextThread:=tmpNext;
+          Dec(AThreadListLen);
+        end
+      else
+        begin
+{$IFDEF DEBUG_MT}
+          SysDebugLn('FPC AThreads: Error! Attempt to remove threadID, which is the mainthread or not exited:'+IToHStr(threadID));
+{$ENDIF}
+          inList:=false;
+        end;
+    end
+{$IFDEF DEBUG_MT}
+  else
+    SysDebugLn('FPC AThreads: Error! Attempt to remove threadID, which is not in list:'+IToHstr(threadID))
+{$ENDIF}
+  ;
+  ReleaseSemaphore(@AThreadListSemaphore);
+
+  RemoveFromThreadList:=inList;
+end;
+
+{ Function to return a function's ThreadInfo based on the threadID }
+function GetThreadInfo(var l: PThreadInfo; threadID: TThreadID): PThreadInfo;
+var
+  p     : PThreadInfo;
+  inList: Boolean;
+begin
+  inList:=False;
+  GetThreadInfo:=nil;
+  if l = nil then
+    exit;
+
+  ObtainSemaphoreShared(@AThreadListSemaphore);
+  p:=l;
+  while (p <> nil) and (p^.threadID <> threadID) do
+    p:=p^.nextThread;
+  GetThreadInfo:=p;
+  ReleaseSemaphore(@AThreadListSemaphore);
+end;
+
+{ Get current thread's ThreadInfo structure }
+function GetCurrentThreadInfo: PThreadInfo;
+begin
+  result:=PThreadInfo(PProcess(FindTask(nil))^.pr_Task.tc_UserData);
+end;
+
+{ Returns the number of threads still not exited in our threadlist }
+function CountRunningThreads(var l: PThreadInfo): LongInt;
+var
+  p: PThreadInfo;
+begin
+  CountRunningThreads:=0;
+  ObtainSemaphoreShared(@AThreadListSemaphore);
+  p:=l;
+  while p <> nil do
+    begin
+      inc(CountRunningThreads,ord(not p^.exited));
+      p:=p^.nextThread;
+    end;
+  ReleaseSemaphore(@AThreadListSemaphore);
+end;
+
+{ Helper function for IPC }
+procedure SendMessageToThread(var threadMsg: TThreadMsg; p: PThreadInfo; const op: TThreadOperation; waitReply: boolean);
+var
+  replyPort: PMsgPort;
+begin
+  replyPort:=@PProcess(FindTask(nil))^.pr_MsgPort;
+
+  FillChar(threadMsg,sizeof(threadMsg),0);
+  with threadMsg do
+    begin
+      with tm_MsgNode do
+        begin
+          mn_Node.ln_Type:=NT_MESSAGE;
+          mn_Length:=SizeOf(TThreadMsg);
+          if waitReply then
+            mn_ReplyPort:=replyPort
+          else
+            mn_ReplyPort:=nil;
+        end;
+      tm_ThreadInfo:=p;
+      tm_Operation:=op;
+    end;
+  PutMsg(@p^.threadPtr^.pr_MsgPort,@threadMsg);
+
+  if waitReply then
+    begin
+      WaitPort(replyPort);
+      GetMsg(replyPort);
+    end;
+end;
+
+procedure SetAThreadBaseName(s: String);
+begin
+  ObtainSemaphore(@AThreadListSemaphore);
+  SubThreadBaseName:=s;
+  ReleaseSemaphore(@AThreadListSemaphore);
+end;
+
+function GetAThreadBaseName: String;
+begin
+  ObtainSemaphoreShared(@AThreadListSemaphore);
+  GetAThreadBaseName:=SubThreadBaseName;
+  ReleaseSemaphore(@AThreadListSemaphore);
+end;
+
+
+procedure AInitThreadvar(var offset : dword;size : dword);
+begin
+{$IFDEF DEBUG_MT}
+  {SysDebugLn('FPC AThreads: InitThreadvar');}
+{$ENDIF}
+  offset:=threadvarblocksize;
+  inc(threadvarblocksize,size);
+end;
+
+
+function ARelocateThreadvar(offset : dword) : pointer;
+var
+  p: PThreadInfo;
+begin
+{$IFDEF DEBUG_MT}
+  {SysDebugLn('FPC AThreads: RelocateThreadvar');}
+{$ENDIF}
+  p:=GetCurrentThreadInfo;
+  if (p <> nil) and (p^.threadVars <> nil) then
+    result:=p^.threadVars + Offset
+  else
+    result:=nil;
+end;
+
+
+procedure AAllocateThreadVars;
+var
+  p: PThreadInfo;
+begin
+  { we've to allocate the memory from system  }
+  { because the FPC heap management uses      }
+  { exceptions which use threadvars but       }
+  { these aren't allocated yet ...            }
+  { allocate room on the heap for the thread vars }
+  p:=GetCurrentThreadInfo;
+  if p <> nil then
+    begin
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Allocating threadvars, ID:'+IToHStr(p^.threadID));
+{$endif}
+{$ifdef AMIGA}
+      ObtainSemaphore(ASYS_heapSemaphore);
+{$endif}
+      p^.threadVars:=AllocPooled(ASYS_heapPool,threadvarblocksize);
+      if p^.threadVars = nil then
+        SysDebugLn('FPC AThreads: Failed to allocate threadvar memory!')
+      else
+        begin
+          p^.threadVarsSize:=threadvarblocksize;
+          FillChar(p^.threadVars^,threadvarblocksize,0);
+        end;
+{$ifdef AMIGA}
+      ReleaseSemaphore(ASYS_heapSemaphore);
+{$endif}
+    end
+  else
+    begin
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: AllocateThreadVars: tc_UserData of this process was nil!')
+{$endif}
+    end;
+end;
+
+
+procedure AReleaseThreadVars;
+var
+  p: PThreadInfo;
+begin
+  p:=GetCurrentThreadInfo;
+  if (p <> nil) and (p^.threadVars <> nil) then
+    begin
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Releasing threadvars, ID:'+IToHStr(p^.threadID));
+{$endif}
+{$ifdef AMIGA}
+      ObtainSemaphore(ASYS_heapSemaphore);
+{$endif}
+      FreePooled(ASYS_heapPool,p^.threadVars,p^.threadVarsSize);
+      p^.threadVars:=nil;
+      p^.threadVarsSize:=0;
+{$ifdef AMIGA}
+      ReleaseSemaphore(ASYS_heapSemaphore);
+{$endif}
+    end
+  else
+    begin
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: ReleaseThreadVars: tc_UserData or threadVars area of this process was nil!')
+{$endif}
+    end;
+end;
+
+
+procedure InitAThreading;
+var
+  threadInfo: PThreadInfo;
+  p: PProcess;
+begin
+  if (InterLockedExchange(longint(IsMultiThread),ord(true)) = 0) then
+    begin
+      { We're still running in single thread mode, setup the TLS }
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Entering multithreaded mode...');
+{$endif}
+      p:=PProcess(FindTask(nil));
+      new(threadInfo);
+      FillChar(threadInfo^,sizeof(TThreadInfo),0);
+      p^.pr_Task.tc_UserData:=threadInfo;
+      threadInfo^.mainThread:=true;
+      InitSemaphore(@threadInfo^.mutex);
+      ObtainSemaphore(@threadInfo^.mutex);
+      threadInfo^.threadPtr:=p;
+      threadInfo^.threadID:=TThreadID(threadInfo);
+      InitThreadVars(@ARelocateThreadvar);
+      AddToThreadList(AThreadList,threadInfo);
+    end;
+end;
+
+
+procedure ThreadFunc; cdecl;
+var
+  thisThread: PProcess;
+  threadMsg: PThreadMsg;
+  resumeMsg: PThreadMsg;
+  exitSuspend: boolean; // true if we have to exit instead of resuming
+  threadInfo: PThreadInfo;
+begin
+  thisThread:=PProcess(FindTask(nil));
+
+  { wait for our start message to arrive, then fetch it }
+  WaitPort(@thisThread^.pr_MsgPort);
+  threadMsg:=PThreadMsg(GetMsg(@thisThread^.pr_MsgPort));
+
+  { fetch existing threadinfo from the start message, and set 
+    it to tc_userData, so we can proceed with threadvars }
+  threadInfo:=threadMsg^.tm_ThreadInfo;
+  thisThread^.pr_Task.tc_userData:=threadInfo;
+
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: Entering subthread function, ID:'+hexStr(threadInfo));
+{$endif}
+  { Obtain the threads' mutex, used for exit sync }
+  ObtainSemaphore(@threadInfo^.mutex);
+
+  { Allocate local thread vars, this must be the first thing,
+    because the exception management and io depends on threadvars }
+  AAllocateThreadVars;
+
+  { Rename the thread into something sensible }
+  if threadInfo^.name <> '' then
+    begin
+{$ifdef DEBUG_MT}
+      { this line can't be before threadvar allocation }
+      SysDebugLn('FPC AThreads: Renaming thread ID:'+hexStr(threadInfo)+' to '+threadInfo^.name);
+{$endif}
+      thisThread^.pr_Task.tc_Node.ln_Name:=PChar(@threadInfo^.name[1]);
+    end;
+
+  { Reply the message, so the calling thread could continue }
+  { note that threadMsg was allocated on the caller's task, so }
+  { it will be invalid below this point }
+  ReplyMsg(PMessage(threadMsg));
+
+  { if creating a suspended thread, wait for the wakeup message to arrive }
+  { then check if we actually have to resume, or exit }
+  exitSuspend:=false;
+  if threadInfo^.suspended then
+    begin
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Suspending subthread on entry, ID:'+hexStr(threadInfo));
+{$endif}
+      WaitPort(@thisThread^.pr_MsgPort);
+      resumeMsg:=PThreadMsg(GetMsg(@thisThread^.pr_MsgPort));
+      exitSuspend:=resumeMsg^.tm_Operation <> toResume;
+      threadInfo^.suspended:=false;
+      ReplyMsg(PMessage(resumeMsg));
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Resuming subthread on entry, ID:'+hexStr(threadInfo)+', resumed only to exit: '+IToStr(ord(exitSuspend)));
+{$endif}
+    end;
+
+  { Finally, call the user code }
+  if not exitSuspend then
+    begin
+      InitThread(threadInfo^.stackLen);
+      threadInfo^.exitCode:=Pointer(threadInfo^.f(threadInfo^.p));
+      DoneThread;
+    end;
+
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: Exiting Subthread function, ID:'+hexStr(threadInfo));
+{$endif}
+  Forbid();
+  threadInfo^.exited:=true;
+
+  { Finally, Release our exit mutex. }
+  ReleaseSemaphore(@threadInfo^.mutex);
+end;
+
+
+function CreateNewProcess(const Tags : Array Of PtrUInt) : PProcess;
+begin
+  result:=CreateNewProc(@Tags[0]);
+end;
+
+function ABeginThread(sa : Pointer;stacksize : PtrUInt;
+                      ThreadFunction : tthreadfunc;p : pointer;
+                      creationFlags : dword; var ThreadId : TThreadId) : TThreadID;
+var
+  threadInfo: PThreadInfo;
+  threadMsg: TThreadMsg;
+  threadName: String;
+  subThread: PProcess;
+begin
+  ABeginThread:=TThreadID(0);
+
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: Creating new thread...');
+{$endif DEBUG_MT}
+  { Initialize multithreading if not done }
+  if not IsMultiThread then
+    InitAThreading;
+  { the only way to pass data to the newly created thread
+    in a MT safe way, is to use the heap }
+  new(threadInfo);
+  FillChar(threadInfo^,sizeof(TThreadInfo),0);
+  InitSemaphore(@threadInfo^.mutex);
+  threadInfo^.f:=ThreadFunction;
+  threadInfo^.p:=p;
+
+  if (creationFlags and STACK_SIZE_PARAM_IS_A_RESERVATION) > 0 then
+    threadInfo^.stackLen:=stacksize
+  else
+    threadInfo^.stackLen:=System.StackLength; { inherit parent's stack size }
+  threadInfo^.suspended:=(creationFlags and CREATE_SUSPENDED) > 0;
+
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: Starting new thread... Stack size: '+IToStr(threadInfo^.stackLen));
+{$endif}
+  subThread:=CreateNewProcess([NP_Entry,PtrUInt(@ThreadFunc),
+                               {$IFDEF MORPHOS}
+                               NP_CodeType,CODETYPE_PPC,
+                               NP_PPCStackSize,threadInfo^.stacklen,
+                               {$ELSE}
+                               NP_StackSize,threadInfo^.stacklen,
+                               {$ENDIF}
+                               TAG_DONE]);
+  if subThread = nil then
+    begin
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Failed to start the subthread!');
+{$endif}
+      exit;
+    end;
+  ThreadID:=TThreadID(threadInfo);
+  threadInfo^.threadPtr:=subThread;
+  threadInfo^.threadID:=ThreadID;
+  AddToThreadList(AThreadList,threadInfo);
+
+  { the thread should be started, and waiting for our start message, so send it }
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: Sending start message to subthread and waiting for reply, ID:'+IToHStr(threadID));
+{$endif}
+  { AddToThreadList assigned us a number, so use it to name the thread }
+  threadInfo^.name:=GetAThreadBaseName+' #'+IToStr(threadInfo^.num);
+  SendMessageToThread(threadMsg,threadInfo,toStart,true);
+
+  ABeginThread:=ThreadId;
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: Thread created successfully, ID:'+IToHStr(threadID));
+{$endif}
+end;
+
+
+procedure AEndThread(ExitCode : DWord);
+begin
+  { Do not call DoneThread here. It will be called by the threadfunction, when it exits. }
+end;
+
+
+function ASuspendThread (threadHandle : TThreadID) : dword;
+begin
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: unsupported operation: SuspendThread called for ID:'+IToHStr(threadHandle));
+{$endif}
+  // cannot be properly supported on Amiga
+  result:=dword(-1);
+end;
+
+
+function AResumeThread (threadHandle : TThreadID) : dword;
+var
+  m: TThreadMsg;
+  p: PThreadInfo;
+begin
+  AResumeThread:=0;
+  Forbid();
+  p:=GetThreadInfo(AThreadList,threadHandle);
+  if (p <> nil) and p^.suspended then
+    begin
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Waiting for thread to resume, ID:'+IToHStr(threadHandle));
+{$endif}
+      { WaitPort in SendMessageToThread will break the Forbid() state... }
+      SendMessageToThread(m,p,toResume,true);
+      AResumeThread:=0;
+    end
+  else
+    begin
+      SysDebugLn('FPC AThreads: szijjal gazt:'+hexstr(p)+' mi?'+IToStr(ord(p^.suspended))+' mimi?'+IToStr(ord(p^.exited)));
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Error, attempt to resume a non-suspended thread, or invalid thread ID:'+IToHStr(threadHandle));
+{$endif}
+      AResumeThread:=dword(-1);
+    end;
+  Permit();
+end;
+
+
+procedure AThreadSwitch;  {give time to other threads}
+begin
+  { On Unix, this calls sched_yield();
+    Harry 'Piru' Sintonen recommended to emulate this on Amiga systems with
+    exec/Forbid-exec/Permit pair which is pretty fast to execute and will
+    trigger a rescheduling.
+    Another idea by Frank Mariak was to use exec/SetTaskPri() with the same
+    priority }
+  Forbid();
+  Permit();
+end;
+
+
+function AKillThread (threadHandle : TThreadID) : dword;
+begin
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: unsupported operation: KillThread called for ID:'+IToHStr(threadHandle));
+{$endif}
+  // cannot be properly supported on Amiga
+  AKillThread:=dword(-1);
+end;
+
+
+function ACloseThread (threadHandle : TThreadID) : dword;
+begin
+{$WARNING The return value here seems to be undocumented}
+  RemoveFromThreadList(AThreadList, threadHandle);
+  result:=0;
+end;
+
+
+function AWaitForThreadTerminate (threadHandle : TThreadID; TimeoutMs : longint) : dword;  {0=no timeout}
+var
+  p: PThreadInfo;
+  m: TThreadMsg;
+begin
+{.$WARNING Support for timeout argument is not implemented}
+{ But since CThreads uses pthread_join, which has also no timeout,
+  I don't think this is a big issue. (KB) }
+  AWaitForThreadTerminate:=0;
+  Forbid();
+  p:=GetThreadInfo(AThreadList,threadHandle);
+  if (p <> nil) then
+    begin
+      if not p^.exited then
+        begin
+{$ifdef DEBUG_MT}
+          SysDebugLn('FPC AThreads: Waiting for thread to exit, ID:'+IToHStr(threadHandle));
+{$endif}
+          { WaitPort in SendMessageToThread will break the Forbid() state... }
+          if p^.suspended then
+            begin
+              SendMessageToThread(m,p,toExit,true);
+{$ifdef DEBUG_MT}
+              SysDebugLn('FPC AThreads: Signaled suspended thread to exit, ID:'+IToHStr(threadHandle));
+{$endif}
+            end;
+
+          { Wait for the thread to exit... }
+          Permit();
+          ObtainSemaphore(@p^.mutex);
+          ReleaseSemaphore(@p^.mutex);
+          Forbid();
+        end
+      else
+{$ifdef DEBUG_MT}
+        SysDebugLn('FPC AThreads: Thread already exited, ID:'+IToHStr(threadHandle));
+{$endif}
+      AWaitForThreadTerminate:=DWord(p^.exitCode);
+    end
+  else
+    begin
+{$ifdef DEBUG_MT}
+      SysDebugLn('FPC AThreads: Error, attempt to wait for invalid thread ID to exit, ID:'+IToHStr(threadHandle));
+{$endif}
+      AWaitForThreadTerminate:=dword(-1); { Return non-zero code on error. }
+    end;
+  Permit();
+end;
+
+
+function AThreadSetPriority (threadHandle : TThreadID; Prio: longint): boolean; {-15..+15, 0=normal}
+begin
+  {$Warning ThreadSetPriority needs to be implemented}
+  result:=false;
+end;
+
+
+function AThreadGetPriority (threadHandle : TThreadID): Integer;
+begin
+  {$Warning ThreadGetPriority needs to be implemented}
+  result:=0;
+end;
+
+
+function AGetCurrentThreadId : TThreadID;
+begin
+  AGetCurrentThreadId := TThreadID(GetCurrentThreadInfo);
+end;
+
+
+Type  PINTRTLEvent = ^TINTRTLEvent;
+      TINTRTLEvent = record
+        isset: boolean;
+      end;
+
+Function intRTLEventCreate: PRTLEvent;
+
+var p:pintrtlevent;
+
+begin
+  new(p);
+  result:=PRTLEVENT(p);
+end;
+
+procedure intRTLEventDestroy(AEvent: PRTLEvent);
+
+var p:pintrtlevent;
+
+begin
+  p:=pintrtlevent(aevent);
+  dispose(p);
+end;
+
+procedure intRTLEventSetEvent(AEvent: PRTLEvent);
+var p:pintrtlevent;
+
+begin
+  p:=pintrtlevent(aevent);
+  p^.isset:=true;
+end;
+
+
+procedure intRTLEventResetEvent(AEvent: PRTLEvent);
+var p:pintrtlevent;
+
+begin
+  p:=pintrtlevent(aevent);
+  p^.isset:=false;
+end;
+
+
+procedure intRTLEventWaitFor(AEvent: PRTLEvent);
+var p:pintrtlevent;
+
+begin
+  p:=pintrtlevent(aevent);
+  p^.isset:=false;
+end;
+
+procedure intRTLEventWaitForTimeout(AEvent: PRTLEvent;timeout : longint);
+var
+  p : pintrtlevent;
+begin
+  p:=pintrtlevent(aevent);
+end;
+
+
+procedure AInitCriticalSection(var CS);
+begin
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: InitCriticalSection '+hexStr(@CS));
+{$ENDIF}
+  InitSemaphore(PSignalSemaphore(@CS));
+end;
+
+
+procedure AEnterCriticalSection(var CS);
+begin
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: EnterCriticalSection '+hexStr(@CS));
+{$ENDIF}
+  ObtainSemaphore(PSignalSemaphore(@CS));
+end;
+
+
+function ATryEnterCriticalSection(var CS):longint;
+begin
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: TryEnterCriticalSection '+hexStr(@CS));
+{$ENDIF}
+  result:=DWord(AttemptSemaphore(PSignalSemaphore(@CS)));
+  if result<>0 then
+    result:=1;
+end;
+
+
+procedure ALeaveCriticalSection(var CS);
+begin
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: LeaveCriticalSection '+hexStr(@CS));
+{$ENDIF}
+  ReleaseSemaphore(PSignalSemaphore(@CS));
+end;
+
+
+procedure ADoneCriticalSection(var CS);
+begin
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: DoneCriticalSection '+hexStr(@CS));
+{$ENDIF}
+  { unlock as long as unlocking works to unlock it if it is recursive
+    some Delphi code might call this function with a locked mutex }
+  with TSignalSemaphore(CS) do
+    while ss_NestCount > 0 do
+      ReleaseSemaphore(PSignalSemaphore(@CS));
+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 ASemaphoreInit: Pointer;
+begin
+  result:=nil;
+end;
+
+procedure ASemaphoreDestroy(const FSem: Pointer);
+begin
+end;
+
+procedure ASemaphoreWait(const FSem: Pointer);
+begin
+end;
+
+procedure ASemaphorePost(const FSem: Pointer);
+begin
+end;
+
+
+function AInitThreads : Boolean;
+begin
+{$ifdef DEBUG_MT}
+  SysDebugLn('FPC AThreads: Entering InitThreads...');
+{$endif}
+  result:=true;
+
+  // We assume that if you set the thread manager, the application is multithreading.
+  InitAThreading;
+
+  ThreadID := TThreadID(GetCurrentThreadInfo);
+end;
+
+function ADoneThreads : Boolean;
+begin
+  result:=true;
+end;
+
+
+procedure SetAThreadManager;
+begin
+  with AThreadManager do begin
+    InitManager            :=@AInitThreads;
+    DoneManager            :=@ADoneThreads;
+    BeginThread            :=@ABeginThread;
+    EndThread              :=@AEndThread;
+    SuspendThread          :=@ASuspendThread;
+    ResumeThread           :=@AResumeThread;
+    KillThread             :=@AKillThread;
+    ThreadSwitch           :=@AThreadSwitch;
+    CloseThread            :=@ACloseThread;
+    WaitForThreadTerminate :=@AWaitForThreadTerminate;
+    ThreadSetPriority      :=@AThreadSetPriority;
+    ThreadGetPriority      :=@AThreadGetPriority;
+    GetCurrentThreadId     :=@AGetCurrentThreadId;
+    InitCriticalSection    :=@AInitCriticalSection;
+    DoneCriticalSection    :=@ADoneCriticalSection;
+    EnterCriticalSection   :=@AEnterCriticalSection;
+    TryEnterCriticalSection:=@ATryEnterCriticalSection;
+    LeaveCriticalSection   :=@ALeaveCriticalSection;
+    InitThreadVar          :=@AInitThreadVar;
+    RelocateThreadVar      :=@ARelocateThreadVar;
+    AllocateThreadVars     :=@AAllocateThreadVars;
+    ReleaseThreadVars      :=@AReleaseThreadVars;
+    BasicEventCreate       :=@intBasicEventCreate;
+    BasicEventDestroy      :=@intBasicEventDestroy;
+    BasicEventResetEvent   :=@intBasicEventResetEvent;
+    BasicEventSetEvent     :=@intBasicEventSetEvent;
+    BasiceventWaitFor      :=@intBasicEventWaitFor;
+    rtlEventCreate         :=@intrtlEventCreate;
+    rtlEventDestroy        :=@intrtlEventDestroy;
+    rtlEventSetEvent       :=@intrtlEventSetEvent;
+    rtlEventResetEvent     :=@intrtlEventResetEvent;
+    rtleventWaitForTimeout :=@intrtleventWaitForTimeout;
+    rtleventWaitFor        :=@intrtleventWaitFor;
+    // semaphores
+    SemaphoreInit          :=@ASemaphoreInit;
+    SemaphoreDestroy       :=@ASemaphoreDestroy;
+    SemaphoreWait          :=@ASemaphoreWait;
+    SemaphorePost          :=@ASemaphorePost;
+  end;
+  SetThreadManager(AThreadManager);
+end;
+
+Procedure InitSystemThreads; external name '_FPC_InitSystemThreads';
+
+
+{ This should only be called from the finalization }
+procedure WaitForAllThreads;
+var
+  p: PThreadInfo;
+  pn: PThreadInfo;
+begin
+  { If we are the main thread exiting, we have to wait for our subprocesses to
+    exit. Because AmigaOS won't clean up for us. Also, after exiting the main
+    thread the OS unloads all the code segments with code potentially still
+    running in the background... So even waiting here forever is better than
+    exiting with active threads, which will most likely just kill the OS
+    immediately. (KB) }
+  ObtainSemaphore(@AThreadListSemaphore);
+
+{$IFDEF DEBUG_MT}
+  if AThreadListLen > 1 then
+    begin
+      SysDebugLn('FPC AThreads: We have registered subthreads, checking their status...');
+      if CountRunningThreads(AThreadList) > 1 then
+        SysDebugLn('FPC AThreads: We have running subthreads, waiting for them to exit...');
+    end;
+{$ENDIF}
+
+  while CountRunningThreads(AThreadList) > 1 do
+    begin
+      ReleaseSemaphore(@AThreadListSemaphore);
+      DOSDelay(1);
+      { Reobtain the semaphore... }
+      ObtainSemaphore(@AThreadListSemaphore);
+    end;
+
+  if AThreadListLen > 1 then
+    begin
+{$IFDEF DEBUG_MT}
+      SysDebugLn('FPC AThreads: All threads exited but some lacking cleanup - trying to free up resources...');
+{$ENDIF}
+      p:=AThreadList;
+      while p <> nil do
+        begin
+          pn:=p^.nextThread;
+          if not p^.mainThread then
+            RemoveFromThreadList(AThreadList,p^.threadID);
+          p:=pn;
+        end;
+    end
+  else
+    begin
+{$IFDEF DEBUG_MT}
+      SysDebugLn('FPC AThreads: All threads exited normally.');
+{$ENDIF}
+    end;
+  ReleaseSemaphore(@AThreadListSemaphore);
+end;
+
+initialization
+  initsystemthreads;
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: Unit Initialization');
+{$ENDIF}
+  if ThreadingAlreadyUsed then
+    begin
+      writeln('Threading has been used before athreads was initialized.');
+      writeln('Make athreads one of the first units in your uses clause!');
+      runerror(211);
+    end;
+  AThreadList:=nil;
+  AThreadListLen:=0;
+  AThreadNum:=-1; { Mainthread will be 0. }
+  InitSemaphore(@AThreadListSemaphore);
+  SetAThreadManager;
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: Unit Initialization Done');
+{$ENDIF}
+finalization
+{$IFDEF DEBUG_MT}
+  SysDebugLn('FPC AThreads: Unit Finalization');
+{$ENDIF}
+  WaitForAllThreads;
+end.

rtl/amicommon/osdebug.inc

@@ -38,6 +38,23 @@ begin
   RawPutChar(#10);
 end;
 
+procedure SysDebug(const s: ShortString); platform;
+var
+  i: LongInt;
+begin
+  for i:=1 to Length(s) do
+    RawPutChar(s[i]);
+end;
+
+procedure SysDebugLn(const s: ShortString); platform;
+var
+  i: LongInt;
+begin
+  for i:=1 to Length(s) do
+    RawPutChar(s[i]);
+  RawPutChar(#10);
+end;
+
 procedure SysDebugLn; {$IFDEF SYSTEMINLINE}inline;{$ENDIF} platform;
 begin
   RawPutChar(#10);

rtl/amicommon/osdebugh.inc

@@ -15,4 +15,6 @@
 
 procedure SysDebug(const s: RawByteString);
 procedure SysDebugLn(const s: RawByteString);
+procedure SysDebug(const s: ShortString);
+procedure SysDebugLn(const s: ShortString);
 procedure SysDebugLn;

rtl/amicommon/sysfile.inc

@@ -40,6 +40,7 @@ var
   tmpHandle : LongInt;
 begin
   if l=nil then exit;
+  ObtainSemaphore(ASYS_fileSemaphore);
 
   { First, close all tracked files }
   tmpNext:=l^.next;
@@ -58,6 +59,7 @@ begin
     l:=l^.next;
     dispose(tmpNext);
   end;
+  ReleaseSemaphore(ASYS_fileSemaphore);
 end;
 
 { Function to be called to add a file to the opened file list }
@@ -67,6 +69,8 @@ var
   inList: Boolean;
 begin
   inList:=False;
+  ObtainSemaphore(ASYS_fileSemaphore);
+
   if l<>nil then begin
     { if there is a valid filelist, search for the value }
     { in the list to avoid double additions }
@@ -93,6 +97,7 @@ begin
     RawDoFmt('FPC_FILE_DEBUG: Error! Trying add filehandle a filehandle twice: $%lx !'+#10,@h,pointer(1),nil);
 {$ENDIF}
   ;
+  ReleaseSemaphore(ASYS_fileSemaphore);
 end;
 
 { Function to be called to remove a file from the list }
@@ -108,6 +113,7 @@ begin
     exit;
   end;
 
+  ObtainSemaphore(ASYS_fileSemaphore);
   p:=l;
   while (p^.next<>nil) and (not inList) do
     if p^.next^.handle=h then inList:=True
@@ -123,6 +129,7 @@ begin
     RawDoFmt('FPC_FILE_DEBUG: Error! Trying to remove not existing filehandle: $%lx !'+#10,@h,pointer(1),nil);
 {$ENDIF}
   ;
+  ReleaseSemaphore(ASYS_fileSemaphore);
 
   RemoveFromList:=inList;
 end;
@@ -140,6 +147,7 @@ begin
     exit;
   end;
 
+  ObtainSemaphore(ASYS_fileSemaphore);
   p:=l;
   while (p^.next<>nil) and (inList=nil) do
     if p^.next^.handle=h then inList:=p^.next
@@ -150,6 +158,7 @@ begin
     RawDoFmt('FPC_FILE_DEBUG: Warning! Check for not existing filehandle: $%lx !'+#10,@h,pointer(1),nil);
 {$ENDIF}
 
+  ReleaseSemaphore(ASYS_fileSemaphore);
   CheckInList:=inList;
 end;
 

rtl/amicommon/sysosh.inc

@@ -23,9 +23,19 @@ type
   THandle = LongInt;
 {$endif CPU64}
   TThreadID = THandle;
-  
+
   PRTLCriticalSection = ^TRTLCriticalSection;
+{$IFDEF AROS}
   TRTLCriticalSection = Pointer;
-
-
-
+{$ELSE}
+  TRTLCriticalSection = record
+    { This must actually be bigger or equal to sizeof(TSignalSemaphore)
+      which seems to be 46 bytes on MorphOS and Amiga/m68k. }
+    semaphore: array[0..63] of byte;
+  end;
+{$ENDIF}
+
+{ BeginThread flags we support in AThreads }
+const
+  CREATE_SUSPENDED = 1;
+  STACK_SIZE_PARAM_IS_A_RESERVATION = 2;

rtl/amicommon/sysutils.pp

@@ -63,7 +63,7 @@ uses
 {$i sysutils.inc}
 
 
-{ * Include sytem specific includes * }
+{ * Include system specific includes * }
 {$include execd.inc}
 {$include execf.inc}
 {$include timerd.inc}
@@ -900,7 +900,7 @@ end;
 procedure Sleep(Milliseconds: cardinal);
 begin
   // Amiga dos.library Delay() has precision of 1/50 seconds
-  Delay(Milliseconds div 20);
+  DOSDelay(Milliseconds div 20);
 end;
 
 

rtl/amicommon/tthread.inc

@@ -0,0 +1,125 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2015 by Karoly Balogh,
+    member of the Free Pascal development team.
+
+    native TThread implementation for Amiga-like systems
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{ Thread management routines }
+
+{ Based on the Win32 version, but since that mostly just wraps to a stock
+  ThreadManager, it was relatively straightforward to get this working,
+  after we had a ThreadManager (AThreads) (KB) }
+
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
+begin
+  FSuspended := CreateSuspended;
+  FInitialSuspended := CreateSuspended;
+  { Always start in suspended state, will be resumed in AfterConstruction if necessary
+    See Mantis #16884 }
+  FHandle := BeginThread(nil, StackSize, @ThreadProc, pointer(self), 1{CREATE_SUSPENDED},
+                         FThreadID);
+  if FHandle = TThreadID(0) then
+    raise EThread.CreateFmt(SThreadCreateError, ['Cannot create thread.']);
+
+  FFatalException := nil;
+end;
+
+
+procedure TThread.SysDestroy;
+begin
+  if FHandle<>0 then
+    begin
+      { Don't check Suspended. If the thread has been externally suspended (which is
+        deprecated and strongly discouraged), it's better to deadlock here than
+        to silently free the object and leave OS resources leaked. }
+      if not FFinished {and not Suspended} then
+        begin
+          Terminate;
+          { Allow the thread function to perform the necessary cleanup. Since
+            we've just set Terminated flag, it won't call Execute. }
+          if FInitialSuspended then
+            Start;
+          WaitFor;
+        end;
+    end;
+
+  FFatalException.Free;
+  FFatalException := nil;
+end;
+
+procedure TThread.CallOnTerminate;
+begin
+  FOnTerminate(Self);
+end;
+
+procedure TThread.DoTerminate;
+begin
+  if Assigned(FOnTerminate) then
+    Synchronize(@CallOnTerminate);
+end;
+
+{const
+  Priorities: array [TThreadPriority] of Integer =
+   (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
+    THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
+    THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);}
+
+function TThread.GetPriority: TThreadPriority;
+var
+  P: Integer;
+  I: TThreadPriority;
+begin
+{  P := GetThreadPriority(FHandle);
+  Result := tpNormal;
+  for I := Low(TThreadPriority) to High(TThreadPriority) do
+    if Priorities[I] = P then Result := I;}
+end;
+
+procedure TThread.SetPriority(Value: TThreadPriority);
+begin
+//  SetThreadPriority(FHandle, Priorities[Value]);
+end;
+
+
+procedure TThread.SetSuspended(Value: Boolean);
+begin
+  if Value <> FSuspended then
+    if Value then
+      Suspend
+    else
+      Resume;
+end;
+
+procedure TThread.Suspend;
+begin
+  { Unsupported, but lets have it... }
+  FSuspended := True;
+  SuspendThread(FHandle);
+end;
+
+procedure TThread.Resume;
+begin
+  if ResumeThread(FHandle) = 1 then FSuspended := False;
+end;
+
+procedure TThread.Terminate;
+begin
+  FTerminated := True;
+end;
+
+function TThread.WaitFor: Integer;
+begin
+  result:=WaitForThreadTerminate(FThreadID,0);
+  FFinished:=(result = 0);
+end;

rtl/amiga/m68k/doslibf.inc

@@ -111,7 +111,7 @@ SysCall AOS_DOSBase 186;
 function DateStamp(date: PDateStamp location 'd1'): PDateStamp;
 SysCall AOS_DOSBase 192;
 
-procedure Delay(timeout: LongInt location 'd1');
+procedure DOSDelay(timeout: LongInt location 'd1');
 SysCall AOS_DOSBase 198;
 
 function WaitForChar(file1  : LongInt location 'd1';

rtl/amiga/m68k/m68kamiga.inc

@@ -0,0 +1,66 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2015 by Karoly Balogh,
+    member of the Free Pascal development team.
+
+    m68k/Amiga atomic operations implementation
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{ The Amiga hardware doesn't support the m68k CPU's atomic operations
+  like TAS, CAS, CAS2 and so on. Therefore we must "emulate" them from
+  software. The easiest way is the Forbid()/Permit() OS call pair around
+  the ops themselves. It of course won't be hardware-atomic, but should
+  be safe for multithreading. (KB) }
+
+function InterLockedDecrement (var Target: longint) : longint;
+  begin
+    Forbid;
+    Dec(Target);
+    Result := Target;
+    Permit;
+  end;
+
+
+function InterLockedIncrement (var Target: longint) : longint;
+  begin
+    Forbid;
+    Inc(Target);
+    Result := Target;
+    Permit;
+  end;
+
+
+function InterLockedExchange (var Target: longint;Source : longint) : longint;
+  begin
+    Forbid;
+    Result := Target;
+    Target := Source;
+    Permit;
+  end;
+
+
+function InterLockedExchangeAdd (var Target: longint;Source : longint) : longint;
+  begin
+    Forbid;
+    Result := Target;
+    Target := Target + Source;
+    Permit;
+  end;
+
+
+function InterlockedCompareExchange(var Target: longint; NewValue: longint; Comperand: longint): longint;
+  begin
+    Forbid;
+    Result := Target;
+    if Target = Comperand then
+      Target := NewValue;
+    Permit;
+  end;

rtl/amiga/system.pp

@@ -80,6 +80,7 @@ var
 
   ASYS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
   ASYS_heapSemaphore: Pointer; { 68k OS from 3.x has no MEMF_SEM_PROTECTED for pools, have to do it ourselves }
+  ASYS_fileSemaphore: Pointer; { mutex semaphore for filelist access arbitration }
   ASYS_origDir  : LongInt; { original directory on startup }
   AOS_wbMsg    : Pointer; public name '_WBenchMsg'; { the "public" part is amunits compatibility kludge }
   _WBenchMsg   : Pointer; external name '_WBenchMsg'; { amunits compatibility kludge }
@@ -113,6 +114,7 @@ implementation
 
 {$I system.inc}
 {$I osdebug.inc}
+{$I m68kamiga.inc}
 
 {$IFDEF AMIGAOS4}
   // Required to allow opening of utility library interface...
@@ -355,8 +357,14 @@ begin
   ASYS_heapPool:=CreatePool(MEMF_FAST,growheapsize2,growheapsize1);
   if ASYS_heapPool=nil then Halt(1);
   ASYS_heapSemaphore:=AllocPooled(ASYS_heapPool,sizeof(TSignalSemaphore));
+  if ASYS_heapSemaphore = nil then Halt(1);
   InitSemaphore(ASYS_heapSemaphore);
 
+  { Initialize semaphore for filelist access arbitration }
+  ASYS_fileSemaphore:=AllocPooled(ASYS_heapPool,sizeof(TSignalSemaphore));
+  if ASYS_fileSemaphore = nil then Halt(1);
+  InitSemaphore(ASYS_fileSemaphore);
+
   if AOS_wbMsg=nil then begin
     StdInputHandle:=dosInput;
     StdOutputHandle:=dosOutput;

rtl/amiga/tthread.inc

@@ -1,157 +0,0 @@
-{
-    This file is part of the Free Component Library (FCL)
-    Copyright (c) 1999-2002 by the Free Pascal development team
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-{****************************************************************************}
-{*                             TThread                                      *}
-{****************************************************************************}
-
-{$WARNING This file is only a stub, and will not work!}
-
-const
- ThreadCount: longint = 0;
-
-(* Implementation of exported functions *)
-
-procedure AddThread (T: TThread);
-begin
- Inc (ThreadCount);
-end;
-
-
-procedure RemoveThread (T: TThread);
-begin
- Dec (ThreadCount);
-end;
-
-
-procedure TThread.CallOnTerminate;
-begin
- FOnTerminate (Self);
-end;
-
-
-function TThread.GetPriority: TThreadPriority;
-var
-{ PTIB: PThreadInfoBlock;
- PPIB: PProcessInfoBlock;}
- I: TThreadPriority;
-begin
-{
- DosGetInfoBlocks (@PTIB, @PPIB);
- with PTIB^.TIB2^ do
-  if Priority >= $300 then GetPriority := tpTimeCritical else
-      if Priority < $200 then GetPriority := tpIdle else
-  begin
-   I := Succ (Low (TThreadPriority));
-   while (I < High (TThreadPriority)) and
-    (Priority - Priorities [I] <= Priorities [Succ (I)] - Priority) do Inc (I);
-   GetPriority := I;
-  end;
-}
-end;
-
-
-procedure TThread.SetPriority(Value: TThreadPriority);
-{var
- PTIB: PThreadInfoBlock;
- PPIB: PProcessInfoBlock;}
-begin
-{ DosGetInfoBlocks (@PTIB, @PPIB);}
-(*
- PTIB^.TIB2^.Priority := Priorities [Value];
-*)
-{
- DosSetPriority (2, High (Priorities [Value]),
-                     Low (Priorities [Value]) - PTIB^.TIB2^.Priority, FHandle);}
-end;
-
-
-procedure TThread.SetSuspended(Value: Boolean);
-begin
- if Value <> FSuspended then
- begin
-  if Value then Suspend else Resume;
- end;
-end;
-
-
-procedure TThread.DoTerminate;
-begin
- if Assigned (FOnTerminate) then Synchronize (@CallOnTerminate);
-end;
-
-
-procedure TThread.SysCreate(CreateSuspended: Boolean;
-                            const StackSize: SizeUInt);
-var
-  Flags: cardinal;
-begin
-  AddThread (Self);
-{
-  FSuspended := CreateSuspended;
-  Flags := dtStack_Commited;
-  if FSuspended then Flags := Flags or dtSuspended;
-  if DosCreateThread (cardinal (FThreadID), @ThreadProc, pointer (Self),
-                                                        Flags, 16384) <> 0 then
-  begin
-   FFinished := true;
-   Destroy;
-  end else FHandle := FThreadID;
-  IsMultiThread := true;
-  FFatalException := nil;
-}
-end;
-
-
-procedure TThread.SysDestroy;
-begin
- if not FFinished and not Suspended then
- begin
-  Terminate;
-  WaitFor;
- end;
-{
- if FHandle <> -1 then DosKillThread (cardinal (FHandle));
- FFatalException.Free;
- FFatalException := nil;
- inherited Destroy;
- RemoveThread (Self);
-}
-end;
-
-procedure TThread.Resume;
-begin
-{ FSuspended := not (DosResumeThread (cardinal (FHandle)) = 0);}
-end;
-
-
-procedure TThread.Suspend;
-begin
-{ FSuspended := DosSuspendThread (cardinal (FHandle)) = 0;}
-end;
-
-
-procedure TThread.Terminate;
-begin
- FTerminated := true;
-end;
-
-
-function TThread.WaitFor: Integer;
-var
- FH: cardinal;
-begin
-{ WaitFor := DosWaitThread (FH, dtWait);}
-end;
-
-

rtl/aros/arosthreads.inc

@@ -322,7 +322,7 @@ end;
 
 procedure EmptyFunc;
 begin
-  Delay(1);
+  DOSDelay(1);
   ReleaseSemaphore(@AROSThreadStruct^.EmptySemaphore);
 end;
 
@@ -379,7 +379,7 @@ begin
       NP_Entry, PtrUInt(@EmptyFunc),
       TAG_DONE, TAG_END]);
     ObtainSemaphore(@AROSThreadStruct^.EmptySemaphore);
-    Delay(1);
+    DOSDelay(1);
   end;
   //
   NewThread^.Task := CreateNewProcTags([

rtl/aros/i386/doslibf.inc

@@ -34,7 +34,7 @@ function IoErr: longint; syscall AOS_DOSBase 22;
 procedure dosExit(ErrCode: longint); syscall AOS_DOSBase 24;
 function SetProtection(const name: PChar; protect: longword): LongInt; syscall AOS_DOSBase 31;
 function DateStamp(date: PDateStamp): PDateStamp; syscall AOS_DOSBase 32;
-procedure Delay(ticks: LongWord); syscall AOS_DOSBase 33;
+procedure dosDelay(ticks: LongWord); syscall AOS_DOSBase 33;
 function AllocDosObject(Type_: LongWord; const Tags: PTagItem): Pointer; syscall AOS_DOSBase 38;
 procedure FreeDosObject(Type_: LongWord; Ptr: Pointer); syscall AOS_DOSBase 39;
 function SetFileDate(name: PChar; date: PDateStamp): LongBool; syscall AOS_DOSBase 66;

rtl/aros/i386/execf.inc

@@ -2,7 +2,7 @@
     This file is part of the Free Pascal run time library.
     Copyright (c) 2006 Karoly Balogh
 
-    exec functions (V40) for Amiga/PowerPC
+    exec functions for AROS/i386
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -28,6 +28,7 @@ function AllocSignal(signalNum: LongInt): ShortInt; syscall LocalExecBase 55;
 procedure FreeSignal(signalNum: LongInt); syscall LocalExecBase 56;
 procedure AddPort(port: PMsgPort); syscall LocalExecBase 59;
 procedure RemPort(port: PMsgPort); syscall LocalExecBase 60;
+procedure PutMsg(Port: PMsgPort; Message: PMessage); syscall AOS_ExecBase 61;
 function GetMsg(port: PMsgPort): PMessage; syscall LocalExecBase 62;
 procedure ReplyMsg(message : pMessage); syscall LocalExecBase 63;
 function WaitPort(port: PMsgPort): PMessage; syscall LocalExecBase 64;
@@ -40,6 +41,9 @@ procedure InitSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 93;
 procedure ObtainSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 94;
 procedure ReleaseSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 95;
 function AttemptSemaphore(SigSem: PSignalSemaphore): LongWord; syscall AOS_ExecBase 96;
+function CreateMsgPort: PMsgPort; syscall AOS_ExecBase 111;
+procedure DeleteMsgPort(Port: PMsgPort); syscall AOS_ExecBase 112;
+procedure ObtainSemaphoreShared(SigSem: PSignalSemaphore); syscall AOS_ExecBase 113;
 function CreatePool(requirements: Cardinal; puddleSize: Cardinal; threshSize: Cardinal): Pointer; syscall LocalExecBase 116;
 procedure DeletePool(poolHeader: Pointer); syscall LocalExecBase 117;
 function AllocPooled(poolHeader: Pointer; memSize: Cardinal): Pointer; syscall LocalExecBase 118;

rtl/aros/system.pp

@@ -67,6 +67,7 @@ var
   AROS_ThreadLib : Pointer; public name 'AROS_THREADLIB';
 
   ASYS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
+  ASYS_fileSemaphore: Pointer; { mutex semaphore for filelist access arbitration }
   ASYS_origDir  : LongInt; { original directory on startup }
   AOS_wbMsg    : Pointer;
   AOS_ConName  : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
@@ -141,7 +142,7 @@ begin
   //
   if AOS_wbMsg <> nil then
   begin
-    // forbid -> Amiga RKM Libraries Manual 
+    // forbid -> Amiga RKM Libraries Manual
     Forbid();
     // Reply WBStartupMessage
     ReplyMsg(AOS_wbMsg);
@@ -150,6 +151,50 @@ begin
   HaltProc(ExitCode);
 end;
 
+function GetWBArgsNum: Integer;
+var
+  startup: PWBStartup;
+begin
+  GetWBArgsNum := 0;
+  Startup := nil;
+  Startup := PWBStartup(AOS_wbMsg);
+  if Startup <> nil then
+  begin
+    Result := Startup^.sm_NumArgs - 1;
+  end;
+end;
+
+function GetWBArg(Idx: Integer): string;
+var
+  startup: PWBStartup;
+  wbarg: PWBArgList;
+  Path: array[0..254] of Char;
+  strPath: string;
+  Len: Integer;
+begin
+  GetWBArg := '';
+  FillChar(Path[0],255,#0);
+  Startup := PWBStartup(AOS_wbMsg);
+  if Startup <> nil then
+  begin
+    //if (Idx >= 0) and (Idx < Startup^.sm_NumArgs) then
+    begin
+      wbarg := Startup^.sm_ArgList;
+      if NameFromLock(wbarg^[Idx + 1].wa_Lock,@Path[0],255) then
+      begin
+        Len := 0;
+        while (Path[Len] <> #0) and (Len < 254) do
+          Inc(Len);
+        if Len > 0 then
+          if (Path[Len - 1] <> ':') and (Path[Len - 1] <> '/') then
+            Path[Len] := '/';
+        strPath := Path;
+      end;
+      Result := strPath + wbarg^[Idx + 1].wa_Name;
+    end;
+  end;
+end;
+
 { Generates correct argument array on startup }
 procedure GenerateArgs;
 var
@@ -175,6 +220,7 @@ var
   Start: Word;
   Ende: Word;
   LocalIndex: Word;
+  i: Integer;
   P : PChar;
   {$H+}
   Temp : string;
@@ -192,7 +238,14 @@ begin
   { check if we're started from Workbench }
   if AOS_wbMsg <> nil then
   begin
-    ArgC := 0;
+    ArgC := GetWBArgsNum + 1;
+    for i := 1 to ArgC - 1 do
+    begin
+      Temp := GetWBArg(i);
+      AllocArg(i, Length(Temp));
+      Move(Temp[1], Argv[i]^, Length(Temp));
+      Argv[i][Length(Temp)] := #0;
+    end;
     Exit;
   end;
 
@@ -215,7 +268,7 @@ begin
     begin
       while (p[count]<>#0) and (p[count]<>'"') and (p[count]<>LineEnding) do
       begin
-        Inc(Count) 
+        Inc(Count)
       end;
     end else
     begin
@@ -239,7 +292,7 @@ begin
     end;
     if inQuotes and (p[count] = '"') then
       Inc(Count);
-    inQuotes := False; 
+    inQuotes := False;
   end;
   argc:=localindex;
 end;
@@ -297,50 +350,6 @@ end;
                              ParamStr/Randomize
 *****************************************************************************}
 
-function GetWBArgsNum: Integer;
-var
-  startup: PWBStartup;
-begin
-  GetWBArgsNum := 0;
-  Startup := nil;
-  Startup := PWBStartup(AOS_wbMsg);
-  if Startup <> nil then
-  begin
-    Result := Startup^.sm_NumArgs - 1;
-  end;
-end;
-
-function GetWBArg(Idx: Integer): string;
-var
-  startup: PWBStartup;
-  wbarg: PWBArgList;
-  Path: array[0..254] of Char;
-  strPath: string;
-  Len: Integer;
-begin
-  GetWBArg := '';
-  FillChar(Path[0],255,#0);
-  Startup := PWBStartup(AOS_wbMsg);
-  if Startup <> nil then
-  begin
-    //if (Idx >= 0) and (Idx < Startup^.sm_NumArgs) then
-    begin
-      wbarg := Startup^.sm_ArgList;
-      if NameFromLock(wbarg^[Idx + 1].wa_Lock,@Path[0],255) then
-      begin
-        Len := 0;
-        while (Path[Len] <> #0) and (Len < 254) do
-          Inc(Len);
-        if Len > 0 then
-          if (Path[Len - 1] <> ':') and (Path[Len - 1] <> '/') then
-            Path[Len] := '/';
-        strPath := Path;
-      end;
-      Result := strPath + wbarg^[Idx + 1].wa_Name;
-    end;
-  end;
-end;
-
 { number of args }
 function paramcount : longint;
 begin
@@ -401,12 +410,18 @@ begin
   AOS_UtilityBase := OpenLibrary('utility.library', 0);
   if AOS_UtilityBase = nil then
     Halt(1);
-    
+
   { Creating the memory pool for growing heap }
   ASYS_heapPool := CreatePool(MEMF_ANY or MEMF_SEM_PROTECTED, growheapsize2, growheapsize1);
   if ASYS_heapPool = nil then
     Halt(1);
-  
+
+  { Initialize semaphore for filelist access arbitration }
+  ASYS_fileSemaphore:=AllocPooled(ASYS_heapPool,sizeof(TSignalSemaphore));
+  if ASYS_fileSemaphore = nil then
+    Halt(1);
+  InitSemaphore(ASYS_fileSemaphore);
+
   if AOS_wbMsg = nil then begin
     StdInputHandle := THandle(dosInput);
     StdOutputHandle := THandle(dosOutput);

rtl/aros/systhrd.inc

@@ -153,7 +153,7 @@ end;
 
 procedure SysThreadSwitch;
 begin
-  Delay(0);
+  DOSDelay(0);
 end;
 
 function SysSuspendThread(ThreadHandle: THandle): dword;

rtl/m68k/m68k.inc

@@ -384,7 +384,7 @@ asm
 @LMEMSET3:
 end;
 
-
+{$IFNDEF HASAMIGA}
 function InterLockedDecrement (var Target: longint) : longint;
   begin
   {$warning FIX ME}
@@ -424,6 +424,7 @@ function InterlockedCompareExchange(var Target: longint; NewValue: longint; Comp
     if Target = Comperand then
       Target := NewValue;
   end;
+{$ENDIF HASAMIGA}
 
 {$if defined(CPUM68K_HAS_BYTEREV) or defined(CPUM68K_HAS_ROLROR)}
 { Disabled for now, because not all cases below were tested. (KB) }

rtl/morphos/doslibf.inc

@@ -114,7 +114,7 @@ SysCall MOS_DOSBase 186;
 function DateStamp(date: PDateStamp location 'd1'): PDateStamp;
 SysCall MOS_DOSBase 192;
 
-procedure Delay(timeout: LongInt location 'd1');
+procedure DOSDelay(timeout: LongInt location 'd1');
 SysCall MOS_DOSBase 198;
 
 function WaitForChar(file1  : LongInt location 'd1';

rtl/morphos/execd.inc

@@ -490,7 +490,7 @@ type
   TMemEntry = packed record
     me_Un: packed record
     case Byte of
-      0 : (meu_Regs: DWord);
+      0 : (meu_Reqs: DWord);
       1 : (meu_Addr: Pointer)
     end;
     me_Length: DWord;
@@ -501,7 +501,7 @@ type
   TMemList = packed record
     ml_Node      : TNode;
     ml_NumEntries: Word;
-    ml_ME        : PMemEntry;
+    ml_ME        : array [0..0] of TMemEntry;
   end;
 
 

rtl/morphos/sysosh.inc

@@ -1,33 +0,0 @@
-{
-    This file is part of the Free Pascal run time library.
-    Copyright (c) 2001 by Free Pascal development team
-
-    This file implements all the base types and limits required
-    for a minimal POSIX compliant subset required to port the compiler
-    to a new OS.
-
-    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.
-
- **********************************************************************}
-
-{Platform specific information}
-type
-{$ifdef CPU64}
-  THandle = Int64;
-{$else CPU64}
-  THandle = Longint;
-{$endif CPU64}
-  TThreadID = THandle;
-  
-  PRTLCriticalSection = ^TRTLCriticalSection;
-  TRTLCriticalSection = record
-   Locked: boolean
-  end;
-
-
-

rtl/morphos/system.pp

@@ -64,6 +64,7 @@ var
   MOS_UtilityBase: Pointer;
 
   ASYS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
+  ASYS_fileSemaphore: Pointer; { mutex semaphore for filelist access arbitration }
   ASYS_origDir  : LongInt; { original directory on startup }
   MOS_ambMsg   : Pointer;
   MOS_ConName  : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
@@ -367,6 +368,11 @@ begin
  { Creating the memory pool for growing heap }
  ASYS_heapPool:=CreatePool(MEMF_FAST or MEMF_SEM_PROTECTED,growheapsize2,growheapsize1);
  if ASYS_heapPool=nil then Halt(1);
+ 
+ { Initialize semaphore for filelist access arbitration }
+ ASYS_fileSemaphore:=AllocPooled(ASYS_heapPool,sizeof(TSignalSemaphore));
+ if ASYS_fileSemaphore = nil then Halt(1);
+ InitSemaphore(ASYS_fileSemaphore);
 
  if MOS_ambMsg=nil then begin
    MOS_ConHandle:=0;

rtl/morphos/tthread.inc

@@ -1,157 +0,0 @@
-{
-    This file is part of the Free Component Library (FCL)
-    Copyright (c) 1999-2002 by the Free Pascal development team
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-{****************************************************************************}
-{*                             TThread                                      *}
-{****************************************************************************}
-
-{$WARNING This file is only a stub, and will not work!}
-
-const
- ThreadCount: longint = 0;
-
-(* Implementation of exported functions *)
-
-procedure AddThread (T: TThread);
-begin
- Inc (ThreadCount);
-end;
-
-
-procedure RemoveThread (T: TThread);
-begin
- Dec (ThreadCount);
-end;
-
-
-procedure TThread.CallOnTerminate;
-begin
- FOnTerminate (Self);
-end;
-
-
-function TThread.GetPriority: TThreadPriority;
-var
-{ PTIB: PThreadInfoBlock;
- PPIB: PProcessInfoBlock;}
- I: TThreadPriority;
-begin
-{
- DosGetInfoBlocks (@PTIB, @PPIB);
- with PTIB^.TIB2^ do
-  if Priority >= $300 then GetPriority := tpTimeCritical else
-      if Priority < $200 then GetPriority := tpIdle else
-  begin
-   I := Succ (Low (TThreadPriority));
-   while (I < High (TThreadPriority)) and
-    (Priority - Priorities [I] <= Priorities [Succ (I)] - Priority) do Inc (I);
-   GetPriority := I;
-  end;
-}
-end;
-
-
-procedure TThread.SetPriority(Value: TThreadPriority);
-{var
- PTIB: PThreadInfoBlock;
- PPIB: PProcessInfoBlock;}
-begin
-{ DosGetInfoBlocks (@PTIB, @PPIB);}
-(*
- PTIB^.TIB2^.Priority := Priorities [Value];
-*)
-{
- DosSetPriority (2, High (Priorities [Value]),
-                     Low (Priorities [Value]) - PTIB^.TIB2^.Priority, FHandle);}
-end;
-
-
-procedure TThread.SetSuspended(Value: Boolean);
-begin
- if Value <> FSuspended then
- begin
-  if Value then Suspend else Resume;
- end;
-end;
-
-
-procedure TThread.DoTerminate;
-begin
- if Assigned (FOnTerminate) then Synchronize (@CallOnTerminate);
-end;
-
-
-procedure TThread.SysCreate(CreateSuspended: Boolean;
-                            const StackSize: SizeUInt);
-var
-  Flags: cardinal;
-begin
-  AddThread (Self);
-{
-  FSuspended := CreateSuspended;
-  Flags := dtStack_Commited;
-  if FSuspended then Flags := Flags or dtSuspended;
-  if DosCreateThread (cardinal (FThreadID), @ThreadProc, pointer (Self),
-                                                        Flags, 16384) <> 0 then
-  begin
-   FFinished := true;
-   Destroy;
-  end else FHandle := FThreadID;
-  IsMultiThread := true;
-  FFatalException := nil;
-}
-end;
-
-
-procedure TThread.SysDestroy;
-begin
- if not FFinished and not Suspended then
- begin
-  Terminate;
-  WaitFor;
- end;
-{
- if FHandle <> -1 then DosKillThread (cardinal (FHandle));
- FFatalException.Free;
- FFatalException := nil;
- inherited Destroy;
- RemoveThread (Self);
-}
-end;
-
-procedure TThread.Resume;
-begin
-{ FSuspended := not (DosResumeThread (cardinal (FHandle)) = 0);}
-end;
-
-
-procedure TThread.Suspend;
-begin
-{ FSuspended := DosSuspendThread (cardinal (FHandle)) = 0;}
-end;
-
-
-procedure TThread.Terminate;
-begin
- FTerminated := true;
-end;
-
-
-function TThread.WaitFor: Integer;
-var
- FH: cardinal;
-begin
-{ WaitFor := DosWaitThread (FH, dtWait);}
-end;
-
-

rtl/objpas/classes/classesh.inc

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