multithreading - 如何使用新线程库中的 Task.Wait For Any？

Question

尝试使用Delphi中的线程库并行计算任务并使用TTask.WaitForAny()获取第一个计算结果时，偶尔会出现异常停止执行。

异常处的调用堆栈:

First chance exception at $752D2F71. Exception class EMonitorLockException with message 'Object lock not owned'. Process Project1.exe (11248)

:752d2f71 KERNELBASE.RaiseException + 0x48
System.TMonitor.CheckOwningThread
System.ErrorAt(25,$408C70)
System.Error(reMonitorNotLocked)
System.TMonitor.CheckOwningThread
System.TMonitor.Exit
System.TMonitor.Exit($2180E40)
System.Threading.TTask.RemoveCompleteEvent(???)
System.Threading.TTask.DoWaitForAny((...),4294967295)
System.Threading.TTask.WaitForAny((...))
Project9.Parallel2
Project9.Project1
:74ff919f KERNEL32.BaseThreadInitThunk + 0xe
:7723b54f ntdll.RtlInitializeExceptionChain + 0x8f
:7723b51a ntdll.RtlInitializeExceptionChain + 0x5a

<小时/>

调用堆栈得出的结论是，异常是由线程库、TMonitor 和/或 TTask.WaitForAny() 中的错误引起的。为了验证这一点，代码被削减到最少:

program Project1;

{$APPTYPE CONSOLE}

uses
  System.SysUtils, System.Threading, System.Classes, System.SyncObjs,
  System.StrUtils;
var
  WorkerCount : integer = 1000;

function MyTaskProc: TProc;
begin
  result := procedure
    begin
      // Do something
    end;
end;

procedure Parallel2;
var
  i : Integer;
  Ticks: Cardinal;
  tasks: array of ITask;
  LTask: ITask;
  workProc: TProc;
begin
  workProc := MyTaskProc();
  Ticks := TThread.GetTickCount;
  SetLength(tasks, WorkerCount); // number of parallel tasks to undertake
  for i := 0 to WorkerCount - 1 do // parallel tasks
    tasks[i] := TTask.Run(workProc);
  TTask.WaitForAny(tasks); // wait for the first one to finish
  for LTask in tasks do
    LTask.Cancel; // kill the remaining tasks
  Ticks := TThread.GetTickCount - Ticks;
  WriteLn('Parallel time ' + Ticks.ToString + ' ms');
end;

begin
  try
    repeat
      Parallel2;
      WriteLn('finished');
    until FALSE;
  except
    on E: Exception do
      writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.

现在，错误会在一段时间后重现，并且 RTL 错误已得到验证。

此提交为 RSP-10197 TTask.WaitForAny gives exception EMonitorLockException "Object lock not owned"到内河码头。

<小时/>

鉴于目前无法使用 Delphi 线程库解决这个问题，问题是:

是否有解决方法可以并行执行过程以获得第一个获取的解决方案？

Answer 1

这是一个使用 TParallel.For 的示例当产生答案时停止执行。它使用 TParallel.LoopState向并行 for 循环的其他成员发出信号。通过使用 .Stop 信号，所有当前和待处理的迭代都应该停止。当前迭代应检查loopState.Stopped。

procedure Parallel3(CS: TCriticalSection);
var
  Ticks: Cardinal;
  i,ix: Integer;  // variables that are only touched once in the Parallel.For loop
begin
  i := 0;
  Ticks := TThread.GetTickCount;
  TParallel.For(1,WorkerCount,
    procedure(index:Integer; loopState: TParallel.TLoopState)
    var
      k,l,m: Integer;
    begin
      // Do something complex
      k := (1000 - index)*1000;
      for l := 0 to Pred(k) do
        m := k div 1000;
      // If criteria to stop fulfilled:
      CS.Enter;
      Try
        if loopState.Stopped then // A solution was already found
          Exit;
        loopState.Stop;  // Signal 
        Inc(i);
        ix := index;
      Finally
        CS.Leave;
      End;
    end
  );
  Ticks := TThread.GetTickCount - Ticks;
  WriteLn('Parallel time ' + Ticks.ToString + ' ticks', ' i :',i,' index:',ix);
end;

临界区保护计算结果，这里为简单起见 i,ix。

<小时/>

免责声明，鉴于 System.Threading 库中存在大量错误，我会推荐使用 OTL 框架的另一种解决方案。至少在图书馆达到稳定的基础之前。