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

--- Merging r30842 into '.':

Browse Source 
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 -
This commit is contained in:
marco 2015-06-17 11:56:51 +00:00
parent bc4bae3150
commit c07dbaddf1
27 changed files with 1350 additions and 428 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored
View File

@ -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

2
packages/fcl-process/src/amicommon/process.inc
View File

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

32
packages/fcl-process/src/amicommon/simpleipc.inc
View File

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

4
packages/morphunits/src/exec.pas
View File

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

990
rtl/amicommon/athreads.pp Normal file
View File

@ -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.

17
rtl/amicommon/osdebug.inc
View File

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

2
rtl/amicommon/osdebugh.inc
View File

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

9
rtl/amicommon/sysfile.inc
View File

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

16
rtl/amicommon/sysosh.inc
View File

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

4
rtl/amicommon/sysutils.pp
View File

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

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

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

2
rtl/amiga/m68k/doslibf.inc
View File

@ -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';

66
rtl/amiga/m68k/m68kamiga.inc Normal file
View File

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

8
rtl/amiga/system.pp
View File

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

157
rtl/amiga/tthread.inc
View File

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

4
rtl/aros/arosthreads.inc
View File

@ -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([

2
rtl/aros/i386/doslibf.inc
View File

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

6
rtl/aros/i386/execf.inc
View File

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

115
rtl/aros/system.pp
View File

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

2
rtl/aros/systhrd.inc
View File

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

3
rtl/m68k/m68k.inc
View File

@ -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) }

2
rtl/morphos/doslibf.inc
View File

@ -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';

4
rtl/morphos/execd.inc
View File

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

33
rtl/morphos/sysosh.inc
View File

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

6
rtl/morphos/system.pp
View File

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

157
rtl/morphos/tthread.inc
View File

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

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

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