diff --git a/.gitattributes b/.gitattributes index c6888cdada..fb80a6fe18 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8041,6 +8041,7 @@ 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 @@ -8061,7 +8062,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 @@ -8867,7 +8867,6 @@ rtl/morphos/prt0.as 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 diff --git a/rtl/amicommon/tthread.inc b/rtl/amicommon/tthread.inc new file mode 100644 index 0000000000..d735b6fa14 --- /dev/null +++ b/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; diff --git a/rtl/amiga/tthread.inc b/rtl/amiga/tthread.inc deleted file mode 100644 index cbbe3d6953..0000000000 --- a/rtl/amiga/tthread.inc +++ /dev/null @@ -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; - - diff --git a/rtl/morphos/tthread.inc b/rtl/morphos/tthread.inc deleted file mode 100644 index cbbe3d6953..0000000000 --- a/rtl/morphos/tthread.inc +++ /dev/null @@ -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; - - diff --git a/rtl/objpas/classes/classesh.inc b/rtl/objpas/classes/classesh.inc index 954c79445e..569972b197 100644 --- a/rtl/objpas/classes/classesh.inc +++ b/rtl/objpas/classes/classesh.inc @@ -1641,6 +1641,10 @@ type FSem: Pointer; FCond: Pointer; FInitialSuspended: boolean; +{$endif} +{$if defined(amiga) or defined(morphos)} + private + FInitialSuspended: boolean; {$endif} public constructor Create(CreateSuspended: Boolean;