使用 OmniThreadLibrary 并行写入数组比串行写入慢

Question

我正在研究差分进化优化算法的实现，并希望通过并行计算种群成员来加快计算时间。 我正在使用 OmniThread 库，并且已经成功地并行化了我的循环，却发现它的运行速度比串行实现慢。

我把代码精简到了本质来测试并行化，精简版也出现了同样的问题：并行版比串行版慢。

关键是我传递了多个动态数组，应该为每个总体成员写入输出。每个数组都有一个专用于人口成员的维度，因此对于每个人口成员，可以访问一组不同的数组索引。这也意味着在并行实现中没有 2 个线程会写入同一个数组元素。

在我用来测试的代码下方（差分进化中的实际代码有一个DoWork 过程，还有更多const 参数和var 数组）

unit Unit1;

interface

type
  TGoalFunction = reference to function(const X, B: array of extended): extended;
  TArrayExtended1D = array of extended;
  TArrayExtended2D = array of TArrayExtended1D;

  TClassToTest = class abstract
  private
    class procedure DoWork(const AGoalFunction: TGoalFunction; const AInputArray: TArrayExtended2D; var AOutputArray1: TArrayExtended1D; var AOutputArray2: TArrayExtended2D; const AIndex, AIndex2: integer);
  public
    class procedure RunSerial;
    class procedure RunParallel;
  end;

function HyperSphere(const X, B: array of extended): extended;

const
  DIMENSION1 = 5000;
  DIMENSION2 = 5000;
  LOOPS = 10;

implementation

uses
  OtlParallel;

function HyperSphere(const X, B: array of extended): extended;
var
  I: Integer;
begin
  Result := 0;
  for I := 0 to Length(X) - 1 do
    Result := Result + X[I]*X[I];
end;

{ TClassToTest }

class procedure TClassToTest.DoWork(const AGoalFunction: TGoalFunction; const AInputArray: TArrayExtended2D; var AOutputArray1: TArrayExtended1D; var AOutputArray2: TArrayExtended2D; const AIndex, AIndex2: integer);
var
  I: Integer;
begin
  AOutputArray1[AIndex] := AGoalFunction(AInputArray[AIndex], []);
  for I := 0 to Length(AOutputArray2[AIndex]) - 1 do
    AOutputArray2[AIndex, I] := Random*AIndex2;
end;

class procedure TClassToTest.RunParallel;
var
  LGoalFunction: TGoalFunction;
  LInputArray: TArrayExtended2D;
  LOutputArray1: TArrayExtended1D;
  LOutputArray2: TArrayExtended2D;
  I, J, K: Integer;
begin
  SetLength(LInputArray, DIMENSION1, DIMENSION2);
  for I := 0 to DIMENSION1 - 1 do
  begin
    for J := 0 to DIMENSION2 - 1 do
      LInputArray[I, J] := Random;
  end;
  SetLength(LOutputArray1, DIMENSION1);
  SetLength(LOutputArray2, DIMENSION1, DIMENSION2);

  LGoalFunction := HyperSphere;

  for I := 0 to LOOPS - 1 do
  begin
    Parallel.ForEach(0, DIMENSION1 - 1).Execute(
      procedure (const value: integer)
      begin
        DoWork(LGoalFunction, LInputArray, LOutputArray1, LOutputArray2, value, I);
      end
    );

    for J := 0 to DIMENSION1 - 1 do
    begin
      for K := 0 to DIMENSION2 - 1 do
        LInputArray[J, K] := LOutputArray2[J, K];
    end;
  end;
end;

class procedure TClassToTest.RunSerial;
var
  LGoalFunction: TGoalFunction;
  LInputArray: TArrayExtended2D;
  LOutputArray1: TArrayExtended1D;
  LOutputArray2: TArrayExtended2D;
  I, J, K: Integer;
begin
  SetLength(LInputArray, DIMENSION1, DIMENSION2);
  for I := 0 to DIMENSION1 - 1 do
  begin
    for J := 0 to DIMENSION2 - 1 do
      LInputArray[I, J] := Random;
  end;
  SetLength(LOutputArray1, DIMENSION1);
  SetLength(LOutputArray2, DIMENSION1, DIMENSION2);

  LGoalFunction := HyperSphere;

  for I := 0 to LOOPS - 1 do
  begin
    for J := 0 to DIMENSION1 - 1 do
    begin
      DoWork(LGoalFunction, LInputArray, LOutputArray1, LOutputArray2, J, I);
    end;

    for J := 0 to DIMENSION1 - 1 do
    begin
      for K := 0 to DIMENSION2 - 1 do
        LInputArray[J, K] := LOutputArray2[J, K];
    end;
  end;
