Delphi 2010: No thread vs threads

Question

Hello everyone,

I'm user of delphi 2010, my current machine is intel core i7, running windows 7 x64. I've write the following codes:

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FCount: Integer;
    FTickCount: Cardinal;
    procedure DoTest;
    procedure OnTerminate(Sender: TObject);
  end;

  TMyThread = class(TThread)
  private
    FMethod: TProc;
  protected
    procedure Execute; override;
  public
    constructor Create(const aCreateSuspended: Boolean; const aMethod: TProc);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var i: integer;
    T1, T2: Cardinal;
begin
  T1 := GetTickCount;
  for i := 0 to 9 do
    DoTest;
  T2 := GetTickCount;
  Memo1.Lines.Add(Format('no thread=%4f', [(T2 - T1)/1000]));
end;

procedure TForm1.Button2Click(Sender: TObject);
var T: TMyThread;
    i: integer;
begin
  FCount := 0;
  FTickCount := GetTickCount;

  for i := 0 to 9 do begin
    T := TMyThread.Create(True, DoTest);
    T.OnTerminate := OnTerminate;
    T.Priority := tpTimeCritical;

    if SetThreadAffinityMask(T.Handle, 1 shl (i mod 8)) = 0 then
      raise Exception.Create(IntToStr(GetLastError));

    Inc(FCount);
    T.Start;
  end;
end;

procedure TForm1.DoTest;
var i: integer;
begin
  for i := 1 to 10000000 do
    IntToStr(i);
end;

procedure TForm1.OnTerminate(Sender: TObject);
begin
  Dec(FCount);
  if FCount = 0 then
    Memo1.Lines.Add(Format('thread=%4f', [(GetTickCount - FTickCount)/1000]));
end;

constructor TMyThread.Create(const aCreateSuspended: Boolean; const aMethod:
    TProc);
begin
  inherited Create(aCreateSuspended);
  FMethod := aMethod;
  FreeOnTerminate := True;
end;

procedure TMyThread.Execute;
begin
  FMethod;
end;

Click on Button1 will shows 12.25 seconds, while Button2 will shows 12.14 seconds. My problem is why i cannot get more obvious difference of time taken (less than 10 seconds) although i'm running parallel threads ?

Answer 1

Memory allocation seems to be the main problem here.

If you replace the payload with

procedure TForm6.DoTest;
var i: integer;
  a: double;
begin
  a := 0;
  for i := 1 to 10000000 do
    a := Cos(a);
end;

the code will parallelize nicely indicating that there's no real problem with your framework.

If you, however, replace the payload with memory allocation/deallocation

procedure TForm6.DoTest;
var i: integer;
  p: pointer;
begin
  for i := 1 to 10000000 do begin
    GetMem(p, 10);
    FreeMem(p);
  end;
end;

the parallel version will run much slower than the single-threaded one.

When calling IntToStr, a temporary string is allocated and destroyed and this allocations/deallocations are creating the bottleneck.

BTW1: Unless you really really know what you're doing, I'm strongly advising against running threads at tpTimeCritical priority. Even if you really really know what you're doing you shouldn't be doing that.

BTW2: Unless you really really know what you're doing, you should not mess with affinity masks on thread level. System is smart enough to schedule threads nicely.

Answer 2

If you have memory intensive threads (many memory allocations/deallocations) you better use TopMM instead of FastMM: http://www.topsoftwaresite.nl/

FastMM uses a lock which blocks all other threads, TopMM does not so it scales much better on multi cores/cpus!

Answer 3

I'm not 100% sure, but there's a chance that the OnTerminate event is called from the context of the TThread. If that's the case (I must admit I haven't checked this), you'd be better off using InterlockedDecrement on FCount, and synchronizing the GUI updates. Just a minor point, but in production code these things matter.