Extend TThread with (class) methods and (class) properties from Delphi 2007 and newer.

Especially for the introduction of the Queue method the internal Synchronize handling was modified. Instead of handling only one event there is now a queue of events which is walked completely when CheckSynchronize is called. Each entry in the queue can carry a PRTLEvent which will be signaled when the contained method has been executed and thus Synchronize methods can still be blocking.
Exceptions inside the queued methods are either handed back to the calling method for Synchronize events or raised directly (after leaving the queue in a valid state) to the caller of CheckSynchronize.

The way platform specific adjustments can be made to TThread was changed. Instead of implementing the Constructor and Destructor directly one now implements the methods SysCreate and SysDestroy which are called from the Constructor and Destructor respectively. All RTLs were adjusted for this and should be controlled by the platform maintainers for correct compilation (Unix works).

The new method NameThreadForDebugging has two overloaded variants: one with the thread name as AnsiString and one with the thread name as UnicodeString.
By default the AnsiString variant calls the UnicodeString variant and the latter needs to be implemented. This can be changed by defining THREADNAME_IS_ANSISTRING for a platform. Then the UnicodeString variant calls the AnsiString one and the AnsiString one needs to be implemented.

Also added was a global property CPUCount for the System unit. This property returns the number of virtual cores of the system.

New methods and functions that should be implemented per platform are:
System.GetCPUCount (default returns 1)
Classes.TThread.GetSystemTimes (default zeros the struct)
Classes.TThread.NameThreadForDebugging (default does nothing)

More detailed information about the added methods will be available in the feature announcement mail.

git-svn-id: trunk@23227 -

rtl/amiga/tthread.inc

@@ -91,12 +91,11 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 var
   Flags: cardinal;
 begin
-  inherited Create;
   AddThread (Self);
 {
   FSuspended := CreateSuspended;
@@ -114,7 +113,7 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
  if not FFinished and not Suspended then
  begin

rtl/beos/tthread.inc

@@ -165,18 +165,18 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 var
   Flags: Integer;
 begin
-  inherited Create;
   AddThread(self);
   FSuspended := CreateSuspended;
   Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
   { Setup 16k of stack }
   FStackSize:=16384;
-  Getmem(FStackPointer,FStackSize);
-  inc(FStackPointer,FStackSize);
+  Getmem(FStackPointer,StackSize);
+  inc(FStackPointer,StackSize);
   FCallExitProcess:=false;
   { Clone }
   FHandle:= Clone(@ThreadProc,FStackPointer,Flags,self);
@@ -187,7 +187,7 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
   if not FFinished and not Suspended then
    begin
@@ -200,7 +200,6 @@ begin
   Freemem(FStackPointer);
   FFatalException.Free;
   FFatalException := nil;
-  inherited Destroy;
   RemoveThread(self);
 end;
 
@@ -454,14 +453,13 @@ begin
 end;
 
 { TThread }
-constructor TThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean; const StackSize: SizeUInt);
 var
   data : pointer;
 begin
   // lets just hope that the user doesn't create a thread
   // via BeginThread and creates the first TThread Object in there!
   InitThreads;
-  inherited Create;
   FSem := SemaphoreInit;
   FSuspended := CreateSuspended;
   FSuspendedExternal := false;
@@ -473,7 +471,7 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
   if FThreadID = GetCurrentThreadID then begin
     raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!');
@@ -493,7 +491,6 @@ begin
   FFatalException.Free;
   FFatalException := nil;
   SemaphoreDestroy(FSem);
-  inherited Destroy;
 end;
 
 procedure TThread.SetSuspended(Value: Boolean);

rtl/gba/tthread.inc

@@ -67,17 +67,16 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 var
   Flags: cardinal;
 begin
-  inherited Create;
   AddThread (Self);
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
  if not FFinished and not Suspended then
  begin

rtl/go32v2/tthread.inc

@@ -46,14 +46,14 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean; const StackSize: SizeUInt);
 
 begin
  {IsMultiThread := TRUE; }
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 
 begin
 end;

rtl/inc/thread.inc

@@ -20,6 +20,14 @@ Var
   fpc_threadvar_relocate_proc : TRelocateThreadVarHandler; public name 'FPC_THREADVAR_RELOCATE';
 {$endif THREADVAR_RELOCATED_ALREADY_DEFINED}
 
+{$ifndef HAS_GETCPUCOUNT}
+    function GetCPUCount: LongWord;
+      begin
+        Result := 1;
+      end;
+{$endif}
+
+
 {*****************************************************************************
                            Threadvar initialization
 *****************************************************************************}

