{**************************************************************************************************}
{                                                                                                  }
{ Asynchronous function calls utilizing multiple threads.                                          }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is AsyncCalls.pas.                                                             }
{                                                                                                  }
{ The Initial Developer of the Original Code is Andreas Hausladen.                                 }
{ Portions created by Andreas Hausladen are Copyright (C) 2006-2016 Andreas Hausladen.             }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{ Contributor(s):                                                                                  }
{                                                                                                  }
{**************************************************************************************************}
{$A+,B-,C+,D-,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W+,X+,Y+,Z1}

unit AsyncCalls;

{.$DEFINE DEBUG_ASYNCCALLS}
{.$DEFINE DEBUG_ASYNCCALLS_ODS}
{.$DEFINE DEBUG_THREADSTATS}

{$IFDEF MSWINDOWS}
  {$IFNDEF CPUX64}
    {$DEFINE SUPPORT_LOCAL_FUNCTIONS}
  {$ENDIF ~CPUX64}
{$ENDIF MSWINDOWS}

interface

{$IFNDEF CONDITIONALEXPRESSIONS}
  {$IFDEF VER130}
    {$DEFINE DELPHI5}
  {$ELSE}
    'Your compiler version is not supported'
  {$ENDIF}
{$ELSE}
  {$IFDEF VER140}
    {$DEFINE DELPHI6}
    {.$MESSAGE ERROR 'Your compiler version is not supported'}
  {$ELSE}
    {$DEFINE DELPHI7_UP}
  {$ENDIF}

  {$WARN SYMBOL_PLATFORM OFF}
  {$WARN UNIT_PLATFORM OFF}
  {$IF CompilerVersion >= 15.0}
    {$WARN UNSAFE_TYPE OFF}
    {$WARN UNSAFE_CODE OFF}
    {$WARN UNSAFE_CAST OFF}
  {$IFEND}

  {$IF CompilerVersion >= 18.0}
    {$DEFINE SUPPORTS_INLINE}
  {$IFEND}

  {$IF CompilerVersion >= 20.0}
    {$DEFINE DELPHI2009_UP}
  {$IFEND}

  {$IF CompilerVersion >= 21.0}
    {$DEFINE DELPHI2010_UP}
  {$IFEND}
{$ENDIF}

{$IFDEF DEBUG_ASYNCCALLS}
  {$D+,C+}
{$ENDIF DEBUG_ASYNCCALLS}

uses
  Windows, Messages, SysUtils, Classes, Contnrs, ActiveX, SyncObjs;

type
  {$IFNDEF CONDITIONALEXPRESSIONS}
  INT_PTR = Integer;
  IInterface = IUnknown;
  {$ELSE}
    {$IF not declared(INT_PTR)}
  INT_PTR = Integer;
    {$IFEND}
  {$ENDIF}

  TAsyncIdleMsgMethod = procedure of object;

  {$IFDEF SUPPORT_LOCAL_FUNCTIONS}
  TCdeclFunc = Pointer; // function(Arg1: Type1; Arg2: Type2; ...); cdecl;
  TCdeclMethod = TMethod; // function(Arg1: Type1; Arg2: Type2; ...) of object; cdecl;
  TLocalAsyncProc = function: Integer;
  TLocalVclProc = function(Param: INT_PTR): INT_PTR;
  TLocalAsyncProcEx = function(Param: INT_PTR): INT_PTR;
  //TLocalAsyncForLoopProc = function(Index: Integer; SyncLock: TCriticalSection): Boolean;
  {$ENDIF SUPPORT_LOCAL_FUNCTIONS}

  TAsyncCallArgObjectProc = function(Arg: TObject): Integer;
  TAsyncCallArgIntegerProc = function(Arg: Integer): Integer;
  TAsyncCallArgStringProc = function(const Arg: string): Integer;
  TAsyncCallArgWideStringProc = function(const Arg: WideString): Integer;
  TAsyncCallArgInterfaceProc = function(const Arg: IInterface): Integer;
  TAsyncCallArgExtendedProc = function(const Arg: Extended): Integer;
  TAsyncCallArgVariantProc = function(const Arg: Variant): Integer;

  TAsyncCallArgObjectMethod = function(Arg: TObject): Integer of object;
  TAsyncCallArgIntegerMethod = function(Arg: Integer): Integer of object;
  TAsyncCallArgStringMethod = function(const Arg: string): Integer of object;
  TAsyncCallArgWideStringMethod = function(const Arg: WideString): Integer of object;
  TAsyncCallArgInterfaceMethod = function(const Arg: IInterface): Integer of object;
  TAsyncCallArgExtendedMethod = function(const Arg: Extended): Integer of object;
  TAsyncCallArgVariantMethod = function(const Arg: Variant): Integer of object;

  TAsyncCallArgObjectEvent = procedure(Arg: TObject) of object;
  TAsyncCallArgIntegerEvent = procedure(Arg: Integer) of object;
  TAsyncCallArgStringEvent = procedure(const Arg: string) of object;
  TAsyncCallArgWideStringEvent = procedure(const Arg: WideString) of object;
  TAsyncCallArgInterfaceEvent = procedure(const Arg: IInterface) of object;
  TAsyncCallArgExtendedEvent = procedure(const Arg: Extended) of object;
  TAsyncCallArgVariantEvent = procedure(const Arg: Variant) of object;

  TAsyncCallArgRecordProc = function(var Arg{: TRecordType}): Integer;
  TAsyncCallArgRecordMethod = function(var Arg{: TRecordType}): Integer of object;
  TAsyncCallArgRecordEvent = procedure(var Arg{: TRecordType}) of object;

  EAsyncCallError = class(Exception);

  IAsyncCall = interface
    { Sync() waits until the asynchronous call has finished and returns the
      result value of the called function if that exists. }
    function Sync: Integer;

    { Finished() returns True if the asynchronous call has finished. }
    function Finished: Boolean;

    { ReturnValue() returns the result of the asynchronous call. It raises an
      exception if called before the function has finished. It returns 0 if the
      AsyncCall invocation was canceled. }
    function ReturnValue: Integer;

    { Canceled() returns True if the AsyncCall was canceled by CancelInvocation(). }
    function Canceled: Boolean;

    { ForceDifferentThread() tells AsyncCalls that the assigned function must
      not be executed in the current thread. }
    procedure ForceDifferentThread;

    { CancelInvocation() stopps the AsyncCall from being invoked. If the AsyncCall is already
      processed, a call to CancelInvocation() has no effect and the Canceled() function will
      return False as the AsyncCall wasn't canceled. }
    procedure CancelInvocation;

    { Forget() unlinks the IAsyncCall interface from the internal AsyncCall. This means that
      if the last reference to the IAsyncCall interface is gone, the asynchronous call will
      be still executed. The interface's methods will throw an exception if called after calling
      Forget(). The async function must not call into the main thread because it could be executed
      after the TThread.Synchronize/Queue mechanism was shut down by the RTL what can cause a
      dead lock. }
    procedure Forget;
  end;

  { *** Internal interface. Do not use it *** }
  IAsyncCallEx = interface
    ['{A31D8EE4-17B6-4FC7-AC94-77887201EE56}']
    function GetEvent: THandle;
    function SyncInThisThreadIfPossible: Boolean;
  end;

  IAsyncRunnable = interface
    ['{1A313BBD-0F89-43AD-8B57-BBA3205F4888}']
    procedure AsyncRun;
  end;


{ SetMaxAsyncCallThreads() controls how many threads can be used by the
  async call thread pool. The thread pool creates threads when they are needed.
  Allocated threads are not destroyed until the application has terminated, but
  they are suspended if not used. }
procedure SetMaxAsyncCallThreads(MaxThreads: Integer);
{ GetMaxAsyncCallThreads() returns the maximum number of threads that can
  exist in the thread pool. }
function GetMaxAsyncCallThreads: Integer;

{ AsyncCall() executes the given function/procedure in a separate thread. The
  result value of the asynchronous function is returned by IAsyncCall.Sync() and
  IAsyncCall.ReturnValue().
  The AsyncExec() function calls the IdleMsgMethod in a loop, while the async.
  method is executed.

Example:
  function FileAgeAsync(const Filename: string): Integer;
  begin
    Result := FileAge(Filename);
  end;

  var
    a: IAsyncCall;
  begin
    a := AsyncCall(FileAgeAsync, 'C:\Windows\notepad.exe');
    // do something
    Age := a.Sync;
  end;
}
function AsyncCall(Proc: TAsyncCallArgObjectProc; Arg: TObject): IAsyncCall; overload;
function AsyncCall(Proc: TAsyncCallArgIntegerProc; Arg: Integer): IAsyncCall; overload;
function AsyncCall(Proc: TAsyncCallArgStringProc; const Arg: string): IAsyncCall; overload;
function AsyncCall(Proc: TAsyncCallArgWideStringProc; const Arg: WideString): IAsyncCall; overload;
function AsyncCall(Proc: TAsyncCallArgInterfaceProc; const Arg: IInterface): IAsyncCall; overload;
function AsyncCall(Proc: TAsyncCallArgExtendedProc; const Arg: Extended): IAsyncCall; overload;
function AsyncCallVar(Proc: TAsyncCallArgVariantProc; const Arg: Variant): IAsyncCall; overload;

function AsyncCall(Method: TAsyncCallArgObjectMethod; Arg: TObject): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgIntegerMethod; Arg: Integer): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgStringMethod; const Arg: string): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgWideStringMethod; const Arg: WideString): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgInterfaceMethod; const Arg: IInterface): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgExtendedMethod; const Arg: Extended): IAsyncCall; overload;
function AsyncCallVar(Method: TAsyncCallArgVariantMethod; const Arg: Variant): IAsyncCall; overload;

function AsyncCall(Method: TAsyncCallArgObjectEvent; Arg: TObject): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgIntegerEvent; Arg: Integer): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgStringEvent; const Arg: string): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgWideStringEvent; const Arg: WideString): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgInterfaceEvent; const Arg: IInterface): IAsyncCall; overload;
function AsyncCall(Method: TAsyncCallArgExtendedEvent; const Arg: Extended): IAsyncCall; overload;
function AsyncCallVar(Method: TAsyncCallArgVariantEvent; const Arg: Variant): IAsyncCall; overload;

function AsyncCall(Runnable: IAsyncRunnable): IAsyncCall; overload;

procedure AsyncExec(Method: TNotifyEvent; Arg: TObject; IdleMsgMethod: TAsyncIdleMsgMethod);

{$IFDEF SUPPORT_LOCAL_FUNCTIONS}
{ LocalAsyncCall() executes the given local function/procedure in a separate thread.
  The result value of the asynchronous function is returned by IAsyncCall.Sync() and
  IAsyncCall.ReturnValue().
  The LocalAsyncExec() function calls the IdleMsgMethod while the local procedure is
  executed.

Example:
  procedure MainProc(const S: string);
  var
    Value: Integer;
    a: IAsyncCall;

    function DoSomething: Integer;
    begin
      if S = 'Abc' then
        Value := 1;
      Result := 0;
    end;

  begin
    a := LocalAsyncCall(@DoSomething);
    // do something
    a.Sync;

    LocalAsyncExec(@DoSomething, Application.ProcessMessages);
  end;
}
function LocalAsyncCall(LocalProc: TLocalAsyncProc): IAsyncCall;
function LocalAsyncCallEx(LocalProc: TLocalAsyncProcEx; Param: INT_PTR): IAsyncCall;
procedure LocalAsyncExec(Proc: TLocalAsyncProc; IdleMsgMethod: TAsyncIdleMsgMethod);



{ LocalVclCall() executes the given local function/procedure in the main thread. It
  uses the TThread.Synchronize function which blocks the current thread.
  LocalAsyncVclCall() execute the given local function/procedure in the main thread.
  It does not wait for the main thread to execute the function unless the current
  thread is the main thread. In that case it executes and waits for the specified
  function in the current thread like LocalVclCall().

  The result value of the asynchronous function is returned by IAsyncCall.Sync() and
  IAsyncCall.ReturnValue().

Example:
  procedure TForm1.MainProc;

    procedure DoSomething;

      procedure UpdateProgressBar(Percentage: Integer);
      begin
        ProgressBar.Position := Percentage;
        Sleep(20); // This delay does not affect the time for the 0..100 loop
                   // because UpdateProgressBar is non-blocking.
      end;

      procedure Finished;
      begin
        ShowMessage('Finished');
      end;

    var
      I: Integer;
    begin
      for I := 0 to 100 do
      begin
        // Do some time consuming stuff
        Sleep(30);
        LocalAsyncVclCall(@UpdateProgressBar, I); // non-blocking
      end;
      LocalVclCall(@Finished); // blocking
    end;

  var
    a: IAsyncCall;
  begin
    a := LocalAsyncCall(@DoSomething);
    a.ForceDifferentThread; // Do not execute in the main thread because this will
                            // change LocalAyncVclCall into a blocking LocalVclCall
    // do something
    //a.Sync; The Compiler will call this for us in the Interface._Release method
  end;
}

procedure LocalVclCall(LocalProc: TLocalVclProc; Param: INT_PTR = 0);
function LocalAsyncVclCall(LocalProc: TLocalVclProc; Param: INT_PTR = 0): IAsyncCall;
{$ENDIF SUPPORT_LOCAL_FUNCTIONS}