end;

end.

我原本预计我的 8 核处理器的加速比约为 6 倍，但遇到了轻微的减速。我应该改变什么来提高并行运行DoWork 过程的速度？

请注意，我更愿意将实际工作保留在 DoWork 过程中，因为我必须能够在有或没有并行化（布尔标志）的情况下调用相同的算法，同时保持代码主体易于共享维护

Answer 1

这是由于Random 缺乏线程安全。其中的实现是：

// global var
var
  RandSeed: Longint = 0;    { Base for random number generator }

function Random: Extended;
const
  two2neg32: double = ((1.0/$10000) / $10000);  // 2^-32
var
  Temp: Longint;
  F: Extended;
begin
  Temp := RandSeed * $08088405 + 1;
  RandSeed := Temp;
  F  := Int64(Cardinal(Temp));
  Result := F * two2neg32;
end;

因为RandSeed 是一个全局变量，它通过调用Random 进行修改，所以线程最终会争用对RandSeed 的写入。那些有争议的写入会导致您的性能问题。它们有效地序列化您的并行代码。严重到比真正的串行代码还要慢。

将下面的代码添加到您单元的实现部分的顶部，您会看到不同之处：

threadvar
  RandSeed: Longint;

function Random: Double;
const
  two2neg32: double = ((1.0/$10000) / $10000);  // 2^-32
var
  Temp: Longint;
  F: Double;
begin
  Temp := RandSeed * $08088405 + 1;
  RandSeed := Temp;
  F  := Int64(Cardinal(Temp));
  Result := F * two2neg32;
end;

通过更改以避免共享、争用写入，您会发现并行版本更快，正如预期的那样。你不会得到处理器数量的线性缩放。我的猜测是，这是因为您的内存访问模式在代码的并行版本中是次优的。

我猜你只是使用Random 作为生成一些数据的一种手段。但如果您确实需要 RNG，则需要安排每个任务使用自己的私有 RNG 实例。

您还可以使用Sqr(X) 而不是X*X 来稍微加快代码速度，也可以切换到Double 而不是Extended。

Answer 2

前段时间我遇到了完全相同的问题。事实证明，瓶颈在于 Parallel.ForEach 的 OTL 调用具有范围会创建一个隐藏的枚举器，在任务非常小并且经常调用循环的情况下，这是瓶颈。

一个更高效的解决方案看起来像这样：

Parallel.ForEach(0, MAXCORES)
    .NumTasks(MAXCORES)
    .Execute(
      procedure (const p:Integer)
      var
        chunkSize : Integer;
        myStart, myEnd : Integer;
        i: Integer;
      begin
        chunkSize := DIMENSION div MAXCORES;
        myStart := p * chunkSize;
        myEnd := min( myStart+chunkSize-1, DIMENSION -1);
        for I := myStart to MyEnd do
          DoSomething(i);
      end);

无论DoSomething 调用中的负载如何，此代码都非常线性地扩展

Answer 3

我已尝试在 i7（8 个超线程）上运行此程序（使用 Random 修复并使用 Doubles）并获得并行时间 1650 毫秒和串行时间 5240 毫秒。鉴于代码内容，我不认为这是特别出乎意料的扩大规模。目前的代码将具有接近 100% 成功的管道预测 - 所有分支都预测，函数调用返回缓存，甚至缓存预取运行良好。在典型的现代 PC 上，这意味着代码可能会受到内存带宽的限制，其中扩展将在很大程度上取决于您的内存性能，而不是您拥有的内核数量。

唯一的另一个问题是对 FPU 资源的潜在争用，这将高度依赖于您的内部处理器架构。

我怀疑如果工作负载更复杂，串行和并行之间会出现更大的扩展，因为串行版本将浪费时间来编码触发的管道中断，而并行版本将保持内存有限。我在 Delphi 中完成了相当多的高性能计算工作，并且由于内存带宽限制，在良好的 8 核机器上，进行简单计算的优化算法可以完全受内存限制，在扩展至 2 倍时具有多线程性能.如果您具有超频能力，则可以特别清楚地说明此类问题，因为超频 CPU 的性能收益可以很好地指示内存等待的水平，因为其他一切都与超频成比例地加速。

如果您想了解处理器架构的详细信息以及它们如何影响您的工作，那么http://www.agner.org/optimize/ 是了解有多少要学习的好地方。