Question

由于System.Generics.Collections.TArray.Copy<T>的未修复错误（取决于already reported bug in System.CopyArray），有时会使用线程库引发异常。

方法System.Threading.TSparseArray<T>.Add中引发了异常：

function TSparseArray<T>.Add(const Item: T): Integer;
var
  I: Integer;
  LArray, NewArray: TArray<T>;
begin
  ...
          TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
  ...
end;

System.CopyArray中的错误预计会出现这种情况。因此，在尝试解决此问题时，我的第一个想法就是简单地复制数组：

// TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
for LIdx := Low( LArray ) to High( LArray ) do
  NewArray[LIdx] := LArray[LIdx];

像魅力一样工作。但之后我想知道为什么需要阵列副本：

LArray := FArray; // copy array reference from field
...
SetLength(NewArray, Length(LArray) * 2);
TArray.Copy<T>(LArray, NewArray, I + 1);
NewArray[I + 1] := Item;
Exit(I + 1);

元素被复制到NewArray（局部变量），就是这样。没有作业返回FArray，所以对我来说，NewArray将在超出范围时完成。

现在我有三个错误修正选择：

只需替换TArray.Copy

即可

SetLength(NewArray, Length(LArray) * 2);
// TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
for LIdx := Low( LArray ) to High( LArray ) do
  NewArray[LIdx] := LArray[LIdx];
NewArray[I + 1] := Item;
Exit(I + 1);

替换TArray.Copy并保存NewArray

SetLength(NewArray, Length(LArray) * 2);
// TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
for LIdx := Low( LArray ) to High( LArray ) do
  NewArray[LIdx] := LArray[LIdx];
NewArray[I + 1] := Item;
FArray := NewArray;
Exit(I + 1);

注释掉所有不必要的代码部分（因为它们只是在浪费时间）

// SetLength(NewArray, Length(LArray) * 2);
// TArray.Copy<T>(LArray, NewArray, I + 1); // <- Exception here
// NewArray[I + 1] := Item;
Exit(I + 1);

我检查了所有三个修复程序，其中包含一堆查找未使用的工作线程或未执行任务的任务。但我没有找到任何一个。该库按预期工作（现在没有任何例外）。

你能指点我在这里缺少什么吗？

要获得此异常，您已经运行了一系列任务，并让TTaskPool创建越来越多的TWorkerQueueThreads。通过TaskManager检查线程数，并在TArray.Copy方法的TSparseArray<T>.Add行上使用断点。在这里，当应用程序的线程数超过25个线程时，我得到了这个异常。

// Hit the button very fast until the debugger stops 
// at TSparseArray<T>.Add method to copy the array
procedure TForm1.Button1Click( Sender : TObject );
var
  LIdx : Integer;
begin
  for LIdx := 1 to 20 do
    TTask.Run( 
      procedure 
      begin
        Sleep( 50 );
      end );
end;

Answer 1

这不是System.CopyArray中的错误。按设计，它仅支持托管类型。该错误实际上在TArray.Copy<T>。在调用System.CopyArray而不区分T是否为托管类型时，这是错误的。

但是，来自XE7更新1的最新版TArray.Copy<T>似乎没有您所描述的问题。代码如下所示：

class procedure TArray.Copy<T>(const Source, Destination: array of T; 
  SourceIndex, DestIndex, Count: NativeInt);
begin
  CheckArrays(Pointer(@Source[0]), Pointer(@Destination[0]), SourceIndex, 
    Length(Source), DestIndex, Length(Destination), Count);
  if IsManagedType(T) then
    System.CopyArray(Pointer(@Destination[SourceIndex]), 
      Pointer(@Source[SourceIndex]), TypeInfo(T), Count)
  else
    System.Move(Pointer(@Destination[SourceIndex])^, Pointer(@Source[SourceIndex])^, 
      Count * SizeOf(T));
end;

除非我在分析中出错，否则您只需应用更新1来解决System.CopyArray的问题。

但正如Uwe在下面的评论中指出的那样，这段代码仍然是假的。它错误地使用SourceIndex，应该使用DestIndex。并且源和目标参数以错误的顺序传递。人们也想知道为什么作者写了Pointer(@Destination[SourceIndex])^而不是Destination[SourceIndex]。我发现整个情况非常令人沮丧。 Embarcadero如何发布这种令人震惊的质量代码？

比TSparseArray<T>更严重的问题。看起来像这样：

function TSparseArray<T>.Add(const Item: T): Integer;
var
  I: Integer;
  LArray, NewArray: TArray<T>;
begin
  while True do
  begin
    LArray := FArray;
    TMonitor.Enter(FLock);
    try
      for I := 0 to Length(LArray) - 1 do
      begin
        if LArray[I] = nil then
        begin
          FArray[I] := Item;
          Exit(I);
        end else if I = Length(LArray) - 1 then
        begin
          if LArray <> FArray then
            Continue;
          SetLength(NewArray, Length(LArray) * 2);
          TArray.Copy<T>(LArray, NewArray, I + 1);
          NewArray[I + 1] := Item;
          Exit(I + 1);
        end;
      end;
    finally
      TMonitor.Exit(FLock);
    end;
  end;