rtl/inc/threadh.inc

@@ -18,6 +18,12 @@ const
   { includes 16384 bytes margin for stackchecking }
   DefaultStackSize = 4*1024*1024;
 
+{ every platform can have it's own implementation of GetCPUCount; use the define
+  HAS_GETCPUCOUNT to disable the default implementation which simply returns 1 }
+function GetCPUCount: LongWord;
+
+property CPUCount: LongWord read GetCPUCount;
+
 type
   PEventState = pointer;
   PRTLEvent   = type pointer;   // Windows=thandle, other=pointer to record.

rtl/morphos/tthread.inc

@@ -91,12 +91,11 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 var
   Flags: cardinal;
 begin
-  inherited Create;
   AddThread (Self);
 {
   FSuspended := CreateSuspended;
@@ -114,7 +113,7 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
  if not FFinished and not Suspended then
  begin

rtl/nativent/tthread.inc

@@ -1,15 +1,15 @@
 { Thread management routines }
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 begin
-  inherited Create;
+
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
-  inherited Destroy;
+
 end;
 
 procedure TThread.CallOnTerminate;

rtl/nds/tthread.inc

@@ -67,17 +67,16 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 var
   Flags: cardinal;
 begin
-  inherited Create;
   AddThread (Self);
 end;
 
 
-destructor TThread.Destroy;
+procedure  TThread.SysDestroy;
 begin
  if not FFinished and not Suspended then
  begin

rtl/netware/tthread.inc

@@ -125,12 +125,11 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 var
   Flags: Integer;
 begin
-  inherited Create;
   AddThread(self);
   FSuspended := CreateSuspended;
   { Create new thread }
@@ -141,7 +140,7 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
   if not FFinished then
   begin
@@ -153,7 +152,6 @@ begin
   end;
   FFatalException.Free;
   FFatalException := nil;
-  inherited Destroy;
   RemoveThread(self);          {remove it from the list of active threads}
 end;
 

rtl/netwlibc/tthread.inc

@@ -257,14 +257,13 @@ begin
 end;
 
 { TThread }
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 begin
   // lets just hope that the user doesn't create a thread
   // via BeginThread and creates the first TThread Object in there!
   InitThreads;
   AddThread(self);
-  inherited Create;
   FSem := SemaphoreInit;
   FSuspended := False;
   FSuspendedExternal := false;
@@ -276,7 +275,7 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
   if FThreadID = GetCurrentThreadID then begin
     raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!');
@@ -296,7 +295,6 @@ begin
   FFatalException.Free;
   FFatalException := nil;
   SemaphoreDestroy(FSem);
-  inherited Destroy;
   RemoveThread(self);          {remove it from the list of active threads}
 end;
 

rtl/objpas/classes/classes.inc

@@ -60,19 +60,84 @@ var
 { TThread implementation }
 
 { system independend threading code }
+
 var
-  { event that happens when gui thread is done executing the method}
-  ExecuteEvent: PRtlEvent;
-  { event executed by synchronize to wake main thread if it sleeps in CheckSynchronize }
+  { event executed by SychronizeInternal to wake main thread if it sleeps in
+    CheckSynchronize }
   SynchronizeTimeoutEvent: PRtlEvent;
-  { guard for synchronization variables }
-  SynchronizeCritSect: TRtlCriticalSection;
-  { method to execute }
-  SynchronizeMethod: TThreadMethod;
-  { should we execute the method? }
-  DoSynchronizeMethod: boolean;
-  { caught exception in gui thread, to be raised in calling thread }
-  SynchronizeException: Exception;
+  { the head of the queue containing the entries to be Synchronized - Nil if the
+    queue is empty }
+  ThreadQueueHead: TThread.PThreadQueueEntry;
+  { the tail of the queue containing the entries to be Synchronized - Nil if the
+    queue is empty }
+  ThreadQueueTail: TThread.PThreadQueueEntry;
+  { used for serialized access to the queue }
+  ThreadQueueLock: TRtlCriticalSection;
+  { this list holds all instances of external threads that need to be freed at
+    the end of the program }
+  ExternalThreads: TThreadList;
+threadvar
+  { the instance of the current thread; in case of an external thread this is
+    Nil until TThread.GetCurrentThread was called once (the RTLs need to ensure
+    that threadvars are initialized with 0!) }
+  CurrentThreadVar: TThread;
+
+
+type
+  { this type is used if a thread is created using
+    TThread.CreateAnonymousThread }
+  TAnonymousThread = class(TThread)
+  private
+    fProc: TProcedure;
+  protected
+    procedure Execute; override;
+  public
+    { as in TThread aProc needs to be changed to TProc once closures are
+      supported }
+    constructor Create(aProc: TProcedure);
+  end;
+
+
+procedure TAnonymousThread.Execute;
+begin
+  fProc();
+end;
+
+
+constructor TAnonymousThread.Create(aProc: TProcedure);
+begin
+  { an anonymous thread is created suspended and with FreeOnTerminate set }
+  inherited Create(True);
+  FreeOnTerminate := True;
+  fProc := aProc;
+end;
+
+
+type
+  { this type is used by TThread.GetCurrentThread if the thread does not yet
+    have a value in CurrentThreadVar (Note: the main thread is also created as
+    a TExternalThread) }
+  TExternalThread = class(TThread)
+  protected
+    { dummy method to remove the warning }
+    procedure Execute; override;
+  public
+    constructor Create;
+  end;
+
+
+procedure TExternalThread.Execute;
+begin
+  { empty }
+end;
+
+
+constructor TExternalThread.Create;
+begin
+  FExternalThread := True;
+  { the parameter is unimportant if FExternalThread is True }
+  inherited Create(False);
+end;
 
 
 function ThreadProc(ThreadObjPtr: Pointer): PtrInt;
@@ -93,8 +158,10 @@ function ThreadProc(ThreadObjPtr: Pointer): PtrInt;
       { The thread may be already terminated at this point, e.g. if it was intially
         suspended, or if it wasn't ever scheduled for execution for whatever reason.
         So bypass user code if terminated. }
-      if not Thread.Terminated then
+      if not Thread.Terminated then begin
+        CurrentThreadVar := Thread;
         Thread.Execute;
+      end;
     except
       Thread.FFatalException := TObject(AcquireExceptionObject);
     end;
@@ -110,6 +177,29 @@ function ThreadProc(ThreadObjPtr: Pointer): PtrInt;
 { system-dependent code }
 {$i tthread.inc}
 
+
+constructor TThread.Create(CreateSuspended: Boolean;
+                           const StackSize: SizeUInt);
+begin
+  inherited Create;
+  if FExternalThread then
+    FThreadID := GetCurrentThreadID
+  else
+    SysCreate(CreateSuspended, StackSize);
+end;
+
+
+destructor TThread.Destroy;
+begin
+  if not FExternalThread then
+    SysDestroy;
+  RemoveQueuedEvents(Self);
+  DoneSynchronizeEvent;
+  { set CurrentThreadVar to Nil? }
+  inherited Destroy;
+end;
+
+
 procedure TThread.Start;
 begin
   { suspend/resume are now deprecated in Delphi (they also don't work
@@ -132,40 +222,94 @@ begin
 // is fixed for all platforms (in case the fix for non-unix platforms also
 // requires this field at least)
 {$if defined(unix) or defined(windows)}
-  if not FInitialSuspended then
+  if not FExternalThread and not FInitialSuspended then
     Resume;
 {$endif}
 end;
 
 
-class procedure TThread.Synchronize(AThread: TThread; AMethod: TThreadMethod);
-  var
-    LocalSyncException: Exception;
+procedure ExecuteThreadQueueEntry(aEntry: TThread.PThreadQueueEntry);
+begin
+  if Assigned(aEntry^.Method) then
+    aEntry^.Method()
+  // enable once closures are supported
+  {else
+    aEntry^.ThreadProc();}
+end;
+
+
+procedure ThreadQueueAppend(aEntry: TThread.PThreadQueueEntry);
+begin
+  { do we really need a synchronized call? }
+  if aEntry^.Thread.ThreadID = MainThreadID then begin
+    ExecuteThreadQueueEntry(aEntry);
+    if not Assigned(aEntry^.SyncEvent) then
+      Dispose(aEntry);
+  end else begin
+    System.EnterCriticalSection(ThreadQueueLock);
+    try
+      { add the entry to the thread queue }
+      if Assigned(ThreadQueueTail) then begin
+        ThreadQueueTail^.Next := aEntry;
+      end else
+        ThreadQueueHead := aEntry;
+      ThreadQueueTail := aEntry;
+    finally
+      System.LeaveCriticalSection(ThreadQueueLock);
+    end;
+
+    { ensure that the main thread knows that something awaits }
+    RtlEventSetEvent(SynchronizeTimeoutEvent);
+    if assigned(WakeMainThread) then
+      WakeMainThread(aEntry^.Thread);
+
+    { is this a Synchronize or Queue entry? }
+    if Assigned(aEntry^.SyncEvent) then begin
+      RtlEventWaitFor(aEntry^.SyncEvent);
+      if Assigned(aEntry^.Exception) then
+        raise aEntry^.Exception;
+    end;
+  end;
+end;
+
+
+procedure TThread.InitSynchronizeEvent;
   begin
-    { do we really need a synchronized call? }
-    if GetCurrentThreadID=MainThreadID then
-      AMethod()
-    else
-      begin
-        System.EnterCriticalSection(SynchronizeCritSect);
-        SynchronizeException:=nil;
-        SynchronizeMethod:=AMethod;
+    if Assigned(FSynchronizeEntry) then
+      Exit;
 
-        { be careful, after this assignment Method could be already executed }
-        DoSynchronizeMethod:=true;
+    New(FSynchronizeEntry);
+    FillChar(FSynchronizeEntry^, SizeOf(TThreadQueueEntry), 0);
+    FSynchronizeEntry^.Thread := Self;
+    FSynchronizeEntry^.SyncEvent := RtlEventCreate;
+  end;
 
-        RtlEventSetEvent(SynchronizeTimeoutEvent);
 
-        if assigned(WakeMainThread) then
-          WakeMainThread(AThread);
+procedure TThread.DoneSynchronizeEvent;
+  begin
+    if not Assigned(FSynchronizeEntry) then
+      Exit;
 
-        { wait infinitely }
-        RtlEventWaitFor(ExecuteEvent);
-        LocalSyncException:=SynchronizeException;
-        System.LeaveCriticalSection(SynchronizeCritSect);
-        if assigned(LocalSyncException) then
-          raise LocalSyncException;
-      end;
+    RtlEventDestroy(FSynchronizeEntry^.SyncEvent);
+    Dispose(FSynchronizeEntry);
+    FSynchronizeEntry := Nil;
+  end;
+
+
+class procedure TThread.Synchronize(AThread: TThread; AMethod: TThreadMethod);
+  begin
+    { ensure that we have a TThread instance }
+    if not Assigned(AThread) then
+      AThread := CurrentThread;
+
+    { the Synchronize event is instantiated on demand }
+    AThread.InitSynchronizeEvent;
+
+    AThread.FSynchronizeEntry^.Method := AMethod;
+    ThreadQueueAppend(AThread.FSynchronizeEntry);
+
+    AThread.FSynchronizeEntry^.Method := Nil;
+    AThread.FSynchronizeEntry^.Next := Nil;
   end;
 
 
@@ -177,6 +321,9 @@ procedure TThread.Synchronize(AMethod: TThreadMethod);
 
 function CheckSynchronize(timeout : longint=0) : boolean;
   { assumes being called from GUI thread }
+  var
+    exceptobj: Exception;
+    tmpentry: TThread.PThreadQueueEntry;
   begin
     result:=false;
     { first sanity check }
@@ -194,20 +341,258 @@ function CheckSynchronize(timeout : longint=0) : boolean;
          else
            RtlEventResetEvent(SynchronizeTimeoutEvent);
 
-        if DoSynchronizeMethod then
-          begin
-            DoSynchronizeMethod:=false;
+        System.EnterCriticalSection(ThreadQueueLock);
+        try
+          { Note: we don't need to pay attention to recursive calls to
+                  Synchronize as those calls will be executed in the context of
+                  the GUI thread and thus will be executed immediatly instead of
+                  queuing them }
+          while Assigned(ThreadQueueHead) do begin
+            { step 1: execute the method }
+            exceptobj := Nil;
             try
-              SynchronizeMethod;
-              result:=true;
+              ExecuteThreadQueueEntry(ThreadQueueHead);
             except
-              SynchronizeException:=Exception(AcquireExceptionObject);
+              exceptobj := Exception(AcquireExceptionObject);
+            end;
+
+            { step 2: update the list }
+            tmpentry := ThreadQueueHead;
+            ThreadQueueHead := ThreadQueueHead^.Next;
+            if not Assigned(ThreadQueueHead) then
+              ThreadQueueTail := Nil;
+
+            { step 3: error handling and cleanup }
+            if Assigned(tmpentry^.SyncEvent) then begin
+              { for Synchronize entries we pass back the Exception and trigger
+                the event that Synchronize waits in }
+              tmpentry^.Exception := exceptobj;
+              RtlEventSetEvent(tmpentry^.SyncEvent)
+            end else begin
+              { for Queue entries we dispose the entry and raise the exception }
+              Dispose(tmpentry);
+              if Assigned(exceptobj) then
+                raise exceptobj;
             end;
-            RtlEventSetEvent(ExecuteEvent);
           end;
+        finally
+          System.LeaveCriticalSection(ThreadQueueLock);
+        end;
       end;
   end;
 
+
+class function TThread.GetCurrentThread: TThread;
+begin
+  { if this is the first time GetCurrentThread is called for an external thread
+    we need to create a corresponding TExternalThread instance }
+  if not Assigned(CurrentThreadVar) then
+    CurrentThreadVar := TExternalThread.Create;
+
+  Result := CurrentThreadVar;
+end;
+
+
+class function TThread.GetIsSingleProcessor: Boolean;
+begin
+  Result := FProcessorCount <= 1;
+end;
+
+
+procedure TThread.Queue(aMethod: TThreadMethod);
+begin
+  Queue(Self, aMethod);
+end;
+
+
+class procedure TThread.Queue(aThread: TThread; aMethod: TThreadMethod); static;
+var
+  queueentry: PThreadQueueEntry;
+begin
+  { ensure that we have a valid TThread instance }
+  if not Assigned(aThread) then
+    aThread := CurrentThread;
+
+  New(queueentry);
+  FillChar(queueentry^, SizeOf(TThreadQueueEntry), 0);
+  queueentry^.Thread := aThread;
+  queueentry^.Method := aMethod;
+
+  { the queueentry is freed by CheckSynchronize (or by RemoveQueuedEvents) }
+  ThreadQueueAppend(queueentry);
+end;
+
+
+class procedure TThread.RemoveQueuedEvents(aThread: TThread; aMethod: TThreadMethod);
+var
+  entry, tmpentry, lastentry: PThreadQueueEntry;
+begin
+  { anything to do at all? }
+  if not Assigned(aThread) or not Assigned(aMethod) then
+    Exit;
+
+  System.EnterCriticalSection(ThreadQueueLock);
+  try
+    lastentry := Nil;
+    entry := ThreadQueueHead;
+    while Assigned(entry) do begin
+      { first check for the thread }
+      if Assigned(aThread) and (entry^.Thread <> aThread) then begin
+        lastentry := entry;
+        entry := entry^.Next;
+        Continue;
+      end;
+      { then check for the method }
+      if entry^.Method <> aMethod then begin
+        lastentry := entry;
+        entry := entry^.Next;
+        Continue;
+      end;
+      { skip entries added by Synchronize }
+      if Assigned(entry^.SyncEvent) then begin
+        lastentry := entry;
+        entry := entry^.Next;
+        Continue;
+      end;
+
+      { ok, we need to remove this entry }
+
+      tmpentry := entry;
+      if Assigned(lastentry) then
+        lastentry^.Next := entry^.Next;
+      entry := entry^.Next;
+      if ThreadQueueHead = tmpentry then
+        ThreadQueueHead := entry;
+      if ThreadQueueTail = tmpentry then
+        ThreadQueueTail := lastentry;
+      { only dispose events added by Queue }
+      if not Assigned(tmpentry^.SyncEvent) then
+        Dispose(tmpentry);
+    end;
+  finally
+    System.LeaveCriticalSection(ThreadQueueLock);
+  end;
+end;
+
+
+class procedure TThread.RemoveQueuedEvents(aMethod: TThreadMethod);
+begin
+  RemoveQueuedEvents(Nil, aMethod);
+end;
+
+
+class procedure TThread.RemoveQueuedEvents(aThread: TThread);
+begin
+  RemoveQueuedEvents(aThread, Nil);
+end;
+
+
+class function TThread.CheckTerminated: Boolean;
+begin
+  { this method only works with threads created by TThread, so we can make a
+    shortcut here }
+  if not Assigned(CurrentThreadVar) then
+    raise EThreadExternalException.Create(SThreadExternal);
+  Result := CurrentThreadVar.FTerminated;
+end;
+
+
+class procedure TThread.SetReturnValue(aValue: Integer);
+begin
+  { this method only works with threads created by TThread, so we can make a
+    shortcut here }
+  if not Assigned(CurrentThreadVar) then
+    raise EThreadExternalException.Create(SThreadExternal);
+  CurrentThreadVar.FReturnValue := aValue;
+end;
+
+
+class function TThread.CreateAnonymousThread(aProc: TProcedure): TThread;
+begin
+  if not Assigned(aProc) then
+    raise Exception.Create(SNoProcGiven);
+  Result := TAnonymousThread.Create(aProc);
+end;
+
+
+{$ifdef THREADNAME_IS_ANSISTRING}
+{ the platform implements the AnsiString variant and the UnicodeString variant
+  simply calls the AnsiString variant }
+class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
+begin
+  NameThreadForDebugging(AnsiString(aThreadName), aThreadID);
+end;
+
+  {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
+class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
+begin
+  { empty }
+end;
+  {$endif}
+{$else}
+  {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
+{ the platform implements the UnicodeString variant and the AnsiString variant
+  simply calls the UnicodeString variant }
+class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
+begin
+  { empty }
+end;
+  {$endif}
+
+
+class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
+begin
+  NameThreadForDebugging(UnicodeString(aThreadName), aThreadID);
+end;
+{$endif}
+
+
+class procedure TThread.Yield;
+begin
+  ThreadSwitch;
+end;
+
+
+class procedure TThread.Sleep(aMilliseconds: Cardinal);
+begin
+  SysUtils.Sleep(aMilliseconds);
+end;
+
+
+class procedure TThread.SpinWait(aIterations: LongWord);
+begin
+  { yes, it's just a simple busy wait to burn some cpu cycles... and as the job
+    of this loop is to burn CPU cycles we switch off any optimizations that
+    could interfere with this (e.g. loop unrolling) }
+{$PUSH}
+{$OPTIMIZATION OFF}
+  while aIterations > 0 do
+    Dec(aIterations);
+{$POP}
+end;
+
+
+{$ifndef HAS_TTHREAD_GETSYSTEMTIMES}
+class procedure TThread.GetSystemTimes(out aSystemTimes: TSystemTimes);
+begin
+  { by default we just return a zeroed out record }
+  FillChar(aSystemTimes, SizeOf(aSystemTimes), 0);
+end;
+{$endif}
+
+
+class function TThread.GetTickCount: LongWord;
+begin
+  Result := SysUtils.GetTickCount;
+end;
+
+
+class function TThread.GetTickCount64: QWord;
+begin
+  Result := SysUtils.GetTickCount64;
+end;
+
+
 { TPersistent implementation }
 {$i persist.inc }
 
@@ -1702,11 +2087,11 @@ end;
 
 procedure CommonInit;
 begin
-  InitCriticalSection(SynchronizeCritSect);
-  ExecuteEvent:=RtlEventCreate;
   SynchronizeTimeoutEvent:=RtlEventCreate;
-  DoSynchronizeMethod:=false;
+  InitCriticalSection(ThreadQueueLock);
   MainThreadID:=GetCurrentThreadID;
+  ExternalThreads := TThreadList.Create;
+  TThread.FProcessorCount := CPUCount;
   InitCriticalsection(ResolveSection);
   InitHandlerList:=Nil;
   FindGlobalComponentList:=nil;
@@ -1721,6 +2106,7 @@ end;
 procedure CommonCleanup;
 var
   i: Integer;
+  tmpentry: TThread.PThreadQueueEntry;
 begin
   GlobalNameSpace.BeginWrite;
   with IntConstList.LockList do
@@ -1748,9 +2134,24 @@ begin
   InitHandlerList:=Nil;
   FindGlobalComponentList.Free;
   FindGlobalComponentList:=nil;
-  DoneCriticalSection(SynchronizeCritSect);
-  RtlEventDestroy(ExecuteEvent);
+  with ExternalThreads.LockList do
+    try
+      for i := 0 to Count - 1 do
+        TThread(Items[i]).Free;
+    finally
+      ExternalThreads.UnlockList;
+    end;
+  FreeAndNil(ExternalThreads);
   RtlEventDestroy(SynchronizeTimeoutEvent);
+  { clean up the queue, but keep in mind that the entries used for Synchronize
+    are owned by the corresponding TThread }
+  while Assigned(ThreadQueueHead) do begin
+    tmpentry := ThreadQueueHead;
+    ThreadQueueHead := tmpentry^.Next;
+    if not Assigned(tmpentry^.SyncEvent) then
+      Dispose(tmpentry);
+  end;
+  DoneCriticalSection(ThreadQueueLock);
 end;
 
 { TFiler implementation }

rtl/objpas/classes/classesh.inc

@@ -1540,6 +1540,7 @@ type
 { TThread }
 
   EThread = class(Exception);
+  EThreadExternalException = class(EThread);
   EThreadDestroyCalled = class(EThread);
   TSynchronizeProcVar = procedure;
   TThreadMethod = procedure of object;
@@ -1548,6 +1549,26 @@ type
     tpTimeCritical);
 
   TThread = class
+  private type
+    PThreadQueueEntry = ^TThreadQueueEntry;
+    TThreadQueueEntry = record
+      Method: TThreadMethod;
+      // uncomment once closures are supported
+      //ThreadProc: TThreadProcedure;
+      Thread: TThread;
+      Exception: Exception;
+      SyncEvent: PRtlEvent;
+      Next: PThreadQueueEntry;
+    end;
+  public type
+    TSystemTimes = record
+      IdleTime: QWord;
+      UserTime: QWord;
+      KernelTime: QWord;
+      NiceTime: QWord;
+    end;
+  private
+    class var FProcessorCount: LongWord;
   private
     FHandle: TThreadID;
     FTerminated: Boolean;
@@ -1557,16 +1578,27 @@ type
     FReturnValue: Integer;
     FOnTerminate: TNotifyEvent;
     FFatalException: TObject;
+    FExternalThread: Boolean;
+    FSynchronizeEntry: PThreadQueueEntry;
+    class function GetCurrentThread: TThread; static;
+    class function GetIsSingleProcessor: Boolean; static; inline;
     procedure CallOnTerminate;
     function GetPriority: TThreadPriority;
     procedure SetPriority(Value: TThreadPriority);
     procedure SetSuspended(Value: Boolean);
     function GetSuspended: Boolean;
+    procedure InitSynchronizeEvent;
+    procedure DoneSynchronizeEvent;
+    { these two need to be implemented per platform }
+    procedure SysCreate(CreateSuspended: Boolean;
+                             const StackSize: SizeUInt);
+    procedure SysDestroy;
   protected
     FThreadID: TThreadID; // someone might need it for pthread_* calls
     procedure DoTerminate; virtual;
     procedure Execute; virtual; abstract;
     procedure Synchronize(AMethod: TThreadMethod);
+    procedure Queue(aMethod: TThreadMethod);
     property ReturnValue: Integer read FReturnValue write FReturnValue;
     property Terminated: Boolean read FTerminated;
 {$ifdef windows}
@@ -1594,17 +1626,46 @@ type
     constructor Create(CreateSuspended: Boolean;
                        const StackSize: SizeUInt = DefaultStackSize);
     destructor Destroy; override;
+    { Note: Once closures are supported aProc will be changed to TProc }
+    class function CreateAnonymousThread(aProc: TProcedure): TThread; static;
+    { Use HAS_TTHREAD_NAMETHREADFORDEBUGGING to implement a platform specific
+      variant of the UnicodeString method. The AnsiString method calls the
+      UnicodeString method. If your platform's API only supports AnsiString you
+      can additionally define THREADNAME_IS_ANSISTRING to swap the logic. Then
+      the UnicodeString variant will call the AnsiString variant which can be
+      implemented for a specific platform }
+    class procedure NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID = TThreadID(-1)); static;
+    class procedure NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID = TThreadID(-1)); static; inline;
+    class procedure SetReturnValue(aValue: Integer); static;
+    class function CheckTerminated: Boolean; static;
+    class procedure Synchronize(AThread: TThread; AMethod: TThreadMethod);
+    class procedure Queue(aThread: TThread; aMethod: TThreadMethod); static;
+    class procedure RemoveQueuedEvents(aThread: TThread; aMethod: TThreadMethod); static;
+    class procedure RemoveQueuedEvents(aMethod: TThreadMethod); static;
+    class procedure RemoveQueuedEvents(aThread: TThread); static;
+    class procedure SpinWait(aIterations: LongWord); static;
+    class procedure Sleep(aMilliseconds: Cardinal); static;
+    class procedure Yield; static;
+    { use HAS_TTHREAD_GETSYSTEMTIMES to implement a platform specific variant
+      which does not return a zeroed record }
+    class procedure GetSystemTimes(out aSystemTimes: TSystemTimes); static;
+    class function GetTickCount: LongWord; static; deprecated 'Use TThread.GetTickCount64 instead';
+    class function GetTickCount64: QWord; static;
     procedure AfterConstruction; override;
     procedure Start;
     procedure Resume; deprecated;
     procedure Suspend; deprecated;
     procedure Terminate;
     function WaitFor: Integer;
-    class procedure Synchronize(AThread: TThread; AMethod: TThreadMethod);
+    class property CurrentThread: TThread read GetCurrentThread;
+    class property ProcessorCount: LongWord read FProcessorCount;
+    class property IsSingleProcessor: Boolean read GetIsSingleProcessor;
     property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
     property Handle: TThreadID read FHandle;
+    property ExternalThread: Boolean read FExternalThread;
     property Priority: TThreadPriority read GetPriority write SetPriority;
     property Suspended: Boolean read GetSuspended write SetSuspended;
+    property Finished: Boolean read FFinished;
     property ThreadID: TThreadID read FThreadID;
     property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
     property FatalException: TObject read FFatalException;

rtl/objpas/rtlconst.inc

@@ -203,6 +203,7 @@ ResourceString
   SNoTimers                     = 'No timers available';
   SNotOpenErr                   = 'No MCI-device opened';
   SNotPrinting                  = 'Printer is not currently printing';
+  SNoProcGiven                  = 'No procedure given';
   SNoVolumeLabel                = ': [ - No name - ]';
   SNumberExpected               = 'Number expected';
   SOKButton                     = 'OK';
@@ -268,6 +269,7 @@ ResourceString
   SSymbolExpected               = '%s expected';
   SThreadCreateError            = 'Thread creation error: %s';
   SThreadError                  = 'Thread Error: %s (%d)';
+  SThreadExternal               = 'Thread was created from extern';
   STooManyDeleted               = 'Too many rows or columns deleted';
   STooManyImages                = 'Too many images';
   STwoMDIForms                  = 'There is only one MDI window available';

rtl/os2/tthread.inc

@@ -101,12 +101,11 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 var
   Flags: cardinal;
 begin
-  inherited Create;
   AddThread;
   Flags := dtStack_Commited;
   FSuspended := CreateSuspended;
@@ -117,7 +116,7 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
  if not FFinished and not Suspended then
  begin
@@ -127,7 +126,6 @@ begin
 { if FHandle <> 0 then DosKillThread (cardinal (FHandle));}
  FFatalException.Free;
  FFatalException := nil;
- inherited Destroy;
  RemoveThread;
 end;
 

rtl/unix/tthread.inc

@@ -169,13 +169,12 @@ begin
 end;
 
 { TThread }
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 begin
   // lets just hope that the user doesn't create a thread
   // via BeginThread and creates the first TThread Object in there!
   InitThreads;
-  inherited Create;
   FSem := CurrentTM.SemaphoreInit();
   if FSem = nil then
     raise EThread.create('Semaphore init failed (possibly too many concurrent threads)');
@@ -194,19 +193,15 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
   if (FSem = nil) then
     { exception in constructor }
-    begin
-      inherited destroy;
-      exit;
-    end;
+    exit;
   if (FHandle = TThreadID(0)) then
   { another exception in constructor }
     begin
       CurrentTM.SemaphoreDestroy(FSem);
-      inherited destroy;
       exit;
     end;
   if (FThreadID = GetCurrentThreadID) then
@@ -238,7 +233,6 @@ begin
   { threadvars have been released by cthreads.ThreadMain -> DoneThread, or  }
   { or will be released (in case of FFreeOnTerminate) after this destructor }
   { has exited by ThreadFunc->EndThread->cthreads.CEndThread->DoneThread)   }
-  inherited Destroy;
 end;
 
 procedure TThread.SetSuspended(Value: Boolean);

rtl/wii/tthread.inc

@@ -67,17 +67,16 @@ begin
 end;
 
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 var
   Flags: cardinal;
 begin
-  inherited Create;
   AddThread (Self);
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
  if not FFinished and not Suspended then
  begin

rtl/win/tthread.inc

@@ -1,9 +1,8 @@
 { Thread management routines }
 
-constructor TThread.Create(CreateSuspended: Boolean;
-                           const StackSize: SizeUInt = DefaultStackSize);
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
 begin
-  inherited Create;
   FSuspended := CreateSuspended;
   FInitialSuspended := CreateSuspended;
   { Always start in suspended state, will be resumed in AfterConstruction if necessary
@@ -17,7 +16,7 @@ begin
 end;
 
 
-destructor TThread.Destroy;
+procedure TThread.SysDestroy;
 begin
   if FHandle<>0 then
     begin
@@ -38,7 +37,6 @@ begin
 
   FFatalException.Free;
   FFatalException := nil;
-  inherited Destroy;
 end;
 
 procedure TThread.CallOnTerminate;