{ AsyncCallEx() executes the given function/procedure in a separate thread. The
  Arg parameter can be a record type. The fields of the record can be modified
  in the asynchon function.

Example:
  type
    TData = record
      Value: Integer;
    end;

  procedure TestRec(var Data: TData);
  begin
    Data.Value := 70;
  end;

  a := AsyncCallEx(@TestRec, MyData);
  a.Sync; // MyData.Value is now 70
}
function AsyncCallEx(Proc: TAsyncCallArgRecordProc; var Arg{: TRecordType}): IAsyncCall; overload;
function AsyncCallEx(Method: TAsyncCallArgRecordMethod; var Arg{: TRecordType}): IAsyncCall; overload;
function AsyncCallEx(Method: TAsyncCallArgRecordEvent; var Arg{: TRecordType}): IAsyncCall; overload;


{$IFDEF SUPPORT_LOCAL_FUNCTIONS}
{ The following AsyncCall() functions support variable parameters. All reference
  counted types are protected by an AddRef and later Release. The ShortString,
  Extended, Currency and Int64 types are internally copied to a temporary location.

Supported types:
  Integer      :  Arg: Integer
  Boolean      :  Arg: Boolean
  Char         :  Arg: AnsiChar
  WideChar     :  Arg: WideChar
  Int64        :  [const] Arg: Int64
  Extended     :  [const] Arg: Extended
  Currency     :  [const] Arg: Currency
  String       :  [const] Arg: ShortString
  Pointer      :  [const] Arg: Pointer
  PChar        :  [const] Arg: PChar
  Object       :  [const] Arg: TObject
  Class        :  [const] Arg: TClass
  AnsiString   :  [const] Arg: AnsiString
  UnicodeString:  [const] Arg: UnicodeString
  PWideChar    :  [const] Arg: PWideChar
  WideString   :  [const] Arg: WideString
  Interface    :  [const] Arg: IInterface
  Variant      :  const Arg: Variant

Example:
  procedure Test(const S: string; I: Integer; E: Extended; Obj: TObject); cdecl;
  begin
  end;

  AsyncCall(@Test, ['Hallo', 10, 3.5, MyObject]);
}
function AsyncCall(Proc: TCdeclFunc; const Args: array of const): IAsyncCall; overload;
function AsyncCall(Proc: TCdeclMethod; const Args: array of const): IAsyncCall; overload;
{$ENDIF SUPPORT_LOCAL_FUNCTIONS}



{ AsyncMultiSync() waits for the async calls and other handles to finish.
  MsgAsyncMultiSync() waits for the async calls, other handles and the message queue.

  Arguments:
    List            : An array of IAsyncCall interfaces for which the function
                      should wait.

    Handles         : An array of THandle for which the function should wait.

    WaitAll = True  : The function returns when all listed async calls have
                      finished. If Milliseconds is INFINITE the async calls
                      meight be executed in the current thread.
                      The return value is zero when all async calls have finished.
                      Otherwise it is -1.

    WaitAll = False : The function returns when at least one of the async calls
                      has finished. The return value is the list index of the
                      first finished async call. If there was a timeout, the
                      return value is -1.

    Milliseconds    : Specifies the number of milliseconds to wait until a
                      timeout happens. The value INFINITE lets the function wait
                      until all async calls have finished.

    dwWakeMask      : see Windows.MsgWaitForMultipleObjects()

  Limitations:
    Length(List)+Length(Handles) must not exceed MAXIMUM_ASYNC_WAIT_OBJECTS.

  Return value:
    WAIT_TIMEOUT
      The function timed out

    WAIT_OBJECT_0+index
      The first finished async call
    WAIT_OBJECT_0+Length(List)+index
      The first signaled handle
    WAIT_OBJECT_0+Length(List)+Length(Handles)
      A message was signaled

    WAIT_ABANDONED_0+index
      The abandoned async call
    WAIT_ABANDONED_0+Length(List)+index
      The abandoned handle

    WAIT_FAILED
      The function failed
}

const
  MAXIMUM_ASYNC_WAIT_OBJECTS = MAXIMUM_WAIT_OBJECTS - 3;

function AsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean = True;
  Milliseconds: Cardinal = INFINITE): Cardinal;
function AsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle;
  WaitAll: Boolean = True; Milliseconds: Cardinal = INFINITE): Cardinal;
function MsgAsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean;
  Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal;
function MsgAsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle;
  WaitAll: Boolean; Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal;

{$IFDEF SUPPORT_LOCAL_FUNCTIONS}
{
   EnterMainThread/LeaveMainThread can be used to temporary switch to the
   main thread. The code that should be synchonized (blocking) has to be put
   into a try/finally block and the LeaveMainThread() function must be called
   from the finally block. A missing try/finally will lead to an access violation.

   * All local variables can be used. (EBP points to the thread's stack while
     ESP points the the main thread's stack)
   * Unhandled exceptions are passed to the surrounding thread.
   * The integrated Debugger is not able to follow the execution flow. You have
     to use break points instead of "Step over/in".
   * Nested calls to EnterMainThread/LeaveMainThread are ignored. But they must
     strictly follow the try/finally structure.

   Example:

     procedure MyThreadProc;
     var
       S: string;
     begin
       Assert(GetCurrentThreadId <> MainThreadId);
       S := 'Hallo, I''m executed in the main thread';

       EnterMainThread;
       try
         Assert(GetCurrentThreadId = MainThreadId);
         ShowMessage(S);
       finally
         LeaveMainThread;
       end;

       Assert(GetCurrentThreadId <> MainThreadId);
     end;
}
procedure EnterMainThread;
procedure LeaveMainThread;
{$ENDIF SUPPORT_LOCAL_FUNCTIONS}


type
  TAsyncCall = class;

  { *** Internal class. Do not use it *** }
  { TInternalAsyncCall is the base class for all parameter based async call types }
  TInternalAsyncCall = class(TObject)
  private
    FNext: TInternalAsyncCall;

    FEvent: THandle;
    FFatalException: Exception;
    FFatalErrorAddr: Pointer;

    FRefCount: Integer;
    FReturnValue: Integer;
    FForceDifferentThread: Boolean;
    FCancelInvocation: Boolean;
    FCanceled: Boolean;
    FExecuted: Boolean;
    FFinished: Boolean;

    procedure InternExecuteAsyncCall;
    procedure InternExecuteSyncCall;
    procedure Quit(AReturnValue: Integer);
  protected
    { Decendants must implement this method. It is called when the async call
      should be executed. }
    function ExecuteAsyncCall: Integer; virtual; abstract;
  private
    constructor Create;
    procedure AddRef;
    procedure Release;

    function ExecuteAsync: TAsyncCall;

    function GetEvent: THandle;
    function SyncInThisThreadIfPossible: Boolean;

    function Sync: Integer;
    function Finished: Boolean;
    function ReturnValue: Integer;
    function Canceled: Boolean;
    procedure ForceDifferentThread;
    procedure CancelInvocation;
    procedure Forget;
  public
    destructor Destroy; override;
  end;

  { *** Internal class. Do not use it *** }
  TAsyncCall = class(TInterfacedObject, IAsyncCall, IAsyncCallEx)
  private
    FCall: TInternalAsyncCall;
    procedure CheckForget;

    { IAsyncCallEx }
    function GetEvent: THandle;
    function SyncInThisThreadIfPossible: Boolean;
  private
    constructor Create(ACall: TInternalAsyncCall);
    { IAsyncCall }
    function Sync: Integer;
    function Finished: Boolean;
    function ReturnValue: Integer;
    function Canceled: Boolean;
    procedure ForceDifferentThread;
    procedure CancelInvocation;
    procedure Forget;
  public
    destructor Destroy; override;
  end;

  { *** Internal class. Do not use it *** }
  { TSyncCall is a fake IAsyncCall implementor. The async call was already
    executed when the interface is returned. }
  TSyncCall = class(TInterfacedObject, IAsyncCall)
  private
    FReturnValue: Integer;
  private
    constructor Create(AReturnValue: Integer);
    { IAsyncCall }
    function Sync: Integer;
    function Finished: Boolean;
    function ReturnValue: Integer;
    function Canceled: Boolean;
    procedure ForceDifferentThread;
    procedure CancelInvocation;
    procedure Forget;
  end;

{$IFDEF DELPHI2009_UP}
type
  { *** Helper class *** }
  TMultiArgProcCall<TProc, T1> = class(TInternalAsyncCall)
  private
    FProc: TProc;
    FArg1: T1;
  public
    constructor Create(AProc: TProc; const AArg1: T1);
  end;

  TMultiArgProcCall<TProc, T1, T2> = class(TMultiArgProcCall<TProc, T1>)
  private
    FArg2: T2;
  public
    constructor Create(AProc: TProc; const AArg1: T1; const AArg2: T2);
  end;

  TMultiArgProcCall<TProc, T1, T2, T3> = class(TMultiArgProcCall<TProc, T1, T2>)
  private
    FArg3: T3;
  public
    constructor Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3);
  end;

  TMultiArgProcCall<TProc, T1, T2, T3, T4> = class(TMultiArgProcCall<TProc, T1, T2, T3>)
  private
    FArg4: T4;
  public
    constructor Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3; const AArg4: T4);
  end;

  TAsyncCalls = class(TObject)
  private
    type
      TAsyncCallArgGenericProc<T> = function(Arg: T): Integer;
      TAsyncCallArgGenericProc<T1, T2> = function(Arg1: T1; Arg2: T2): Integer;
      TAsyncCallArgGenericProc<T1, T2, T3> = function(Arg1: T1; Arg2: T2; Arg3: T3): Integer;
      TAsyncCallArgGenericProc<T1, T2, T3, T4> = function(Arg1: T1; Arg2: T2; Arg3: T3; Arg4: T4): Integer;
      TAsyncCallArgGenericMethod<T> = function(Arg: T): Integer of object;
      TAsyncCallArgGenericMethod<T1, T2> = function(Arg1: T1; Arg2: T2): Integer of object;
      TAsyncCallArgGenericMethod<T1, T2, T3> = function(Arg1: T1; Arg2: T2; Arg3: T3): Integer of object;
      TAsyncCallArgGenericMethod<T1, T2, T3, T4> = function(Arg1: T1; Arg2: T2; Arg3: T3; Arg4: T4): Integer of object;
      TIntFunc = reference to function: Integer;

      TAsyncCallArg<T> = class(TMultiArgProcCall<TAsyncCallArgGenericProc<T>, T>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArg<T1, T2> = class(TMultiArgProcCall<TAsyncCallArgGenericProc<T1, T2>, T1, T2>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArg<T1, T2, T3> = class(TMultiArgProcCall<TAsyncCallArgGenericProc<T1, T2, T3>, T1, T2, T3>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArg<T1, T2, T3, T4> = class(TMultiArgProcCall<TAsyncCallArgGenericProc<T1, T2, T3, T4>, T1, T2, T3, T4>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArgMethod<T> = class(TMultiArgProcCall<TAsyncCallArgGenericMethod<T>, T>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArgMethod<T1, T2> = class(TMultiArgProcCall<TAsyncCallArgGenericMethod<T1, T2>, T1, T2>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArgMethod<T1, T2, T3> = class(TMultiArgProcCall<TAsyncCallArgGenericMethod<T1, T2, T3>, T1, T2, T3>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArgMethod<T1, T2, T3, T4> = class(TMultiArgProcCall<TAsyncCallArgGenericMethod<T1, T2, T3, T4>, T1, T2, T3, T4>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallAnonymProc = class(TInternalAsyncCall)
      private
        FProc: TProc;
      protected
        function ExecuteAsyncCall: Integer; override;
      public
        constructor Create(AProc: TProc);
      end;

      TAsyncCallAnonymFunc = class(TInternalAsyncCall)
      private
        FProc: TIntFunc;
      protected
        function ExecuteAsyncCall: Integer; override;
      public
        constructor Create(AProc: TIntFunc);
      end;

      TAsyncVclCallAnonymProc = class(TInternalAsyncCall)
      private
        FProc: TProc;
      protected
        function ExecuteAsyncCall: Integer; override;
      public
        constructor Create(AProc: TProc);
      end;

  public
    { Invoke an asynchronous function call }
    class function Invoke<T>(Proc: TAsyncCallArgGenericProc<T>; const Arg: T): IAsyncCall; overload; static;
    class function Invoke<T>(Event: TAsyncCallArgGenericMethod<T>; const Arg: T): IAsyncCall; overload; static;
    class function Invoke<T1, T2>(Proc: TAsyncCallArgGenericProc<T1, T2>; const Arg1: T1; const Arg2: T2): IAsyncCall; overload; static;
    class function Invoke<T1, T2>(Event: TAsyncCallArgGenericMethod<T1, T2>; const Arg1: T1; const Arg2: T2): IAsyncCall; overload; static;
    class function Invoke<T1, T2, T3>(Proc: TAsyncCallArgGenericProc<T1, T2, T3>; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall; overload; static;
    class function Invoke<T1, T2, T3>(Event: TAsyncCallArgGenericMethod<T1, T2, T3>; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall; overload; static;
    class function Invoke<T1, T2, T3, T4>(Proc: TAsyncCallArgGenericProc<T1, T2, T3, T4>; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall; overload; static;
    class function Invoke<T1, T2, T3, T4>(Event: TAsyncCallArgGenericMethod<T1, T2, T3, T4>; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall; overload; static;

    { Invoke an asynchronous anonymous method call }
    class function Invoke(Func: TIntFunc): IAsyncCall; overload; static;
    class function Invoke(Proc: TProc): IAsyncCall; overload; static;

    { MsgExec waits for the @AsyncCall to finish. If there are any messages in
      the message queue and the function was called from the main thread, it will
      call @IdleMsgMethod. "Application.ProcessMessages" can be specified for
      @IdleMsgMethod. }
    class procedure MsgExec(AsyncCall: IAsyncCall; IdleMsgMethod: TAsyncIdleMsgMethod); static;

    { Synchronize with the VCL }

    { VCLSync returns when the anonymous method was called in the main thread }
    class procedure VCLSync(Proc: TProc); static;
    { VCLInvoke returns immediately. The anonymous method will be executed in
      the main thread. }
    class function VCLInvoke(Proc: TProc): IAsyncCall; static;
  end;
{$ENDIF DELPHI2009_UP}

implementation

{$IFDEF DELPHI5}
uses
  Forms; // AllocateHWnd
{$ENDIF DELPHI5}

resourcestring
  RsAsyncCallNotFinished = 'The asynchronous call is not finished yet';
  RsAsyncCallUnknownVarRecType = 'Unknown TVarRec type %d';
  RsLeaveMainThreadNestedError = 'Unpaired call to AsyncCalls.LeaveMainThread()';
  RsLeaveMainThreadThreadError = 'AsyncCalls.LeaveMainThread() was called outside of the main thread';
  RsForgetWasCalled = 'IAsyncCall.Forget was called. The interface isn''t connected to the asynchronous call anymore';
  RsNoVclSyncPossible = 'Cannot synchronize with the main thread anymore. Don''t call IAsyncCall.Forget for functions that access the VCL';

const
  WM_VCLSYNC = WM_USER + 12;
  WM_RAISEEXCEPTION = WM_USER + 13;

{$IFNDEF DELPHI7_UP}
var
  SyncEvent: THandle;

type
  TThread = class(Classes.TThread)
  {$IFDEF DELPHI6}
  private
    class procedure WakeMainThread(Sender: TObject);
  {$ENDIF DELPHI6}
  public
    class procedure StaticSynchronize(AThread: TThread; AMethod: TThreadMethod);
  end;

class procedure TThread.StaticSynchronize(AThread: TThread; AMethod: TThreadMethod);
var
  Obj: TThread;
begin
  if GetCurrentThreadId = MainThreadId then
    AMethod
  else if AThread <> nil then
    AThread.Synchronize(AMethod)
  else
  begin
    {$WARNINGS OFF} // suppress abstract class warning
    Obj := TThread.Create(True);
    {$WARNINGS ON}
    try
      Obj.Synchronize(AMethod);
    finally
      Obj.Free;
    end;
  end;
end;
{$ENDIF ~DELPHI7_UP}

procedure StaticSynchronize(AMethod: TThreadMethod);
begin
  {$IFDEF DELPHI2010_UP}
  TThread.Synchronize(nil, AMethod);
  {$ELSE}
  TThread.StaticSynchronize(nil, AMethod);
  {$ENDIF DELPHI2010_UP}
end;

{$IFDEF DELPHI5}
function CheckSynchronize(Timeout: Integer = 0): Boolean;
begin
  Result := False;
end;

function AcquireExceptionObject: Pointer;
type
  PRaiseFrame = ^TRaiseFrame;
  TRaiseFrame = record
    NextRaise: PRaiseFrame;
    ExceptAddr: Pointer;
    ExceptObject: TObject;
    ExceptionRecord: PExceptionRecord;
  end;
begin
  if RaiseList <> nil then
  begin
    Result := PRaiseFrame(RaiseList)^.ExceptObject;
    PRaiseFrame(RaiseList)^.ExceptObject := nil;
  end
  else
    Result := nil;
end;
{$ENDIF DELPHI5}

{$IFDEF DELPHI6}
var
  OrgWakeMainThread: TNotifyEvent;

class procedure TThread.WakeMainThread(Sender: TObject);
begin
  if Assigned(OrgWakeMainThread) then
    OrgWakeMainThread(Sender);
  SetEvent(SyncEvent);
end;

procedure HookWakeMainThread;
begin
  OrgWakeMainThread := Classes.WakeMainThread;
  Classes.WakeMainThread := TThread.WakeMainThread;
end;

procedure UnhookWakeMainThread;
begin
  Classes.WakeMainThread := OrgWakeMainThread;
end;
{$ENDIF DELPHI6}

{$IFNDEF DELPHI2009_UP}
// Needed for older Delphi versions
function InterlockedCompareExchange(var Destination: Integer; Exchange: Integer; Comparand: Integer): Integer;
asm
       XCHG    EAX, ECX
  LOCK CMPXCHG [ECX], EDX
end;
{$ENDIF ~DELPHI2009_UP}

type
  { TAsyncCallThread is a pooled thread. It looks itself for work. }
  TAsyncCallThread = class(TThread)
  {$IFDEF DEBUG_THREADSTATS}
  private
    FTaskCount: Integer;
    FTaskTime: Int64;
  {$ENDIF DEBUG_THREADSTATS}
  protected
    procedure Execute; override;
  public
    constructor Create(ACreateSuspended: Boolean);
  end;

  { TThreadPool contains a pool of threads that are either suspended or busy. }
  TThreadPool = class(TObject)
  private
    FWakeUpEvent: THandle;
    FThreadTerminateEvent: THandle;
    FSleepingThreadCount: Integer;
    FEnqueuedCallCount: Integer;
    FMaxThreads: Integer;
    FDestroying: Boolean;

    FThreadCount: Integer;
    FThreads: array[0..255] of TAsyncCallThread;

    FAsyncCallsCritSect: TRTLCriticalSection;
    FAsyncCallHead, FAsyncCallTail: TInternalAsyncCall;

    FNumberOfProcessors: Cardinal;
    {$IFDEF DEBUG_THREADSTATS}
    FSyncExecutedCount, FAsyncExecutedCount: Integer;
    {$ENDIF DEBUG_THREADSTATS}

    FMainThreadSyncEvent: THandle;
    FMainThreadVclHandle: HWND;
    procedure MainThreadWndProc(var Msg: TMessage);
    procedure ProcessMainThreadSync;

    procedure AllocThread;
    function GetNextAsyncCall: TInternalAsyncCall; // called from the threads

    procedure WakeUpThread;
    procedure Sleep;
  public
    constructor Create;
    destructor Destroy; override;

    procedure CheckDestroying;
    procedure SendVclSync(Call: TInternalAsyncCall);

    procedure AddAsyncCall(Call: TInternalAsyncCall);
    function RemoveAsyncCall(Call: TInternalAsyncCall): Boolean;

    property MaxThreads: Integer read FMaxThreads;
    property NumberOfProcessors: Cardinal read FNumberOfProcessors;
    property MainThreadSyncEvent: THandle read FMainThreadSyncEvent;
  end;

{ ---------------------------------------------------------------------------- }

  TAsyncCallArgObject = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgObjectProc;
    FArg: TObject;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgObjectProc; AArg: TObject);
  end;

  TAsyncCallArgString = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgStringProc;
    FArg: string;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgStringProc; const AArg: string);
  end;

  TAsyncCallArgWideString = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgWideStringProc;
    FArg: WideString;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgWideStringProc; const AArg: WideString);
  end;

  TAsyncCallArgInterface = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgInterfaceProc;
    FArg: IInterface;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgInterfaceProc; const AArg: IInterface);
  end;

  TAsyncCallArgExtended = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgExtendedProc;
    FArg: Extended;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgExtendedProc; const AArg: Extended);
  end;

  TAsyncCallArgVariant = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgVariantProc;
    FArg: Variant;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgVariantProc; const AArg: Variant);
  end;

{ ---------------------------------------------------------------------------- }

  {$IFDEF SUPPORT_LOCAL_FUNCTIONS}
  TAsyncCallLocalProc = class(TInternalAsyncCall)
  private
    FProc: TLocalAsyncProc;
    FBasePointer: Pointer;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TLocalAsyncProc; ABasePointer: Pointer);
  end;

  TAsyncCallLocalProcEx = class(TInternalAsyncCall)
  private
    FProc: TLocalAsyncProc;
    FBasePointer: Pointer;
    FParam: INT_PTR;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TLocalAsyncProc; AParam: INT_PTR; ABasePointer: Pointer);
  end;

  TAsyncVclCallLocalProc = class(TInternalAsyncCall)
  private
    FProc: TLocalVclProc;
    FBasePointer: Pointer;
    FParam: INT_PTR;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TLocalVclProc; AParam: INT_PTR; ABasePointer: Pointer);
  end;
  {$ENDIF SUPPORT_LOCAL_FUNCTIONS}

{ ---------------------------------------------------------------------------- }

  TAsyncCallMethodArgObject = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgObjectMethod;
    FArg: TObject;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgObjectMethod; AArg: TObject);
  end;

  TAsyncCallMethodArgString = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgStringMethod;
    FArg: string;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgStringMethod; const AArg: string);
  end;

  TAsyncCallMethodArgWideString = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgWideStringMethod;
    FArg: WideString;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgWideStringMethod; const AArg: WideString);
  end;

  TAsyncCallMethodArgInterface = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgInterfaceMethod;
    FArg: IInterface;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgInterfaceMethod; const AArg: IInterface);
  end;

  TAsyncCallMethodArgExtended = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgExtendedMethod;
    FArg: Extended;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgExtendedMethod; const AArg: Extended);
  end;

  TAsyncCallMethodArgVariant = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgVariantMethod;
    FArg: Variant;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgVariantMethod; const AArg: Variant);
  end;

