ParallelFor - ぱいそにすたん!

出来ましたよと. ブロック内の計算量が少ない場合、ループの中で関数コールするオーバーヘッドが大きくなるので、2引数の無名関数にも対応.

unit ParallelUtils;

interface
uses Windows, SysUtils, Forms;

procedure ParallelFor(Start, Stop: Integer; Block: TProc<Integer, Integer>); overload;
procedure ParallelFor(Start, Stop: Integer; Block: TProc<Integer>); overload;

implementation

type
  TThreadInfo = record
    Start: Integer;
    Stop: Integer;
    Proc: TProc<Integer, Integer>;
    ThreadId: LongWord;
    ThreadHandle: Integer;
  end;
  PThreadInfo = ^TThreadInfo;

function GetNumberOfProcessors: Integer;
var
  SystemInfo: TSystemInfo;
begin
  GetSystemInfo(SystemInfo);
  Result := SystemInfo.dwNumberOfProcessors;
end;

function PallarelForThreadFunc(Parameter: Pointer): Integer;
begin
  Result := 0;
  with PThreadInfo(Parameter)^ do
    Proc(Start, Stop);
  EndThread(0);
end;

procedure ParallelFor(Start, Stop: Integer; Block: TProc<Integer, Integer>); overload;
var
  I: Integer;
  ThreadCount: Integer;
  Infos: array of TThreadInfo;
begin
  ThreadCount := GetNumberOfProcessors;
  SetLength(Infos, ThreadCount);
  for I := 0 to ThreadCount - 1 do
  begin
    Infos[I].Start := Start + (Stop - Start + 1) * I div ThreadCount;
    Infos[I].Stop := Start + (Stop - Start + 1) * (I + 1) div ThreadCount - 1;
    Infos[I].Proc := Block;
    Infos[I].ThreadHandle := BeginThread(nil, 0, PallarelForThreadFunc, @Infos[I], 0, Infos[I].ThreadId);
  end;
  for I := 0 to ThreadCount - 1 do
  begin
    while WaitForSingleObject(Infos[I].ThreadHandle, 0) = WAIT_TIMEOUT do
    begin
      Application.ProcessMessages;
      Sleep(1);
    end;
    CloseHandle(Infos[I].ThreadHandle);
  end;
end;

procedure ParallelFor(Start, Stop: Integer; Block: TProc<Integer>); overload;
begin
  ParallelFor(Start, Stop,
    procedure (Start, Stop: Integer)
    var
      I: Integer;
    begin
      for I := Start to Stop do Block(I);
    end);
end;

end.

ではテスト.

unit Unit1;

interface

uses
  SysUtils, Classes, Controls, Forms, StdCtrls, ParallelUtils;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  FreeVariable: Integer;
begin
  FreeVariable := 10;
  ParallelFor(0, 9,
    procedure (I: Integer)
    begin
      MonitorEnter(Memo1);
      try
        Memo1.Lines.Add(IntToStr(I + FreeVariable));
      finally
        MonitorExit(Memo1);
      end;
    end);
  ParallelFor(10, 19,
    procedure (Start, Stop: Integer)
    var
      I: Integer;
    begin
      MonitorEnter(Memo1);
      try
        for I := Start to Stop do
          Memo1.Lines.Add(IntToStr(I + FreeVariable));
      finally
        MonitorExit(Memo1);
      end;
    end);
end;

end.

結果は以下の通りに.