multithreading - 使用 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 过程中，因为我必须能够在使用和不使用并行化( bool 标志)的情况下调用相同的算法，同时保留代码共享，方便维护

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 私有(private)实例。

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