{ ---------------------------------------------------------------------------- }

  TAsyncCallArgRecord = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgRecordProc;
    FArg: Pointer;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgRecordProc; AArg: Pointer);
  end;

  TAsyncCallMethodArgRecord = class(TInternalAsyncCall)
  private
    FProc: TAsyncCallArgRecordMethod;
    FArg: Pointer;
  protected
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: TAsyncCallArgRecordMethod; AArg: Pointer);
  end;

  {$IFDEF SUPPORT_LOCAL_FUNCTIONS}
  TAsyncCallArrayOfConst = class(TInternalAsyncCall)
  private
    FProc: function: Integer register;
    FArgs: array of TVarRec;
  protected
    procedure CopyVarRec(const Data: TVarRec; var Result: TVarRec);
    function ExecuteAsyncCall: Integer; override;
  public
    constructor Create(AProc: Pointer; const AArgs: array of const); overload;
    constructor Create(AProc: Pointer; MethodData: TObject; const AArgs: array of const); overload;
    destructor Destroy; override;
  end;
  {$ENDIF SUPPORT_LOCAL_FUNCTIONS}

{ ---------------------------------------------------------------------------- }
var
  ThreadPool: TThreadPool;

procedure SetMaxAsyncCallThreads(MaxThreads: Integer);
begin
  if MaxThreads >= Length(ThreadPool.FThreads) then
    MaxThreads := Length(ThreadPool.FThreads);
  if MaxThreads >= 0 then
    ThreadPool.FMaxThreads := MaxThreads;
end;

function GetMaxAsyncCallThreads: Integer;
begin
  Result := ThreadPool.FMaxThreads;
end;

{ ---------------------------------------------------------------------------- }

function AsyncCall(Proc: TAsyncCallArgObjectProc; Arg: TObject): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg))
  else
    Result := TAsyncCallArgObject.Create(Proc, Arg).ExecuteAsync;
end;

function AsyncCall(Proc: TAsyncCallArgIntegerProc; Arg: Integer): IAsyncCall;
begin
  Result := AsyncCall(TAsyncCallArgObjectProc(Proc), TObject(Arg));
end;

function AsyncCall(Proc: TAsyncCallArgStringProc; const Arg: string): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg))
  else
    Result := TAsyncCallArgString.Create(Proc, Arg).ExecuteAsync;
end;

function AsyncCall(Proc: TAsyncCallArgWideStringProc; const Arg: WideString): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg))
  else
    Result := TAsyncCallArgWideString.Create(Proc, Arg).ExecuteAsync;
end;

function AsyncCall(Proc: TAsyncCallArgInterfaceProc; const Arg: IInterface): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg))
  else
    Result := TAsyncCallArgInterface.Create(Proc, Arg).ExecuteAsync;
end;

function AsyncCall(Proc: TAsyncCallArgExtendedProc; const Arg: Extended): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg))
  else
    Result := TAsyncCallArgExtended.Create(Proc, Arg).ExecuteAsync;
end;

function AsyncCallVar(Proc: TAsyncCallArgVariantProc; const Arg: Variant): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg))
  else
    Result := TAsyncCallArgVariant.Create(Proc, Arg).ExecuteAsync;
end;

{ ---------------------------------------------------------------------------- }

function AsyncCall(Method: TAsyncCallArgObjectMethod; Arg: TObject): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Method(Arg))
  else
    Result := TAsyncCallMethodArgObject.Create(Method, Arg).ExecuteAsync;
end;

function AsyncCall(Method: TAsyncCallArgIntegerMethod; Arg: Integer): IAsyncCall;
begin
  Result := AsyncCall(TAsyncCallArgObjectMethod(Method), TObject(Arg));
end;

function AsyncCall(Method: TAsyncCallArgStringMethod; const Arg: string): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Method(Arg))
  else
    Result := TAsyncCallMethodArgString.Create(Method, Arg).ExecuteAsync;
end;

function AsyncCall(Method: TAsyncCallArgWideStringMethod; const Arg: WideString): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Method(Arg))
  else
    Result := TAsyncCallMethodArgWideString.Create(Method, Arg).ExecuteAsync;
end;

function AsyncCall(Method: TAsyncCallArgInterfaceMethod; const Arg: IInterface): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Method(Arg))
  else
    Result := TAsyncCallMethodArgInterface.Create(Method, Arg).ExecuteAsync;
