amicommon: have a generic tthread.inc which even works, given there is a reasonably advanced ThreadManager

git-svn-id: trunk@30914 -

.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

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

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