tester.pas

delphi开发语言下的源代码分析

unit Tester;

interface
uses
  Windows;

procedure DoAllTest;

implementation

threadvar
  A: array[1..3000] of Pointer;

procedure _RandomAlloc;
var
  I, J, K : Integer;
begin
  FillChar(A,SizeOf(A),0);
  // 1000 times allocate 1000 random blocks of (4097 .. 10000) bytes
  for I := 1 to 1000 do
    for J := 1 to 1000 do
    begin
      K := Random(1000)+1;
      FreeMem(A[K]);
      GetMem(A[K],Random(5903)+4097);
    end;

  // free all
  for J := 1 to 1000 do
    FreeMem(A[J]);
end;

function AllocSpeedTest : LongWord;
begin
  Result := GetTickCount;
  _RandomAlloc;
  Result := GetTickCount - Result;
end;

function SequentialAllocTest : LongWord;
var
  I : Integer;
begin
  Result := GetTickCount;
  for I := 1 to 10 do
    _RandomAlloc;
  Result := GetTickCount - Result;
end;

var
  Threads : Integer = 0;

function ThreadProc(Parameter: Pointer): Integer;
begin
  Result := 0;
  _RandomAlloc;
  dec(Threads);
  EndThread(0);
end;

function ThreadAllocTest : LongWord;
var
  I : Integer;
  FThreadID : Cardinal;
begin
  Result := GetTickCount;
  for I := 1 to 10 do
  begin
    inc(Threads);
    BeginThread(nil, 0, @ThreadProc, nil, 0, FThreadID);
  end;

  // waitting for end of all thread...
  while Threads <> 0 do
    Sleep(100);
  Result := GetTickCount - Result;
end;

procedure DoAllTest;
begin
  Writeln('1000 times allocate 1000 random blocks of (4097 .. 10000) bytes');
  Writeln('Time: ', AllocSpeedTest, ' ms, ok.');
  Writeln;

  Writeln('10 times Sequential Allocate. IsMultiThread: ', IsMultiThread);
  Writeln('Time: ', SequentialAllocTest, ' ms, ok.');
  Writeln;

  Writeln('10 Threads Allocate');
  Writeln('Time: ', ThreadAllocTest, ' ms, ok.');
  Writeln;

  Writeln(' - AllocMemCount:', AllocMemCount, '  AllocMemSize:', AllocMemSize);
  with GetHeapStatus do
    Writeln(' - TotalAllocated:', TotalAllocated, '  TotalCommitted:', TotalCommitted,'  TotalFree:', TotalFree);
end;

end.