end;

function AsyncCall(Method: TAsyncCallArgExtendedMethod; const Arg: Extended): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Method(Arg))
  else
    Result := TAsyncCallMethodArgExtended.Create(Method, Arg).ExecuteAsync;
end;

function AsyncCallVar(Method: TAsyncCallArgVariantMethod; const Arg: Variant): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Method(Arg))
  else
    Result := TAsyncCallMethodArgVariant.Create(Method, Arg).ExecuteAsync;
end;

{ ---------------------------------------------------------------------------- }

function AsyncCall(Method: TAsyncCallArgObjectEvent; Arg: TObject): IAsyncCall;
begin
  Result := AsyncCall(TAsyncCallArgObjectMethod(Method), Arg);
end;

function AsyncCall(Method: TAsyncCallArgIntegerEvent; Arg: Integer): IAsyncCall;
begin
  Result := AsyncCall(TAsyncCallArgIntegerMethod(Method), Arg);
end;

function AsyncCall(Method: TAsyncCallArgStringEvent; const Arg: string): IAsyncCall;
begin
  Result := AsyncCall(TAsyncCallArgStringMethod(Method), Arg);
end;

function AsyncCall(Method: TAsyncCallArgWideStringEvent; const Arg: WideString): IAsyncCall;
begin
  Result := AsyncCall(TAsyncCallArgWideStringMethod(Method), Arg);
end;

function AsyncCall(Method: TAsyncCallArgInterfaceEvent; const Arg: IInterface): IAsyncCall;
begin
  Result := AsyncCall(TAsyncCallArgInterfaceMethod(Method), Arg);
end;

function AsyncCall(Method: TAsyncCallArgExtendedEvent; const Arg: Extended): IAsyncCall;
begin
  Result := AsyncCall(TAsyncCallArgExtendedMethod(Method), Arg);
end;

function AsyncCallVar(Method: TAsyncCallArgVariantEvent; const Arg: Variant): IAsyncCall;
begin
  Result := AsyncCallVar(TAsyncCallArgVariantMethod(Method), Arg);
end;

function AsyncCallRunnable(const Arg: IInterface): Integer;
begin
  IAsyncRunnable(Arg).AsyncRun;
  Result := 0;
end;

function AsyncCall(Runnable: IAsyncRunnable): IAsyncCall;
begin
  Result := AsyncCall(AsyncCallRunnable, IInterface(Runnable));
end;

{ ---------------------------------------------------------------------------- }

procedure AsyncExec(Method: TNotifyEvent; Arg: TObject; IdleMsgMethod: TAsyncIdleMsgMethod);
var
  Handle: IAsyncCall;
begin
  Handle := AsyncCall(Method, Arg);
  if Assigned(IdleMsgMethod) then
  begin
    Handle.ForceDifferentThread;
    IdleMsgMethod;
    while MsgAsyncMultiSync([Handle], False, INFINITE, QS_ALLINPUT or QS_ALLPOSTMESSAGE) = 1 do
      IdleMsgMethod;
  end;
end;

{ ---------------------------------------------------------------------------- }
{$IFDEF SUPPORT_LOCAL_FUNCTIONS}
function InternLocalAsyncCall(LocalProc: TLocalAsyncProc; BasePointer: Pointer): IAsyncCall;
begin
  Result := TAsyncCallLocalProc.Create(LocalProc, BasePointer).ExecuteAsync;
end;

function LocalAsyncCall(LocalProc: TLocalAsyncProc): IAsyncCall;
asm
  mov ecx, edx // interface return address
  mov edx, ebp
  jmp InternLocalAsyncCall
end;

function InternLocalAsyncCallEx(LocalProc: TLocalAsyncProc; Param: INT_PTR; BasePointer: Pointer): IAsyncCall;
begin
  Result := TAsyncCallLocalProcEx.Create(LocalProc, Param, BasePointer).ExecuteAsync;
end;

function LocalAsyncCallEx(LocalProc: TLocalAsyncProcEx; Param: INT_PTR): IAsyncCall;
asm
  push ecx // interface return address
  mov ecx, ebp
  call InternLocalAsyncCallEx
end;

procedure InternLocalAsyncExec(LocalProc: TLocalAsyncProc; IdleMsgMethod: TAsyncIdleMsgMethod; BasePointer: Pointer);
var
  Handle: IAsyncCall;
begin
  Handle := TAsyncCallLocalProc.Create(LocalProc, BasePointer).ExecuteAsync;
  if Assigned(IdleMsgMethod) then
  begin
    Handle.ForceDifferentThread;
    IdleMsgMethod;
    while MsgAsyncMultiSync([Handle], False, INFINITE, QS_ALLINPUT or QS_ALLPOSTMESSAGE) = 1 do
      IdleMsgMethod;
  end;
end;

{$STACKFRAMES ON}
procedure LocalAsyncExec(Proc: TLocalAsyncProc; IdleMsgMethod: TAsyncIdleMsgMethod);
asm // TMethod causes the compiler to generate a stackframe
  pop ebp // remove stackframe
  mov edx, ebp
  jmp InternLocalAsyncExec
end;
{$STACKFRAMES OFF}

{$ENDIF SUPPORT_LOCAL_FUNCTIONS}

{ ---------------------------------------------------------------------------- }

function AsyncCallEx(Proc: TAsyncCallArgRecordProc; var Arg{: TRecordType}): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg))
  else
    Result := TAsyncCallArgRecord.Create(Proc, @Arg).ExecuteAsync;
end;

function AsyncCallEx(Method: TAsyncCallArgRecordMethod; var Arg{: TRecordType}): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if ThreadPool.MaxThreads = 0 then
    Result := TSyncCall.Create(Method(Arg))
  else
    Result := TAsyncCallMethodArgRecord.Create(Method, @Arg).ExecuteAsync;
end;

function AsyncCallEx(Method: TAsyncCallArgRecordEvent; var Arg{: TRecordType}): IAsyncCall;
begin
  Result := AsyncCallEx(TAsyncCallArgRecordMethod(Method), Arg);
end;

{ ---------------------------------------------------------------------------- }

{$IFDEF SUPPORT_LOCAL_FUNCTIONS}
function AsyncCall(Proc: TCdeclFunc; const Args: array of const): IAsyncCall; overload;
var
  Call: TInternalAsyncCall;
begin
  Call := TAsyncCallArrayOfConst.Create(Proc, Args);
  if ThreadPool.MaxThreads = 0 then
  begin
    Call.InternExecuteSyncCall;
    Result := TAsyncCall.Create(Call);
  end
  else
    Result := Call.ExecuteAsync;
end;

function AsyncCall(Proc: TCdeclMethod; const Args: array of const): IAsyncCall; overload;
var
  Call: TInternalAsyncCall;
begin
  Call := TAsyncCallArrayOfConst.Create(Proc.Code, TObject(Proc.Data), Args);
  if ThreadPool.MaxThreads = 0 then
  begin
    Call.InternExecuteSyncCall;
    Result := TAsyncCall.Create(Call);
  end
  else
    Result := Call.ExecuteAsync;
end;
{$ENDIF SUPPORT_LOCAL_FUNCTIONS}

{ ---------------------------------------------------------------------------- }

function WaitForSingleObjectMainThread(AHandle: THandle; Timeout: Cardinal): Cardinal;
var
  Handles: array[0..2] of THandle;
begin
  Handles[0] := AHandle;
  Handles[1] := SyncEvent;
  Handles[2] := ThreadPool.MainThreadSyncEvent;
  {$IFDEF DELPHI6}
  HookWakeMainThread;
  try
  {$ENDIF DELPHI6}
  repeat
    Result := WaitForMultipleObjects(3, @Handles[0], False, Timeout);
    if Result = WAIT_OBJECT_0 + 1 then
      CheckSynchronize
    else if Result = WAIT_OBJECT_0 + 2 then
      ThreadPool.ProcessMainThreadSync;
  until (Result <> WAIT_OBJECT_0 + 1) and (Result <> WAIT_OBJECT_0 + 2);
  {$IFDEF DELPHI6}
  finally
    UnhookWakeMainThread;
  end;
  {$ENDIF DELPHI6}
end;

function WaitForMultipleObjectsMainThread(Count: Cardinal;
  const AHandles: array of THandle; WaitAll: Boolean; Timeout: Cardinal;
  MsgWait: Boolean; dwWakeMask: DWORD): Cardinal;
var
  Handles: array of THandle;
  Index: Cardinal;
  FirstFinished, OriginalCount: Cardinal;
begin
  { Wait for the specified events, for the VCL SyncEvent and for the MainThreadSync event }
  OriginalCount := Count;
  SetLength(Handles, Count + 2);
  Move(AHandles[0], Handles[0], Count * SizeOf(THandle));
  Handles[Count] := SyncEvent;
  Handles[Count + 1] := ThreadPool.MainThreadSyncEvent;
  {$IFDEF DELPHI6}
  HookWakeMainThread;
  try
  {$ENDIF DELPHI6}
  if not WaitAll then
  begin
    repeat
      if MsgWait then
      begin
        Result := MsgWaitForMultipleObjects(Count + 2, Handles[0], WaitAll, Timeout, dwWakeMask);
        if Result = WAIT_OBJECT_0 + Count + 2 then
        begin
          ThreadPool.ProcessMainThreadSync; // also uses the message queue
          Result := WAIT_OBJECT_0 + OriginalCount; // caller doesn't know about the 2 synchronization events
          Exit;
        end;
      end
      else
        Result := WaitForMultipleObjects(Count + 2, @Handles[0], WaitAll, Timeout);

      if Result = WAIT_OBJECT_0 + Count then
        CheckSynchronize
      else if Result = WAIT_OBJECT_0 + Count + 1 then
        ThreadPool.ProcessMainThreadSync;
    until (Result <> WAIT_OBJECT_0 + Count) and (Result <> WAIT_OBJECT_0 + Count + 1);
  end
  else
  begin
    FirstFinished := WAIT_TIMEOUT;
    repeat
      if MsgWait then
      begin
        Result := MsgWaitForMultipleObjects(Count + 2, Handles[0], False, Timeout, dwWakeMask);
        if Result = WAIT_OBJECT_0 + Count + 2 then
        begin
          ThreadPool.ProcessMainThreadSync; // also uses the message queue
          Result := WAIT_OBJECT_0 + OriginalCount; // caller doesn't know about the 2 synchronization events
          Exit;
        end;
      end
      else
        Result := WaitForMultipleObjects(Count + 2, @Handles[0], False, Timeout);

      if Result = WAIT_OBJECT_0 + Count then
        CheckSynchronize
      else if Result = WAIT_OBJECT_0 + Count + 1 then
        ThreadPool.ProcessMainThreadSync
      else
      if {(Result >= WAIT_OBJECT_0) and} (Result <= WAIT_OBJECT_0 + Count) then
      begin
        if FirstFinished = WAIT_TIMEOUT then
          FirstFinished := Result;
        Dec(Count);
        if Count > 0 then
        begin
          Index := Result - WAIT_OBJECT_0;
          Move(Handles[Index + 1], Handles[Index], ((Count + 2) - Index) * SizeOf(THandle));
        end;
      end
      else
        Break;
    until Count = 0;
    if Count = 0 then
      Result := FirstFinished;
  end;
  {$IFDEF DELPHI6}
  finally
    UnhookWakeMainThread;
  end;
  {$ENDIF DELPHI6}
end;

{ ---------------------------------------------------------------------------- }

