asynccalls.pas

Asyncronous call of delphi functions and procedures.

      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}
  if FunctionName <> '' then
    OutputDebugString(PChar(FunctionName));
  {$ENDIF DEBUG_ASYNCCALLS}
  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;

procedure TAsyncCallThread.Execute;
var
  FAsyncCall: TAsyncCall;
  CoInitialized: Boolean;
begin
  CoInitialized := CoInitialize(nil) = S_OK;
  try
    while not Terminated do
    begin
      FAsyncCall := ThreadPool.GetNextAsyncCall(Self); // calls Suspend if nothing has to be done.
      if FAsyncCall <> nil then
      begin
        try
          FAsyncCall.InternExecuteAsyncCall;
        except
          {$IFDEF DEBUG_ASYNCCALLS}
          on E: Exception do
            OutputDebugString(PChar('[' + E.ClassName + '] ' + E.Message));
          {$ENDIF DEBUG_ASYNCCALLS}
        end;
      end;
    end;
  finally
    if CoInitialized then
      CoUninitialize;
  end;
end;

procedure TAsyncCallThread.ForceTerminate;
begin
  if Suspended then
  begin
    Terminate;
    { Do not call Self.Resume() here because it can lead to memory corruption.

        procedure TThread.Resume;
        var
          SuspendCount: Integer;
        begin
          SuspendCount := ResumeThread(FHandle);
          => Thread could be destroyed by FreeOnTerminate <=
          CheckThreadError(SuspendCount >= 0);
          if SuspendCount = 1 then
            FSuspended := False; => accesses the destroyed thread
        end;
     }
    ResumeThread(Handle);
  end
  else
    Terminate;
end;

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

constructor TThreadPool.Create;
var
  SysInfo: TSystemInfo;
begin
  inherited Create;
  FThreads := TThreadList.Create;
  FAsyncCalls := TThreadList.Create;
  FMainThreadVclHandle := AllocateHWnd(MainThreadWndProc);
  FMainThreadSyncEvent := CreateEvent(nil, False, False, nil);

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

destructor TThreadPool.Destroy;
var
  I: Integer;
  List: TList;
begin
  List := FThreads.LockList;
  for I := List.Count - 1 downto 0 do
    TAsyncCallThread(List[I]).ForceTerminate;
  FThreads.UnlockList;
  FThreads.Free;

  List := FAsyncCalls.LockList;
  for I := List.Count - 1 downto 0 do
    SetEvent(TAsyncCall(List[I]).FEvent);
  FAsyncCalls.UnlockList;
  FAsyncCalls.Free;

  CloseHandle(FMainThreadSyncEvent);
  DeallocateHWnd(FMainThreadVclHandle);

  inherited Destroy;
end;

function TThreadPool.GetNextAsyncCall(Thread: TAsyncCallThread): TAsyncCall;
var
  List: TList;
begin
  List := FAsyncCalls.LockList;
  try
    if List.Count > 0 then
    begin
      { Get the "oldest" async call }
      Result := List[0];
      List.Delete(0);
    end
    else
      Result := nil;
  finally
    FAsyncCalls.UnlockList;
  end;
  { Nothing to do, go sleeping... }
  if Result = nil then
    Thread.Suspend;
end;

function TThreadPool.RemoveAsyncCall(Call: TAsyncCall): Boolean;
var
  List: TList;
  Index: Integer;
begin
  List := FAsyncCalls.LockList;
  try
    Index := List.IndexOf(Call);
    Result := Index >= 0;
    if Result then
      List.Delete(Index);
  finally
    FAsyncCalls.UnlockList;
  end;
end;

procedure TThreadPool.AddAsyncCall(Call: TAsyncCall);
var
  List: TList;
  FreeThreadFound: Boolean;
  I: Integer;
begin
  List := FAsyncCalls.LockList;
  List.Add(Call);
  FAsyncCalls.UnlockList;

  FreeThreadFound := False;
  List := FThreads.LockList;
  try
    for I := 0 to List.Count - 1 do
    begin
      if TAsyncCallThread(List[I]).Suspended then
      begin
        { Wake up the thread so it can execute the waiting async call. }
        TAsyncCallThread(List[I]).Resume;
        FreeThreadFound := True;
        Break;
      end;
    end;
    { All threads are busy, we need to allocate another thread if possible }
    if not FreeThreadFound and (List.Count < MaxThreads) then
      AllocThread;
  finally
    FThreads.UnlockList;
  end;
end;

function TThreadPool.AllocThread: TAsyncCallThread;
begin
  Result := TAsyncCallThread.Create(True);
  Result.FreeOnTerminate := True;
  FThreads.Add(Result);
  Result.Resume;
end;

const
  WM_VCLSYNC = WM_USER + 12;

procedure TThreadPool.SendVclSync(Call: TAsyncCall);
begin
  if not PostMessage(FMainThreadVclHandle, WM_VCLSYNC, 0, LPARAM(Call)) then
    Call.Quit(0)
  else
    SetEvent(FMainThreadSyncEvent);
end;

procedure TThreadPool.MainThreadWndProc(var Msg: TMessage);
begin
  case Msg.Msg of
    WM_VCLSYNC:
      TAsyncCall(Msg.LParam).InternExecuteSyncCall;
  else
    with Msg do
      Result := DefWindowProc(FMainThreadVclHandle, Msg, WParam, LParam);
  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 }

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

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

procedure TSyncCall.ForceDifferentThread;
begin
end;

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

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

{ ---------------------------------------------------------------------------- }
{ TAsyncCall }

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

destructor TAsyncCall.Destroy; 
begin
  if FEvent <> 0 then
  begin
    try
      Sync;
    finally
      CloseHandle(FEvent);
      FEvent := 0;
    end;
  end;
  inherited Destroy;
end;

function TAsyncCall._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then
  begin
    try
      if FEvent <> 0 then
        Sync;
    finally
      Destroy;
    end;
  end;
end;

function TAsyncCall.Finished: Boolean;
begin
  Result := (FEvent = 0) or FFinished or (WaitForSingleObject(FEvent, 0) = WAIT_OBJECT_0);
end;

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

function TAsyncCall.GetEvent: Cardinal;
begin
  Result := FEvent;
end;

procedure TAsyncCall.InternExecuteAsyncCall;
var
  Value: Integer;
begin
  Value := 0;
  try
    Value := ExecuteAsyncCall;
  except
    FFatalErrorAddr := ErrorAddr;
    FFatalException := AcquireExceptionObject;
  end;
  Quit(Value);
end;

procedure TAsyncCall.InternExecuteSyncCall;
begin
  Quit( ExecuteAsyncCall() );
end;

procedure TAsyncCall.Quit(AReturnValue: Integer);
begin
  FRetur