end;

初始化FArray的唯一时间是TSparseArray<T>构造函数。这意味着如果数组变满，则会添加和丢失项目。据推测，I = Length(LArray) - 1旨在延长FArray的长度并捕获新项目。但是，请注意TSparseArray<T>通过FArray属性公开Current。并且这种曝光不受锁的保护。所以，一旦FArray变满，我无法看到这个类如何以任何有用的方式运行。

我建议您构建一个示例，其中FArray变满，以证明添加的项目已丢失。提交一份错误报告，说明并链接到这个问题。

Answer 2

将项目写入TSparseArray<T>并不重要，因为只有在工作线程完成委托给他的所有任务并且另一个工作线程尚未完成时才需要它。此时，空闲线程正在查看池内其他踏板的队列，并试图窃取一些工作。

如果任何队列没有进入此阵列，则空闲线程不可见，因此无法共享工作负载。

要解决此问题，请选择选项2

function TSparseArray<T>.Add(const Item: T): Integer;
...
SetLength(NewArray, Length(LArray) * 2);
TArray.Copy<T>(LArray, NewArray, I + 1); // <- No Exception here with XE7U1
NewArray[I + 1] := Item;
{$IFDEF USE_BUGFIX}
FArray := NewArray;
{$ENDIF}
Exit(I + 1);

但是窃取部分是没有任何锁定的风险实施

procedure TThreadPool.TQueueWorkerThread.Execute;

...

if Signaled then
begin
  I := 0;
  while I < Length(ThreadPool.FQueues.Current) do
  begin
    if (ThreadPool.FQueues.Current[I] <> nil) 
      and (ThreadPool.FQueues.Current[I] <> WorkQueue)
      and ThreadPool.FQueues.Current[I].TrySteal(Item) 
    then
      Break;
    Inc(I);
  end;
  if I <> Length(ThreadPool.FQueues.Current) then
    Break;
  LookedForSteals := True;
end

数组长度只会增长

while I < Length(ThreadPool.FQueues.Current) do

和

if I <> Length(ThreadPool.FQueues.Current) then

应该足够安全。

if Signaled then
begin
  I := 0;
  while I < Length(ThreadPool.FQueues.Current) do
  begin
    {$IFDEF USE_BUGFIX}
    TMonitor.Enter(ThreadPool.FQueues);
    try
    {$ENDIF}
      if (ThreadPool.FQueues.Current[I] <> nil) and (ThreadPool.FQueues.Current[I] <> WorkQueue) and ThreadPool.FQueues.Current[I].TrySteal(Item) then
        Break;
    {$IFDEF USE_BUGFIX}
    finally
      TMonitor.Exit(ThreadPool.FQueues);
    end;
    {$ENDIF}
    Inc(I);
  end;
  if I <> Length(ThreadPool.FQueues.Current) then
    Break;
  LookedForSteals := True;
end

现在我们需要一个测试环境来观察窃取：

program WatchStealingTasks;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  Winapi.Windows,
  System.SysUtils,
  System.Threading,
  System.Classes,
  System.Math;

procedure OutputDebugStr( const AStr: string ); overload;
begin
  OutputDebugString( PChar( AStr ) );
end;

procedure OutputDebugStr( const AFormat: string; const AParams: array of const ); overload;
begin
  OutputDebugStr( Format( AFormat, AParams ) );
end;

function CreateInnerTask( AThreadId: Cardinal; AValue: Integer; APool: TThreadPool ): ITask;
begin
  Result := TTask.Run(
      procedure
    begin
      Sleep( AValue );
      if AThreadId <> TThread.CurrentThread.ThreadID
      then
        OutputDebugStr( '[%d] executed stolen task from [%d]', [TThread.CurrentThread.ThreadID, AThreadId] )
      else
        OutputDebugStr( '[%d] executed task', [TThread.CurrentThread.ThreadID] );
    end, APool );
end;

function CreateTask( AValue: Integer; APool: TThreadPool ): ITask;
begin
  Result := TTask.Run(
    procedure
    var
      LIdx: Integer;
      LTasks: TArray<ITask>;
    begin
      // Create three inner tasks per task
      SetLength( LTasks, 3 );
      for LIdx := Low( LTasks ) to High( LTasks ) do
        begin
          LTasks[LIdx] := CreateInnerTask( TThread.CurrentThread.ThreadID, AValue, APool );
        end;
      OutputDebugStr( '[%d] waiting for tasks completion', [TThread.CurrentThread.ThreadID] );
      TTask.WaitForAll( LTasks );
      OutputDebugStr( '[%d] task finished', [TThread.CurrentThread.ThreadID] );
    end, APool );
end;

procedure Test;
var
  LPool: TThreadPool;
  LIdx: Integer;
  LTasks: TArray<ITask>;