function InternalAsyncMultiSync(const List: array of IAsyncCall; const Handles: array of THandle;
  WaitAll: Boolean; Milliseconds: Cardinal; MsgWait: Boolean; dwWakeMask: DWORD): Cardinal;

  function InternalWait(const List: array of IAsyncCall; const Handles: array of THandle;
    WaitAll: Boolean; Milliseconds: Cardinal; MsgWait: Boolean; dwWakeMask: DWORD): Cardinal;
  var
    WaitHandles: array of THandle;
    Mapping: array of Integer;
    I: Integer;
    Count: Cardinal;
    EventIntf: IAsyncCallEx;
    SignalState: Cardinal;
  begin
    SetLength(WaitHandles, Length(List) + Length(Handles));
    SetLength(Mapping, Length(WaitHandles));
    Count := 0;
    { Get the TInternalAsyncCall events }
    for I := 0 to High(List) do
    begin
      if (List[I] <> nil) and Supports(List[I], IAsyncCallEx, EventIntf) then
      begin
        WaitHandles[Count] := EventIntf.GetEvent;
        if WaitHandles[Count] <> 0 then
        begin
          Mapping[Count] := I;
          Inc(Count);
        end;
      end
      else
      if not WaitAll then
      begin
        { There are synchron calls in List[] and the caller does not want to
          wait for all handles. }
        Result := I;
        Exit;
      end;
    end;

    { Append other handles }
    for I := 0 to High(Handles) do
    begin
      WaitHandles[Count] := Handles[I];
      Mapping[Count] := Length(List) + I;
      Inc(Count);
    end;

    { Wait for the async calls }
    if Count > 0 then
    begin
      if GetCurrentThreadId = MainThreadID then
      begin
        SignalState := WaitForMultipleObjectsMainThread(Count, WaitHandles, WaitAll, Milliseconds, MsgWait, dwWakeMask);
        if SignalState = Count then // "message" was signaled
        begin
          Result := SignalState;
          Exit;
        end;
      end
      else
      begin
        if MsgWait then
        begin
          SignalState := MsgWaitForMultipleObjects(Count, WaitHandles[0], WaitAll, Milliseconds, dwWakeMask);
          if SignalState = Count then // "message" was signaled
          begin
            Result := SignalState;
            Exit;
          end;
        end
        else
          SignalState := WaitForMultipleObjects(Count, @WaitHandles[0], WaitAll, Milliseconds);
      end;
      if {(SignalState >= WAIT_OBJECT_0) and} (SignalState < WAIT_OBJECT_0 + Count) then
        Result := WAIT_OBJECT_0 + Mapping[SignalState - WAIT_OBJECT_0]
      else if (SignalState >= WAIT_ABANDONED_0) and (SignalState < WAIT_ABANDONED_0 + Count) then
        Result := WAIT_ABANDONED_0 + Mapping[SignalState - WAIT_ABANDONED_0]
      else
        Result := SignalState;
    end
    else
      Result := WAIT_OBJECT_0; // all AsyncCalls are already synchronized
  end;

  function InternalWaitAllInfinite(const List: array of IAsyncCall; const Handles: array of THandle): Cardinal;
  var
    I: Integer;
  begin
    { Wait for the async calls that aren't finished yet. }
    for I := 0 to High(List) do
      if List[I] <> nil then
        List[I].Sync;

    if Length(Handles) > 0 then
    begin
      if GetCurrentThreadId = MainThreadID then
        WaitForMultipleObjectsMainThread(Length(Handles), Handles, True, INFINITE, False, 0)
      else
        WaitForMultipleObjects(Length(Handles), @Handles[0], True, INFINITE);
    end;
    Result := WAIT_OBJECT_0;
  end;

var
  Count: Integer;
begin
  Count := Length(List) + Length(Handles);
  if (Count > 0) and (Count <= MAXIMUM_ASYNC_WAIT_OBJECTS) then
  begin
    if WaitAll and (Milliseconds = INFINITE) and not MsgWait and (GetCurrentThreadId <> MainThreadId) then
      Result := InternalWaitAllInfinite(List, Handles)
    else
      Result := InternalWait(List, Handles, WaitAll, Milliseconds, MsgWait, dwWakeMask);
  end
  else
    Result := WAIT_FAILED;
end;

function AsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean;
  Milliseconds: Cardinal): Cardinal;
begin
  Result := InternalAsyncMultiSync(List, [], WaitAll, Milliseconds, False, 0);
end;

function AsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle;
  WaitAll: Boolean = True; Milliseconds: Cardinal = INFINITE): Cardinal;
begin
  Result := InternalAsyncMultiSync(List, Handles, WaitAll, Milliseconds, False, 0);
end;

function MsgAsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean;
  Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal;
begin
  Result := InternalAsyncMultiSync(List, [], WaitAll, Milliseconds, True, dwWakeMask);
end;

function MsgAsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle;
  WaitAll: Boolean; Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal;
begin
  Result := InternalAsyncMultiSync(List, Handles, WaitAll, Milliseconds, True, dwWakeMask);
end;

procedure NotFinishedError(const FunctionName: string);
begin
  {$IFDEF DEBUG_ASYNCCALLS_ODS}
  if FunctionName <> '' then
    OutputDebugString(PChar(FunctionName));
  {$ENDIF DEBUG_ASYNCCALLS_ODS}
  raise EAsyncCallError.Create(RsAsyncCallNotFinished);
end;

procedure UnknownVarRecType(VType: Byte);
begin
  raise EAsyncCallError.CreateFmt(RsAsyncCallUnknownVarRecType, [VType]);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallThread }

function GetMainWnd(wnd: THandle; var MainWnd: THandle): LongBool; stdcall;
begin
  Result := False;
  MainWnd := wnd;
end;

constructor TAsyncCallThread.Create(ACreateSuspended: Boolean);
begin
  inherited Create(ACreateSuspended);
  Priority := tpHigher; // faster initial start of the thread. Is revoked after getting an IAsyncCall request
end;

procedure TAsyncCallThread.Execute;
var
  FAsyncCall: TInternalAsyncCall;
  CoInitialized: Boolean;
  {$IFDEF DEBUG_THREADSTATS}
  Start, Stop: Int64;
  {$ENDIF DEBUG_THREADSTATS}
begin
  CoInitialized := False;
  case CoInitialize(nil) of
    S_OK, S_FALSE:
      CoInitialized := True;
  end;
  try
    while True do
    begin
      FAsyncCall := ThreadPool.GetNextAsyncCall; // calls Sleep if nothing has to be done
      Priority := tpNormal;
      if FAsyncCall <> nil then
      begin
        {$IFDEF DEBUG_THREADSTATS}
        Inc(FTaskCount);
        QueryPerformanceCounter(Start);
        {$ENDIF DEBUG_THREADSTATS}
        try
          FAsyncCall.InternExecuteAsyncCall;
        except
          {$IFDEF DEBUG_ASYNCCALLS_ODS}
          on E: Exception do
            OutputDebugString(PChar('[' + E.ClassName + '] ' + E.Message));
          {$ENDIF DEBUG_ASYNCCALLS_ODS}
        end;
        {$IFDEF DEBUG_THREADSTATS}
        QueryPerformanceCounter(Stop);
        Inc(FTaskTime, Stop - Start);
        {$ENDIF DEBUG_THREADSTATS}
      end
      else if Terminated then
      begin
        { Thread will quit if the application terminates and no further task is in the queue. }
        FAsyncCall := ThreadPool.GetNextAsyncCall; // Doesn't go to sleep due to signaled ThreadPool.FThreadTerminateEvent
        if FAsyncCall = nil then
          Break;
      end;

      if FAsyncCall <> nil then
        FAsyncCall.Release;
    end;
  finally
    if CoInitialized then
      CoUninitialize;
  end;
end;

{ ---------------------------------------------------------------------------- }
{ TThreadPool }

constructor TThreadPool.Create;
var
  SysInfo: TSystemInfo;
begin
  inherited Create;
  FMainThreadVclHandle := AllocateHWnd(MainThreadWndProc);
  FMainThreadSyncEvent := CreateEvent(nil, False, False, nil);
  FWakeUpEvent := CreateEvent(nil, False, False, nil);
  FThreadTerminateEvent := CreateEvent(nil, True, False, nil);
  InitializeCriticalSectionAndSpinCount(FAsyncCallsCritSect, 4000);

  GetSystemInfo(SysInfo);
  FNumberOfProcessors := SysInfo.dwNumberOfProcessors;
  FMaxThreads := SysInfo.dwNumberOfProcessors * 4 - 2 {main thread};
  if FMaxThreads > Length(FThreads) then
    FMaxThreads := Length(FThreads);
end;

destructor TThreadPool.Destroy;
var
  I: Integer;
  Call: TInternalAsyncCall;
  Msg: TMsg;
begin
  FMaxThreads := FThreadCount; // Do not allocation new threads
  FDestroying := True; // => Sync in this thread because there is no other thread (required for FAsnycCallHead.Free)

  // Allow the threads to terminate if there is no task
  for I := FThreadCount - 1 downto 0 do
    FThreads[I].Terminate;
  // Wake up all sleeping threads and keep them awake so they can terminate
  SetEvent(FThreadTerminateEvent);
  // Wait and destroy the threads
  for I := FThreadCount - 1 downto 0 do
    FThreads[I].Free;

  // Clean up not yet released TInternalAsyncCalls objects
  while FAsyncCallHead <> nil do
  begin
    Call := FAsyncCallHead.FNext;
    FAsyncCallHead.Release;
    FAsyncCallHead := Call;
  end;

  // Handle pending FatalExceptions from "forgotten" async calls
  while PeekMessage(Msg, FMainThreadVclHandle, WM_RAISEEXCEPTION, WM_RAISEEXCEPTION, PM_REMOVE or PM_NOYIELD) do
    DispatchMessage(Msg);

  CloseHandle(FThreadTerminateEvent);
  CloseHandle(FWakeUpEvent);
  CloseHandle(FMainThreadSyncEvent);
  DeallocateHWnd(FMainThreadVclHandle);
  FMainThreadVclHandle := 0;
  DeleteCriticalSection(FAsyncCallsCritSect);

  inherited Destroy;
end;

procedure TThreadPool.CheckDestroying;
begin
  if FDestroying then
    raise EAsyncCallError.CreateRes(@RsNoVclSyncPossible);
end;

function TThreadPool.GetNextAsyncCall: TInternalAsyncCall;
begin
  { Dequeue }
  EnterCriticalSection(FAsyncCallsCritSect); // spinning
  try
    // Skip reference count handling, because we would increment (Result) and decrement (ListRemove) it.
    { Get the "oldest" async call }
    Result := FAsyncCallHead;
    if Result <> nil then
      Dec(FEnqueuedCallCount);
    if FAsyncCallHead <> nil then
      FAsyncCallHead := FAsyncCallHead.FNext;
    if Result = FAsyncCallTail then
      FAsyncCallTail := nil;
  finally
    LeaveCriticalSection(FAsyncCallsCritSect);
  end;
  { If there are further tasks in the queue, other threads may be able to process them.
    Without this, one thread could end up doing all the tasks if no new task is added. }
  if FAsyncCallHead <> nil then // unsafe access, but WakeUpThread would only wake up a thread that will immediately go to sleep
    WakeUpThread;

  { Nothing to do, go sleeping... }
  if Result = nil then
    Sleep;
end;

function TThreadPool.RemoveAsyncCall(Call: TInternalAsyncCall): Boolean;
var
  Item: TInternalAsyncCall;
begin
  Result := False;
  EnterCriticalSection(FAsyncCallsCritSect); // spinning, but we may take too much time
  try
    Item := FAsyncCallHead;
    if Item = Call then
    begin
      FAsyncCallHead := Call.FNext;
      if FAsyncCallHead = nil then
        FAsyncCallTail := nil;
      Dec(FEnqueuedCallCount);
      Result := True;
    end
    else
    begin
      while (Item <> nil) and (Item.FNext <> Call) do
        Item := Item.FNext;
      if Item <> nil then
      begin
        Item.FNext := Call.FNext;
        if Call = FAsyncCallTail then
          FAsyncCallTail := Item;
        Dec(FEnqueuedCallCount);
        Result := True;
      end;
    end;
  finally
    LeaveCriticalSection(FAsyncCallsCritSect);
  end;
  if Result then
    Call.Release; // removed from list
end;

procedure TThreadPool.AddAsyncCall(Call: TInternalAsyncCall);
var
  AvailableThreadCount: Integer;
begin
  { Enqueue }
  Call.AddRef; // added to list

  EnterCriticalSection(FAsyncCallsCritSect); // spinning
  if FAsyncCallTail = nil then
  begin
    FAsyncCallHead := Call;
    FAsyncCallTail := Call;
  end
  else
  begin
    FAsyncCallTail.FNext := Call;
    FAsyncCallTail := Call;
  end;
  AvailableThreadCount := FSleepingThreadCount - FEnqueuedCallCount;
  Inc(FEnqueuedCallCount);
  LeaveCriticalSection(FAsyncCallsCritSect);

  { We need to start another thread, if all threads are busy (not sleeping) or we have already
    enqueued tasks for all sleeping thread. }
  if AvailableThreadCount <= 0 then
  begin
    { Do an unsafe ThreadCount check. AllocThread will do a safe check if we were wrong here. }
    if FThreadCount < MaxThreads then
      AllocThread;
  end;

  { Wake up one of the sleeping threads. }
  WakeUpThread;
end;

procedure TThreadPool.AllocThread;
var
  Index: Integer;
begin
  { Increment FThreadCount if less than FMaxThreads }
  repeat
    Index := FThreadCount;
  until (Index = FMaxThreads) or (InterlockedCompareExchange(FThreadCount, Index + 1, Index) = Index);

  if Index < FMaxThreads then
    FThreads[Index] := TAsyncCallThread.Create(False);
end;

procedure TThreadPool.SendVclSync(Call: TInternalAsyncCall);
begin
  CheckDestroying;

  if not PostMessage(FMainThreadVclHandle, WM_VCLSYNC, 0, LPARAM(Call)) then
    Call.Quit(0)
  else
    SetEvent(FMainThreadSyncEvent);
end;

procedure TThreadPool.WakeUpThread;
begin
  // Wake up one of the sleeping threads
  SetEvent(FWakeUpEvent);
end;

procedure TThreadPool.Sleep;
// Wait for the wake up call from WakeUpThread
var
  Handles: array[0..1] of THandle;
begin
  Handles[0] := FWakeUpEvent;
  Handles[1] := FThreadTerminateEvent;

  InterlockedIncrement(FSleepingThreadCount);

  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_ABOVE_NORMAL); // wake up faster
  WaitForMultipleObjects(2, @Handles, False, INFINITE);
  //SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_NORMAL);  done in TAsyncThread.Execute

  InterlockedDecrement(FSleepingThreadCount);
end;

procedure TThreadPool.MainThreadWndProc(var Msg: TMessage);
begin
  try
    case Msg.Msg of
      WM_VCLSYNC:
        TInternalAsyncCall(Msg.LParam).InternExecuteSyncCall;
      WM_RAISEEXCEPTION:
        raise Exception(Msg.LParam) at Pointer(Msg.WParam);
    else
      Msg.Result := DefWindowProc(FMainThreadVclHandle, Msg.Msg, Msg.WParam, Msg.LParam);
    end;
  except
    if Assigned(ApplicationHandleException) then
      ApplicationHandleException(Self);
  end;
end;

procedure TThreadPool.ProcessMainThreadSync;
var
  Msg: TMsg;
begin
  Assert(GetCurrentThreadId = MainThreadId);
  while PeekMessage(Msg, FMainThreadVclHandle, 0, 0, PM_REMOVE) do
  begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
end;

{ ---------------------------------------------------------------------------- }
{ TSyncCall }

function TSyncCall.Canceled: Boolean;
begin
  Result := False;
end;

procedure TSyncCall.CancelInvocation;
begin
end;

constructor TSyncCall.Create(AReturnValue: Integer);
begin
  inherited Create;
  FReturnValue := AReturnValue;
end;

function TSyncCall.Finished: Boolean;
begin
  Result := True;
end;

procedure TSyncCall.ForceDifferentThread;
begin
end;

procedure TSyncCall.Forget;
begin
end;

function TSyncCall.ReturnValue: Integer;
begin
  Result := FReturnValue;
end;

function TSyncCall.Sync: Integer;
begin
  Result := FReturnValue;
end;

{ ---------------------------------------------------------------------------- }
{ TInternalAsyncCall }

constructor TInternalAsyncCall.Create;
begin
  inherited Create;
  FEvent := CreateEvent(nil, True, False, nil);
end;

destructor TInternalAsyncCall.Destroy;
begin
  if FEvent <> 0 then
  begin
    CloseHandle(FEvent);
    FEvent := 0;
  end;
  // TAsyncCall.Destroy either already called Sync() or we are a "forgotten" async call
  // and we need to handle the exception ourself by trying to throw it in the main thread
  // or just ignoring it.
  if FFatalException <> nil then
  begin
    if Assigned(ApplicationHandleException) and
       (ThreadPool.FMainThreadVclHandle <> 0) and IsWindow(ThreadPool.FMainThreadVclHandle) then
      PostMessage(ThreadPool.FMainThreadVclHandle, WM_RAISEEXCEPTION, WPARAM(FFatalErrorAddr), LPARAM(FFatalException))
    else
      FFatalException.Free;
  end;
  inherited Destroy;
end;

procedure TInternalAsyncCall.AddRef;
begin
  InterlockedIncrement(FRefCount);
end;

procedure TInternalAsyncCall.Release;
begin
  if InterlockedDecrement(FRefCount) = 0 then
    Destroy;
end;

function TInternalAsyncCall.Finished: Boolean;
begin
  if FCanceled or (FCancelInvocation and not FExecuted) then
    Result := True
  else
    Result := (FEvent = 0) or FFinished or (WaitForSingleObject(FEvent, 0) = WAIT_OBJECT_0);
end;

procedure TInternalAsyncCall.ForceDifferentThread;
begin
  FForceDifferentThread := True;
end;

procedure TInternalAsyncCall.Forget;
begin
  ForceDifferentThread;
end;

function TInternalAsyncCall.Canceled: Boolean;
begin
  Result := FCanceled;
end;

procedure TInternalAsyncCall.CancelInvocation;
begin
  FCancelInvocation := True;
end;

function TInternalAsyncCall.GetEvent: THandle;
begin
  Result := FEvent;
end;

procedure TInternalAsyncCall.InternExecuteAsyncCall;
var
  Value: Integer;
begin
  {$IFDEF DEBUG_THREADSTATS}
  InterlockedIncrement(ThreadPool.FAsyncExecutedCount);
  {$ENDIF DEBUG_THREADSTATS}
  Value := 0;
  try
    if not FCancelInvocation then
    begin
      FExecuted := True;
      Value := ExecuteAsyncCall;
    end
    else
      FCanceled := True;
  except
    FFatalErrorAddr := ExceptAddr;
    FFatalException := Exception(AcquireExceptionObject);
  end;
  Quit(Value);
end;

procedure TInternalAsyncCall.InternExecuteSyncCall;
var
  Value: Integer;
begin
  {$IFDEF DEBUG_THREADSTATS}
  InterlockedIncrement(ThreadPool.FSyncExecutedCount);
  {$ENDIF DEBUG_THREADSTATS}
  Value := 0;
  try
    if not FCancelInvocation then
    begin
      FExecuted := True;
      Value := ExecuteAsyncCall();
    end
    else
      FCanceled := True;
  finally
    // Let the exception be handled by the caller because we are in sync with it
    Quit(Value);
  end;
end;

procedure TInternalAsyncCall.Quit(AReturnValue: Integer);
begin
  FReturnValue := AReturnValue;
  FFinished := True;
  SetEvent(FEvent);
end;

function TInternalAsyncCall.ReturnValue: Integer;
var
  E: Exception;
begin
  if not Finished then
    NotFinishedError('IAsyncCall.ReturnValue');
  Result := FReturnValue;

  if FFatalException <> nil then
  begin
    E := FFatalException;
    FFatalException := nil;
    raise E at FFatalErrorAddr;
  end;
end;

function TInternalAsyncCall.Sync: Integer;
var
  E: Exception;
begin
  if not Finished then
  begin
    if not SyncInThisThreadIfPossible then
    begin
      if GetCurrentThreadId = MainThreadID then
      begin
        if WaitForSingleObjectMainThread(FEvent, INFINITE) <> WAIT_OBJECT_0 then
          NotFinishedError('IAsyncCall.Sync');
      end
      else
      if WaitForSingleObject(FEvent, INFINITE) <> WAIT_OBJECT_0 then
        NotFinishedError('IAsyncCall.Sync');
    end;
  end;
  Result := FReturnValue;

  if FFatalException <> nil then
  begin
    E := FFatalException;
    FFatalException := nil;
    raise E at FFatalErrorAddr;
  end;
end;

function TInternalAsyncCall.SyncInThisThreadIfPossible: Boolean;
begin
  // AddRef/Release protection isn't needed here because SyncInThisThreadIfPossible
  // is only called from an TAsynCall instance that holds a reference.
  if not Finished then
  begin
    Result := False;
    if not FForceDifferentThread or ThreadPool.FDestroying then
    begin
      { If no thread was assigned to this async call, remove it form the waiting
        queue and execute it in the current thread. }
      if ThreadPool.RemoveAsyncCall(Self) then
      begin
        InternExecuteSyncCall;
        Result := True;
      end;
    end;
  end
  else
    Result := True;
end;

function TInternalAsyncCall.ExecuteAsync: TAsyncCall;
begin
  Result := TAsyncCall.Create(Self);
  ThreadPool.AddAsyncCall(Self);
end;

{ ---------------------------------------------------------------------------- }
{$IFDEF SUPPORT_LOCAL_FUNCTIONS}
{ TAsyncCallArrayOfConst }

constructor TAsyncCallArrayOfConst.Create(AProc: Pointer; const AArgs: array of const);
var
  I: Integer;
begin
  inherited Create;
  FProc := AProc;
  SetLength(FArgs, Length(AArgs));
  for I := 0 to High(AArgs) do
    CopyVarRec(AArgs[I], FArgs[I]);
end;

constructor TAsyncCallArrayOfConst.Create(AProc: Pointer; MethodData: TObject; const AArgs: array of const);
var
  I: Integer;
begin
  inherited Create;
  FProc := AProc;
  SetLength(FArgs, 1 + Length(AArgs));

  // insert "Self"
  FArgs[0].VType := vtObject;
  FArgs[0].VObject := MethodData;

  for I := 0 to High(AArgs) do
    CopyVarRec(AArgs[I], FArgs[I + 1]);
end;

destructor TAsyncCallArrayOfConst.Destroy;
var
  I: Integer;
  V: PVarRec;
begin
  for I := 0 to High(FArgs) do
  begin
    V := @FArgs[I];
    case V.VType of
      vtAnsiString: AnsiString(V.VAnsiString) := '';
      vtWideString: WideString(V.VWideString) := '';
      {$IFDEF UNICODE}
      vtUnicodeString: UnicodeString(V.VUnicodeString) := '';
      {$ENDIF UNICODE}
      vtInterface : IInterface(V.VInterface) := nil;

      vtString    : Dispose(V.VString);
      vtExtended  : Dispose(V.VExtended);
      vtCurrency  : Dispose(V.VCurrency);
      vtInt64     : Dispose(V.VInt64);
      vtVariant   : Dispose(V.VVariant);
    end;
  end;
  inherited Destroy;
end;

procedure TAsyncCallArrayOfConst.CopyVarRec(const Data: TVarRec; var Result: TVarRec);
begin
  if (Data.VPointer <> nil) and
     (Data.VType in [vtString, vtAnsiString, vtWideString,
                     {$IFDEF UNICODE}vtUnicodeString,{$ENDIF} vtExtended,
                     vtCurrency, vtInt64, vtVariant, vtInterface]) then
  begin
    Result.VType := Data.VType;
    Result.VPointer := nil;
    { Copy and redirect TVarRec data to prevent conflicts with other threads,
      especially the calling thread. Otherwise reference counted types could
      be freed while this asynchron function is still executed. }
    case Result.VType of
      vtAnsiString: AnsiString(Result.VAnsiString) := AnsiString(Data.VAnsiString);
      vtWideString: WideString(Result.VWideString) := WideString(Data.VWideString);
      {$IFDEF UNICODE}
      vtUnicodeString: UnicodeString(Result.VUnicodeString) := UnicodeString(data.VUnicodeString);
      {$ENDIF UNICODE}
      vtInterface : IInterface(Result.VInterface) := IInterface(Data.VInterface);

      vtString    : begin New(Result.VString);   Result.VString^ := Data.VString^; end;
      vtExtended  : begin New(Result.VExtended); Result.VExtended^ := Data.VExtended^; end;
      vtCurrency  : begin New(Result.VCurrency); Result.VCurrency^ := Data.VCurrency^; end;
      vtInt64     : begin New(Result.VInt64);    Result.VInt64^ := Data.VInt64^; end;
      vtVariant   : begin New(Result.VVariant);  Result.VVariant^ := Data.VVariant^; end;
    end;
  end
  else
    Result := Data;
end;

function TAsyncCallArrayOfConst.ExecuteAsyncCall: Integer;
var
  I: Integer;
  V: ^TVarRec;
  ByteCount: Integer;
begin
  ByteCount := Length(FArgs) * SizeOf(Integer) + $40;
  { Create a zero filled buffer for functions that want more arguments than
    specified. }
  asm
    xor eax, eax
    mov ecx, $40 / 8
@@FillBuf:
    push eax
    push eax
    dec ecx
    jnz @@FillBuf
  end;

  for I := High(FArgs) downto 0 do // cdecl => right to left
  begin
    V := @FArgs[I];
    case V.VType of
      vtInteger:     // [const] Arg: Integer
        asm
          mov eax, V
          push [eax].TVarRec.VInteger
        end;

      vtBoolean,     // [const] Arg: Boolean
      vtChar:        // [const] Arg: AnsiChar
        asm
          mov eax, V
          xor edx, edx
          mov dl, [eax].TVarRec.VBoolean
          push edx
        end;

      vtWideChar:    // [const] Arg: WideChar
        asm
          mov eax, V
          xor edx, edx
          mov dx, [eax].TVarRec.VWideChar
          push edx
        end;

      vtExtended:    // [const] Arg: Extended
        asm
          add [ByteCount], 8 // two additional DWORDs
          mov eax, V
          mov edx, [eax].TVarRec.VExtended
          movzx eax, WORD PTR [edx + 8]
          push eax
          push DWORD PTR [edx + 4]
          push DWORD PTR [edx]
        end;

      vtCurrency,    // [const] Arg: Currency
      vtInt64:       // [const] Arg: Int64
        asm
          add [ByteCount], 4 // an additional DWORD
          mov eax, V
          mov edx, [eax].TVarRec.VCurrency
          push DWORD PTR [edx + 4]
          push DWORD PTR [edx]
        end;

      vtString,      // [const] Arg: ShortString
      vtPointer,     // [const] Arg: Pointer
      vtPChar,       // [const] Arg: PChar
      vtObject,      // [const] Arg: TObject
      vtClass,       // [const] Arg: TClass
      vtAnsiString,  // [const] Arg: AnsiString
      {$IFDEF UNICODE}
      vtUnicodeString, // [const] Arg: UnicodeString
      {$ENDIF UNICODE}
      vtPWideChar,   // [const] Arg: PWideChar
      vtVariant,     // const Arg: Variant
      vtInterface,   // [const]: IInterface
      vtWideString:  // [const] Arg: WideString
        asm
          mov eax, V
          push [eax].TVarRec.VPointer
        end;
    else
      UnknownVarRecType(V.VType);
    end;
  end;

  Result := FProc;

  asm // cdecl => we must clean up
    add esp, [ByteCount]
  end;
end;
{$ENDIF SUPPORT_LOCAL_FUNCTIONS}

{ ---------------------------------------------------------------------------- }
{ TAsyncCallArgRecord }

constructor TAsyncCallArgRecord.Create(AProc: TAsyncCallArgRecordProc; AArg: Pointer);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallArgRecord.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg^);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallMethodArgRecord }

constructor TAsyncCallMethodArgRecord.Create(AProc: TAsyncCallArgRecordMethod; AArg: Pointer);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallMethodArgRecord.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg^);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallArgObject }

constructor TAsyncCallArgObject.Create(AProc: TAsyncCallArgObjectProc; AArg: TObject);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallArgObject.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallMethodArgObject }

constructor TAsyncCallMethodArgObject.Create(AProc: TAsyncCallArgObjectMethod; AArg: TObject);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallMethodArgObject.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallArgString }

constructor TAsyncCallArgString.Create(AProc: TAsyncCallArgStringProc;
  const AArg: string);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallArgString.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallMethodArgString }

constructor TAsyncCallMethodArgString.Create(AProc: TAsyncCallArgStringMethod; const AArg: string);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallMethodArgString.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallArgWideString }

constructor TAsyncCallArgWideString.Create(AProc: TAsyncCallArgWideStringProc; const AArg: WideString);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallArgWideString.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallMethodArgWideString }

constructor TAsyncCallMethodArgWideString.Create(AProc: TAsyncCallArgWideStringMethod; const AArg: WideString);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallMethodArgWideString.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallArgInterface }

constructor TAsyncCallArgInterface.Create(AProc: TAsyncCallArgInterfaceProc; const AArg: IInterface);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallArgInterface.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallMethodArgInterface }

constructor TAsyncCallMethodArgInterface.Create(AProc: TAsyncCallArgInterfaceMethod; const AArg: IInterface);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallMethodArgInterface.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallArgExtended }

constructor TAsyncCallArgExtended.Create(AProc: TAsyncCallArgExtendedProc; const AArg: Extended);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallArgExtended.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallMethodArgExtended }

constructor TAsyncCallMethodArgExtended.Create(AProc: TAsyncCallArgExtendedMethod; const AArg: Extended);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallMethodArgExtended.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallArgVariant }

constructor TAsyncCallArgVariant.Create(AProc: TAsyncCallArgVariantProc; const AArg: Variant);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallArgVariant.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }
{ TAsyncCallMethodArgVariant }

constructor TAsyncCallMethodArgVariant.Create(AProc: TAsyncCallArgVariantMethod; const AArg: Variant);
begin
  inherited Create;
  FProc := AProc;
  FArg := AArg;
end;

function TAsyncCallMethodArgVariant.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg);
end;

{ ---------------------------------------------------------------------------- }

{$IFDEF SUPPORT_LOCAL_FUNCTIONS}
{ TAsyncCallLocalProc }

constructor TAsyncCallLocalProc.Create(AProc: TLocalAsyncProc; ABasePointer: Pointer);
begin
  inherited Create;
  @FProc := @AProc;
  FBasePointer := ABasePointer;
end;

function TAsyncCallLocalProc.ExecuteAsyncCall: Integer;
asm
  mov edx, [eax].TAsyncCallLocalProc.FBasePointer
  mov ecx, [eax].TAsyncCallLocalProc.FProc
  xor eax, eax // paramater
  push edx
  call ecx
  pop ecx
end;

{ TAsyncCallLocalProcEx }

constructor TAsyncCallLocalProcEx.Create(AProc: TLocalAsyncProc; AParam: INT_PTR; ABasePointer: Pointer);
begin
  inherited Create;
  @FProc := @AProc;
  FBasePointer := ABasePointer;
  FParam := AParam;
end;

function TAsyncCallLocalProcEx.ExecuteAsyncCall: Integer;
asm
  mov edx, [eax].TAsyncCallLocalProcEx.FBasePointer
  mov ecx, [eax].TAsyncCallLocalProcEx.FProc
  mov eax, [eax].TAsyncCallLocalProcEx.FParam
  push edx
  call ecx
  pop ecx
end;

{ ---------------------------------------------------------------------------- }

{ TAsyncVclCallLocalProc }

constructor TAsyncVclCallLocalProc.Create(AProc: TLocalVclProc; AParam: INT_PTR; ABasePointer: Pointer);
begin
  inherited Create;
  @FProc := @AProc;
  FBasePointer := ABasePointer;
  FParam := AParam;
end;

function TAsyncVclCallLocalProc.ExecuteAsyncCall: Integer;
asm
  mov edx, [eax].TAsyncCallLocalProcEx.FBasePointer
  mov ecx, [eax].TAsyncCallLocalProcEx.FProc
  mov eax, [eax].TAsyncCallLocalProcEx.FParam
  push edx
  call ecx
  pop ecx
end;

{ ---------------------------------------------------------------------------- }

type
  PLocalVclCallRec = ^TLocalVclCallRec;
  TLocalVclCallRec = record
    BasePointer: Pointer;
    Proc: TLocalVclProc;
    Param: INT_PTR;
  end;

function LocalVclCallProc(Data: PLocalVclCallRec): Integer;
asm
  mov edx, [eax].TLocalVclCallRec.BasePointer
  mov ecx, [eax].TLocalVclCallRec.Proc
  mov eax, [eax].TLocalVclCallRec.Param
  push edx
  call ecx
  pop ecx
end;

procedure InternLocalVclCall(LocalProc: TLocalVclProc; Param: INT_PTR; BasePointer: Pointer);
var
  M: TMethod;
  Data: TLocalVclCallRec;
begin
  ThreadPool.CheckDestroying;
  Data.BasePointer := BasePointer;
  Data.Proc := LocalProc;
  Data.Param := Param;
  if GetCurrentThreadId = MainThreadID then
    LocalVclCallProc(@Data)
  else
  begin
    M.Code := @LocalVclCallProc;
    M.Data := @Data;
    StaticSynchronize(TThreadMethod(M));
  end;
end;

procedure LocalVclCall(LocalProc: TLocalVclProc; Param: INT_PTR);
asm
  mov ecx, ebp
  jmp InternLocalVclCall
end;

function InternLocalAsyncVclCall(LocalProc: TLocalVclProc; Param: INT_PTR; BasePointer: Pointer): IAsyncCall;
var
  Data: TLocalVclCallRec;
  Call: TAsyncVclCallLocalProc;
begin
  if GetCurrentThreadId = MainThreadID then
  begin
    Data.BasePointer := BasePointer;
    Data.Proc := LocalProc;
    Data.Param := Param;
    Result := TSyncCall.Create( LocalVclCallProc(@Data) );
  end
  else
  begin
    ThreadPool.CheckDestroying;
    Call := TAsyncVclCallLocalProc.Create(LocalProc, Param, BasePointer);
    ThreadPool.SendVclSync(Call);
    Result := TAsyncCall.Create(Call);
  end;
end;

function LocalAsyncVclCall(LocalProc: TLocalVclProc; Param: INT_PTR = 0): IAsyncCall;
asm
  push ecx // interface return address
  mov ecx, ebp
  call InternLocalAsyncVclCall
end;

{----------------------------------------------------------------------------}

type
  TMainThreadContext = record
    MainThreadEntered: Longint;
    MainThreadOpenBlockCount: Longint;

    IntructionPointer: Pointer;
    BasePointer: Pointer;
    RetAddr: Pointer;

    MainBasePointer: Pointer;
    MainStackPointerStart: Pointer;
    ContextRetAddr: Pointer;

    MainRegEBX, MainRegEDI, MainRegESI: Pointer;
    ThreadRegEBX, ThreadRegEDI, ThreadRegESI: Pointer;

    StackBufferCount: Longint;
    StackBuffer: array of Pointer;
  end;

var
  MainThreadContext: TMainThreadContext;
  MainThreadContextCritSect: TRTLCriticalSection;

procedure ExecuteInMainThread(Data: TObject);
asm
  push ebp

  mov eax, OFFSET MainThreadContext

  { Backup main thread state }
  mov edx, OFFSET @@Leave
  mov [eax].TMainThreadContext.ContextRetAddr, edx
  mov [eax].TMainThreadContext.MainBasePointer, ebp
  mov [eax].TMainThreadContext.MainStackPointerStart, esp

  { Backup main thread registers }
  mov [eax].TMainThreadContext.MainRegEBX, ebx
  mov [eax].TMainThreadContext.MainRegEDI, edi
  mov [eax].TMainThreadContext.MainRegESI, esi

  { Set "nested call" control }
  mov ecx, [eax].TMainThreadContext.MainThreadOpenBlockCount
  mov [eax].TMainThreadContext.MainThreadEntered, ecx
  inc ecx
  mov [eax].TMainThreadContext.MainThreadOpenBlockCount, ecx

  { Switch to the thread state }
  mov ebp, [eax].TMainThreadContext.BasePointer
  mov edx, [eax].TMainThreadContext.IntructionPointer

  { Swicth to the thread registers }
  mov ebx, [eax].TMainThreadContext.ThreadRegEBX
  mov edi, [eax].TMainThreadContext.ThreadRegEDI
  mov esi, [eax].TMainThreadContext.ThreadRegESI

  { Jump to the user's synchronized code }
  jmp edx

  { LeaveMainThread() will jump to this address after it has restored the main
    thread state. }
@@Leave:
  pop ebp
end;

procedure LeaveMainThreadError(ErrorMode: Integer);
begin
  case ErrorMode of
    0: raise Exception.CreateRes(@RsLeaveMainThreadNestedError);
    1: raise Exception.CreateRes(@RsLeaveMainThreadThreadError);
  end;
end;

function InitStackBuffer(Count: Integer): Pointer;
begin
  MainThreadContext.StackBufferCount := Count;
  SetLength(MainThreadContext.StackBuffer, Count);
  if Count > 0 then
    Result := @MainThreadContext.StackBuffer[0]
  else
    Result := nil;
end;

function GetMainThreadId: LongWord;
begin
  Result := MainThreadId;
end;

procedure LeaveMainThread;
asm
  { Check if we are in the main thread }
  call GetCurrentThreadId
  mov ecx, eax
  call GetMainThreadId
  cmp eax, ecx
  jne @@ThreadError

  { "nested call" control }
  mov eax, OFFSET MainThreadContext
  mov ecx, [eax].TMainThreadContext.MainThreadOpenBlockCount
  dec ecx
  js @@NestedError
  mov [eax].TMainThreadContext.MainThreadOpenBlockCount, ecx
  cmp ecx, [eax].TMainThreadContext.MainThreadEntered
  jne @@Leave
  { Release "nested call" control }
  mov [eax].TMainThreadContext.MainThreadEntered, -1

  { Save the current registers for the return, the compiler might have
    generated code that changed the registers in the synchronized code. }
  mov [eax].TMainThreadContext.ThreadRegEBX, ebx
  mov [eax].TMainThreadContext.ThreadRegEDI, edi
  mov [eax].TMainThreadContext.ThreadRegESI, esi
  { Restore main thread registers }
  mov ebx, [eax].TMainThreadContext.MainRegEBX
  mov edi, [eax].TMainThreadContext.MainRegEDI
  mov esi, [eax].TMainThreadContext.MainRegESI

  { Detect if the finally block is called by System._HandleFinally.
    In that case an exception was raised in the MainThread-Block. The
    Classes.CheckSynchronize function will handle the exception and the
    thread switch for us. This will also restore the EBP register. }
  mov eax, [esp + $04] // finally return address
  mov edx, OFFSET System.@HandleFinally
  cmp eax, edx
  jl @@NoException
  mov edx, OFFSET System.@HandleAutoException
  cmp eax, edx
  jl @@InException
@@NoException:

  { Backup the return addresses }
  pop edx // procedure return address

  mov eax, OFFSET MainThreadContext
  mov [eax].TMainThreadContext.RetAddr, edx

  { Pop all items from the stack that are between ESP and MainStackPointerStart
    to an internal buffer that is pushed back on the stack in the
    "EnterMainThread" leave-code. }
  mov edx, [eax].TMainThreadContext.MainStackPointerStart
  mov eax, edx
  sub eax, esp
  shr eax, 2 // todo: adjust for 64Bit
  push edx // MainStackPointerStart => Stack
  push eax // Stack item count => Stack

  call InitStackBuffer // returns EAX=Pointer to first item

  pop ecx // Stack item count <= Stack
  pop edx // MainStackPointerStart <= Stack
  // copy stack
  or ecx, ecx
  jz @@IgnoreCopyStackLoop
  mov edx, eax
@@CopyStackLoop:
  pop eax
  mov [edx], eax
  add edx, 4
  dec ecx
  jnz @@CopyStackLoop
@@IgnoreCopyStackLoop:

  { Restore the main thread state }
  mov eax, OFFSET MainThreadContext
  mov ebp, [eax].TMainThreadContext.MainBasePointer
  mov edx, [eax].TMainThreadContext.ContextRetAddr
  //mov esp, [eax].TMainThreadContext.MainStackPointerStart // fixes stack pointer
  jmp edx

@@NestedError:
  xor eax, eax
  call LeaveMainThreadError
@@ThreadError:
  mov eax, 1
  call LeaveMainThreadError

@@InException:
@@Leave:
end;

procedure EnterMainThread;
asm
  { There is nothing to do if we are already in the main thread }
  call GetCurrentThreadId
  mov ecx, eax
  call GetMainThreadId
  cmp eax, ecx
  je @@InMainThread

  mov eax, ThreadPool
  call TThreadPool.CheckDestroying;

  { Enter critical section => implicit waiting queue }
  mov eax, OFFSET MainThreadContextCritSect
  push eax
  call EnterCriticalSection

  { Take the return address from the stack to "clean" the stack }
  pop edx

  { Backup the current thread state }
  mov eax, OFFSET MainThreadContext
  mov [eax].TMainThreadContext.MainThreadEntered, ecx
  mov [eax].TMainThreadContext.IntructionPointer, edx
  mov [eax].TMainThreadContext.BasePointer, ebp
  { Backup the current thread registers }
  mov [eax].TMainThreadContext.ThreadRegEBX, ebx
  mov [eax].TMainThreadContext.ThreadRegEDI, edi
  mov [eax].TMainThreadContext.ThreadRegESI, esi

  { Begin try/finally }
@@Try:
  xor eax, eax
  push ebp
  push OFFSET @@HandleFinally
  push dword ptr fs:[eax]
  mov fs:[eax], esp

  { Call Synchronize(TMethod(ExecuteInMainThread)) }
  xor edx, edx
  push edx
  mov ecx, OFFSET ExecuteInMainThread
  push ecx
  call StaticSynchronize

  { Clean up try/finally }
  xor eax,eax
  pop edx
  pop ecx
  pop ecx
  mov fs:[eax], edx

  { Restore thread state }
  mov eax, OFFSET MainThreadContext
  mov ebp, [eax].TMainThreadContext.BasePointer

  { Push the backuped stack items back to the stack }
  mov ecx, [eax].TMainThreadContext.StackBufferCount
  dec ecx
  js @@IgnoreRestoreStack
  mov eax, [eax].TMainThreadContext.StackBuffer
  mov edx, ecx
  shl edx, 2 // todo: Adjust for 64 bit
  add eax, edx // move to buffer end
@@RestoreStack:
  mov edx, [eax]
  add eax, -4
  push edx
  dec ecx
  jns @@RestoreStack
@@IgnoreRestoreStack:

  { Put return address back to the stack }
  mov eax, OFFSET MainThreadContext
  mov edx, [eax].TMainThreadContext.RetAddr
  push edx

  { End try/finally }
@@Finally:
  { Restore thread registers }
  mov eax, OFFSET MainThreadContext
  mov ebx, [eax].TMainThreadContext.ThreadRegEBX
  mov edi, [eax].TMainThreadContext.ThreadRegEDI
  mov esi, [eax].TMainThreadContext.ThreadRegESI

  { Leave critical section }
  mov eax, OFFSET MainThreadContextCritSect
  push eax
  call LeaveCriticalSection
  ret
@@HandleFinally:
  jmp System.@HandleFinally
  jmp @@Finally
@@LeaveFinally:
  ret

@@InMainThread:
  { Adjust "nested call" control.
    Threadsafe because we are in the main thread and only the main thread
    manipulates MainThreadOpenBlockCount }
  inc [MainThreadContext].TMainThreadContext.MainThreadOpenBlockCount
end;
{$ENDIF SUPPORT_LOCAL_FUNCTIONS}

{----------------------------------------------------------------------------}

{$IFDEF DELPHI2009_UP}
{ TMultiArgProcCall<TProc, T1> }
constructor TMultiArgProcCall<TProc, T1>.Create(AProc: TProc; const AArg1: T1);
begin
  inherited Create;
  FProc := AProc;
  FArg1 := AArg1;
end;

{ TMultiArgProcCall<TProc, T1, T2> }
constructor TMultiArgProcCall<TProc, T1, T2>.Create(AProc: TProc; const AArg1: T1; const AArg2: T2);
begin
  inherited Create(AProc, AArg1);
  FArg2 := AArg2;
end;

{ TMultiArgProcCall<TProc, T1, T2, T3> }
constructor TMultiArgProcCall<TProc, T1, T2, T3>.Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3);
begin
  inherited Create(AProc, AArg1, AArg2);
  FArg3 := AArg3;
end;

{ TMultiArgProcCall<TProc, T1, T2, T3, T4> }
constructor TMultiArgProcCall<TProc, T1, T2, T3, T4>.Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3; const AArg4: T4);
begin
  inherited Create(AProc, AArg1, AArg2, AArg3);
  FArg4 := AArg4;
end;

{ TAsyncVclCallAnonymProc }

constructor TAsyncCalls.TAsyncVclCallAnonymProc.Create(AProc: TProc);
begin
  inherited Create;
  FProc := AProc;
end;

function TAsyncCalls.TAsyncVclCallAnonymProc.ExecuteAsyncCall: Integer;
begin
  FProc();
  Result := 0;
end;

{ TAsyncCalls.TAsyncCallArg<T> }

function TAsyncCalls.TAsyncCallArg<T>.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg1);
end;

{ TAsyncCalls.TAsyncCallArg<T1, T2> }

function TAsyncCalls.TAsyncCallArg<T1, T2>.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg1, FArg2);
end;

{ TAsyncCalls.TAsyncCallArg<T1, T2, T3> }

function TAsyncCalls.TAsyncCallArg<T1, T2, T3>.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg1, FArg2, FArg3);
end;

{ TAsyncCalls.TAsyncCallArg<T1, T2, T3, T4> }

function TAsyncCalls.TAsyncCallArg<T1, T2, T3, T4>.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg1, FArg2, FArg3, FArg4);
end;

{ TAsyncCalls.TAsyncCallArgMethod<T> }

function TAsyncCalls.TAsyncCallArgMethod<T>.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg1);
end;

{ TAsyncCalls.TAsyncCallArgMethod<T1, T2> }

function TAsyncCalls.TAsyncCallArgMethod<T1, T2>.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg1, FArg2);
end;

{ TAsyncCalls.TAsyncCallArgMethod<T1, T2, T3> }

function TAsyncCalls.TAsyncCallArgMethod<T1, T2, T3>.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg1, FArg2, FArg3);
end;

{ TAsyncCalls.TAsyncCallArgMethod<T1, T2, T3, T4> }

function TAsyncCalls.TAsyncCallArgMethod<T1, T2, T3, T4>.ExecuteAsyncCall: Integer;
begin
  Result := FProc(FArg1, FArg2, FArg3, FArg4);
end;

{ TAsyncCalls.TAsyncCallAnonymProc }

constructor TAsyncCalls.TAsyncCallAnonymProc.Create(AProc: TProc);
begin
  inherited Create;
  FProc := AProc;
end;

function TAsyncCalls.TAsyncCallAnonymProc.ExecuteAsyncCall: Integer;
begin
  FProc;
  Result := 0;
end;

{ TAsyncCalls.TAsyncCallAnonymFunc }

constructor TAsyncCalls.TAsyncCallAnonymFunc.Create(AProc: TIntFunc);
begin
  inherited Create;
  FProc := AProc;
end;

function TAsyncCalls.TAsyncCallAnonymFunc.ExecuteAsyncCall: Integer;
begin
  Result := FProc();
end;

{ TAsyncCalls<T> }

class function TAsyncCalls.Invoke<T>(Proc: TAsyncCallArgGenericProc<T>; const Arg: T): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg))
  else
    Result := TAsyncCallArg<T>.Create(Proc, Arg).ExecuteAsync;
end;

class function TAsyncCalls.Invoke<T>(Event: TAsyncCallArgGenericMethod<T>; const Arg: T): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Event(Arg))
  else
    Result := TAsyncCallArgMethod<T>.Create(Event, Arg).ExecuteAsync;
end;

class function TAsyncCalls.Invoke<T1, T2>(Proc: TAsyncCallArgGenericProc<T1, T2>; const Arg1: T1; const Arg2: T2): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg1, Arg2))
  else
    Result := TAsyncCallArg<T1, T2>.Create(Proc, Arg1, Arg2).ExecuteAsync;
end;

class function TAsyncCalls.Invoke<T1, T2>(Event: TAsyncCallArgGenericMethod<T1, T2>; const Arg1: T1; const Arg2: T2): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Event(Arg1, Arg2))
  else
    Result := TAsyncCallArgMethod<T1, T2>.Create(Event, Arg1, Arg2).ExecuteAsync;
end;

class function TAsyncCalls.Invoke<T1, T2, T3>(Proc: TAsyncCallArgGenericProc<T1, T2, T3>; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg1, Arg2, Arg3))
  else
    Result := TAsyncCallArg<T1, T2, T3>.Create(Proc, Arg1, Arg2, Arg3).ExecuteAsync;
end;

class function TAsyncCalls.Invoke<T1, T2, T3>(Event: TAsyncCallArgGenericMethod<T1, T2, T3>; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Event(Arg1, Arg2, Arg3))
  else
    Result := TAsyncCallArgMethod<T1, T2, T3>.Create(Event, Arg1, Arg2, Arg3).ExecuteAsync;
end;

class function TAsyncCalls.Invoke<T1, T2, T3, T4>(Proc: TAsyncCallArgGenericProc<T1, T2, T3, T4>; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Proc(Arg1, Arg2, Arg3, Arg4))
  else
    Result := TAsyncCallArg<T1, T2, T3, T4>.Create(Proc, Arg1, Arg2, Arg3, Arg4).ExecuteAsync;
end;

class function TAsyncCalls.Invoke<T1, T2, T3, T4>(Event: TAsyncCallArgGenericMethod<T1, T2, T3, T4>; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Event(Arg1, Arg2, Arg3, Arg4))
  else
    Result := TAsyncCallArgMethod<T1, T2, T3, T4>.Create(Event, Arg1, Arg2, Arg3, Arg4).ExecuteAsync;
end;

class function TAsyncCalls.Invoke(Func: TIntFunc): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
    Result := TSyncCall.Create(Func())
  else
    Result := TAsyncCallAnonymFunc.Create(Func).ExecuteAsync;
end;

class function TAsyncCalls.Invoke(Proc: TProc): IAsyncCall;
begin
  { Execute the function synchron if no thread pool exists }
  if GetMaxAsyncCallThreads = 0 then
  begin
    Proc();
    Result := TSyncCall.Create(0);
  end
  else
    Result := TAsyncCallAnonymProc.Create(Proc).ExecuteAsync;
end;

class procedure TAsyncCalls.VCLSync(Proc: TProc);

  procedure Exec(var P: TProc);
  begin
    P();
  end;

var
  M: TMethod;
begin
  if GetCurrentThreadId = MainThreadID then
    Proc()
  else
  begin
    ThreadPool.CheckDestroying;
    M.Code := @Exec;
    M.Data := @Proc;
    StaticSynchronize(TThreadMethod(M));
  end;
end;

class function TAsyncCalls.VCLInvoke(Proc: TProc): IAsyncCall;
var
  Call: TAsyncVclCallAnonymProc;
begin
  if GetCurrentThreadId = MainThreadID then
  begin
    Proc();
    Result := TSyncCall.Create(0);
  end
  else
  begin
    ThreadPool.CheckDestroying;
    Call := TAsyncVclCallAnonymProc.Create(Proc);
    ThreadPool.SendVclSync(Call);
    Result := TAsyncCall.Create(Call);
  end;
end;

class procedure TAsyncCalls.MsgExec(AsyncCall: IAsyncCall; IdleMsgMethod: TAsyncIdleMsgMethod);
begin
  if GetCurrentThreadId = MainThreadID then
  begin
    if Assigned(IdleMsgMethod) then
    begin
      AsyncCall.ForceDifferentThread;
      IdleMsgMethod;
      while MsgAsyncMultiSync([AsyncCall], False, INFINITE, QS_ALLINPUT or QS_ALLPOSTMESSAGE) = 1 do
        IdleMsgMethod;
    end;
  end
  else
    AsyncCall.Sync;
end;

{$ENDIF DELPHI2009_UP}

{----------------------------------------------------------------------------}

{ TAsyncCall }

constructor TAsyncCall.Create(ACall: TInternalAsyncCall);
begin
  inherited Create;
  ACall.AddRef;
  FCall := ACall;
end;

destructor TAsyncCall.Destroy;
begin
  if FCall <> nil then
  begin
    try
      FCall.Sync; // throws raised exception
    finally
      FCall.Release;
    end;
  end;
  inherited Destroy;
end;

function TAsyncCall.Finished: Boolean;
begin
  CheckForget;
  Result := FCall.Finished;
end;

procedure TAsyncCall.ForceDifferentThread;
begin
  CheckForget;
  FCall.ForceDifferentThread;
end;

procedure TAsyncCall.Forget;
var
  C: TInternalAsyncCall;
begin
  CheckForget;
  C := FCall;
  FCall := nil;
  C.Forget;
  C.Release;
end;

function TAsyncCall.ReturnValue: Integer;
begin
  CheckForget;
  Result := FCall.ReturnValue;
end;

function TAsyncCall.Sync: Integer;
begin
  CheckForget;
  Result := FCall.Sync;
end;

function TAsyncCall.GetEvent: THandle;
begin
  CheckForget;
  Result := FCall.GetEvent;
end;

function TAsyncCall.SyncInThisThreadIfPossible: Boolean;
begin
  CheckForget;
  Result := FCall.SyncInThisThreadIfPossible;
end;

function TAsyncCall.Canceled: Boolean;
begin
  CheckForget;
  Result := FCall.Canceled;
end;

procedure TAsyncCall.CancelInvocation;
begin
  CheckForget;
  FCall.CancelInvocation;
end;

procedure TAsyncCall.CheckForget;
begin
  if FCall = nil then
    raise EAsyncCallError.CreateRes(@RsForgetWasCalled);
end;

initialization
  ThreadPool := TThreadPool.Create;
  {$IFDEF SUPPORT_LOCAL_FUNCTIONS}
  MainThreadContext.MainThreadEntered := -1;
  InitializeCriticalSection(MainThreadContextCritSect);
  {$ENDIF SUPPORT_LOCAL_FUNCTIONS}
  {$IFNDEF DELPHi7_UP}
  SyncEvent := CreateEvent(nil, False, False, nil);
  {$ENDIF ~DELPHi7_UP}

finalization
  ThreadPool.Free;
  ThreadPool := nil;
  {$IFDEF SUPPORT_LOCAL_FUNCTIONS}
  DeleteCriticalSection(MainThreadContextCritSect);
  {$ENDIF SUPPORT_LOCAL_FUNCTIONS}
  {$IFNDEF DELPHi7_UP}
  CloseHandle(SyncEvent);
  SyncEvent := 0;
  {$ENDIF ~DELPHi7_UP}

end.