begin
  OutputDebugStr( 'Test started' );
  try
    LPool := TThreadPool.Create;
    try
      // Create three tasks
      SetLength( LTasks, 3 );
      for LIdx := Low( LTasks ) to High( LTasks ) do
        begin
          // Let's put some heavy work (200ms) on the first tasks shoulder
          // and the other tasks just some light work (20ms) to do
          LTasks[LIdx] := CreateTask( IfThen( LIdx = 0, 200, 20 ), LPool );
        end;
      TTask.WaitForAll( LTasks );
    finally
      LPool.Free;
    end;
  finally
    OutputDebugStr( 'Test completed' );
  end;
end;

begin
  try
    Test;
  except
    on E: Exception do
      Writeln( E.ClassName, ': ', E.Message );
  end;
  ReadLn;

end.

调试日志是

Debug-Ausgabe: Test started Prozess WatchStealingTasks.exe (4532)
Thread-Start: Thread-ID: 2104. Prozess WatchStealingTasks.exe (4532)
Thread-Start: Thread-ID: 2188. Prozess WatchStealingTasks.exe (4532)
Thread-Start: Thread-ID: 4948. Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] waiting for tasks completion Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2104] waiting for tasks completion Prozess WatchStealingTasks.exe (4532)
Thread-Start: Thread-ID: 2212. Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] waiting for tasks completion Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] task finished Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] task finished Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2104] executed task Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2188] executed stolen task from [2104] Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [4948] executed stolen task from [2104] Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: [2104] task finished Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: Thread Exiting: 2188 Prozess WatchStealingTasks.exe (4532)
Debug-Ausgabe: Thread Exiting: 4948 Prozess WatchStealingTasks.exe (4532)
Thread-Ende: Thread-ID: 4948. Prozess WatchStealingTasks.exe (4532)
Thread-Ende: Thread-ID: 2188. Prozess WatchStealingTasks.exe (4532)
Thread-Ende: Thread-ID: 2212. Prozess WatchStealingTasks.exe (4532)

好的，盗窃现在应该可以使用任意数量的工作线程，所以一切都好吗？

否

这个小测试应用程序不会结束，因为它现在在线程池的析构函数内冻结。最后一个工作线程不会因
而终止
procedure TThreadPool.TQueueWorkerThread.Execute; ... if ThreadPool.FWorkerThreadCount = 1 then begin // it is the last thread after all tasks executed, but // FQueuedRequestCount is still on 7 - WTF if ThreadPool.FQueuedRequestCount = 0 then begin

还有一个要修复的错误...因为在等待Task.WaitForAll的任务时，您正在等待的所有任务都在内部执行，但不会减少FQueuedRequestCount。

修复

function TThreadPool.TryRemoveWorkItem(const WorkerData: IThreadPoolWorkItem): Boolean; begin Result := (QueueThread <> nil) and (QueueThread.WorkQueue <> nil); if Result then Result := QueueThread.WorkQueue.LocalFindAndRemove(WorkerData); {$IFDEF USE_BUGFIX} if Result then DecWorkRequestCount; {$ENDIF} end;

现在它就像它应该立即运行一样。

<强>更新

作为Uwe的评论，我们还需要修复固定的System.Generics.Collections.TArray.Copy<T>

class procedure TArray.Copy<T>(const Source, Destination: array of T; SourceIndex, DestIndex, Count: NativeInt); {$IFDEF USE_BUGFIX} begin CheckArrays(Pointer(@Source[0]), Pointer(@Destination[0]), SourceIndex, Length(Source), DestIndex, Length(Destination), Count); if IsManagedType(T) then System.CopyArray(Pointer(@Destination[DestIndex]), Pointer(@Source[SourceIndex]), TypeInfo(T), Count) else System.Move(Pointer(@Source[SourceIndex])^,Pointer(@Destination[DestIndex])^, Count * SizeOf(T) ); end; {$ELSE} begin CheckArrays(Pointer(@Source[0]), Pointer(@Destination[0]), SourceIndex, Length(Source), DestIndex, Length(Destination), Count); if IsManagedType(T) then System.CopyArray(Pointer(@Destination[SourceIndex]), Pointer(@Source[SourceIndex]), TypeInfo(T), Count) else System.Move(Pointer(@Destination[SourceIndex])^, Pointer(@Source[SourceIndex])^, Count * SizeOf(T)); end; {$ENDIF}

一个简单的测试检查：

procedure TestArrayCopy; var LArr1, LArr2: TArray<Integer>; begin LArr1 := TArray<Integer>.Create( 10, 11, 12, 13 ); LArr2 := TArray<Integer>.Create( 20, 21 ); // copy the last 2 elements from LArr1 to LArr2 TArray.Copy<Integer>( LArr1, LArr2, 2, 0, 2 ); end;

使用XE7，您将获得例外

您将获得XE7 Update1
LArr1 = ( 10, 11, 0, 0 ) LArr2 = ( 20, 21 )

上面的修复将获得
LArr1 = ( 10, 11, 12, 13 ) LArr2 = ( 12, 13 )

如何修复TSparseArray <t>？</t>

2 个答案: