Two new tests for MM B&V

• Previous message: Ivo Tops: "New MEMORY USAGE measurement proposal for MM B&V"
• Next in thread: Dennis: "Re: Two new tests for MM B&V"
• Reply: Dennis: "Re: Two new tests for MM B&V"
• Reply: Martin James: "Re: Two new tests for MM B&V"
• Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]

Date: Fri, 25 Feb 2005 07:56:53 +0100
To:  pleriche@hotmail.com

Here are two tests I discussed with Dennis, ready for use in MM B^V.

Test 1 - ManyThreadTest - Many shortlived threads (capped at 1250)

Test 2 - StringThreadTest - 8 Threads doing string manipulations

The two units are included below

Modifications needed for BenchMarkForm.pas
==========================================================
Uses StringThreadTestUnit;

AddBenchMark(TManyThreadsTest);
AddBenchMark(TStringThreadTest);

Kind regards,

Ivo Tops
=============================== Save this one as StringThreadTestUnit
{****************************************************************************************

   StringTestBenchMark & ManyThreadsTestBenchMark v1.0

   By Ivo Tops for FastCode Memory Manager BenchMark & Validation

****************************************************************************************}
unit StringThreadTestUnit;

interface

uses BenchmarkClassUnit;

type

   TStringThreadTest = class(TFastcodeMMBenchmark)
   protected
   public
     procedure RunBenchmark; override;
     class function GetBenchmarkName: string; override;
     class function GetBenchmarkDescription: string; override;
     class function GetWeightingFactor: Double; override;
   end;

   TManyThreadsTest = class(TFastcodeMMBenchmark)
   protected
   public
     procedure RunBenchmark; override;
     class function GetBenchmarkName: string; override;
     class function GetBenchmarkDescription: string; override;
     class function GetWeightingFactor: Double; override;
   end;

// Counters for thread running
procedure IncRunningThreads;
procedure DecRunningThreads;
procedure NotifyThreadError;
procedure NotifyValidationError;

implementation

uses Math, StringThread, windows, sysutils;

var RunningThreads: Integer;
   ThreadError, ValidationError, ThreadMaxReached, ZeroThreadsReached:
Boolean;

procedure InitTest;
begin
   RunningThreads := 0;
   ZeroThreadsReached := False;
   ThreadMaxReached := False;
   ThreadError := False;
end;

procedure ExitTest;
begin
   // If Thread had error raise exception
   if ThreadError then raise Exception.Create('TestThread failed with an
Error');
   // If Thread had validate raise exception
   if ValidationError then raise Exception.Create('TestThread failed
Validation');
end;

{ TStringThreadTest }

class function TStringThreadTest.GetBenchmarkDescription: string;
begin
   Result := 'A benchmark that does stringmanipulations concurrently in
8 different threads';
end;

class function TStringThreadTest.GetBenchmarkName: string;
begin
   Result := 'StringThreadTest';
end;

class function TStringTHreadTest.GetWeightingFactor: Double;
begin
   {Arbitrary scale factor to bring scores for this benchmark in line
    with the others}
   Result := 4600 * Power(2, 40);
end;

procedure TStringThreadTest.RunBenchmark;
var I, J: Integer;
begin
   inherited;
   InitTest;
   for J := 1 to 4 do
   begin
     for I := 1 to 8 do // Create a loose new thread that does stringactions
       TStringThread.Create(50, 2000, 4096, False);
     // Simply wait for all threads to finish
     while not ZeroThreadsReached do sleep(10);
   end;
   {Update the peak address space usage}
   UpdateUsageStatistics;
   // Done
   ExitTest;
end;

procedure IncRunningThreads;
var RT: Integer;
begin
   RT := InterlockedExchangeAdd(@RunningThreads, 1);
   ZeroThreadsReached := False;
   ThreadMaxReached := RT > 1250;
end;

procedure DecRunningThreads;
var RT: Integer;
begin
   RT := InterlockedExchangeAdd(@RunningThreads, -1);
   ThreadMaxReached := RT > 1250;
   ZeroThreadsReached := RT = 1; // Old value is 1, so new value is zero
end;

{ TManyThreadsTest }

class function TManyThreadsTest.GetBenchmarkDescription: string;
begin
   Result := 'A benchmark that has many temporary threads, each doing a
little string processing. ';
   Result := Result + 'This test exposes possible multithreading issues
in a memory manager and large per-thread ';
   Result := Result + 'memory requirements.';
end;

class function TManyThreadsTest.GetBenchmarkName: string;
begin
   Result := 'ManyShortLivedThreads';
end;

class function TManyThreadsTest.GetWeightingFactor: Double;
begin
   {Arbitrary scale factor to bring scores for this benchmark in line
    with the others}
   Result := 4600 * Power(2, 40);
end;

procedure TManyThreadsTest.RunBenchmark;
var
   I: Integer;
begin
   inherited;
   InitTest;
   // Launch a lot of threads
   for I := 1 to 100 do
   begin
     TStringThread.Create(1000, 10, 512, False);
     TStringThread.Create(10, 2, 4096, False);
     TStringThread.Create(10, 2, 1024*1024, False);
   end;
   // Launch a lot of threads keeping threadmax in account
   for I := 1 to 500 do
   begin
     TStringThread.Create(100, 1, 512, False);
     TStringThread.Create(100, 100, 512, False);
     TStringThread.Create(100, 1, 512, False);
     while ThreadMaxReached do sleep(1);
   end;
   // Wait for all threads to finish
   while not ZeroThreadsReached do sleep(50);
   {Update the peak address space usage}
   UpdateUsageStatistics;
   // Done
   ExitTest;
end;

procedure NotifyThreadError;
begin
   ThreadError := True;
end;

procedure NotifyValidationError;
begin
   ValidationError := True;
end;

end.

=============================== Save this one as StringThread
{****************************************************************************************

   StringThread usede by StringTestBenchMark & ManyThreadsTestBenchMark

   By Ivo Tops for FastCode Memory Manager BenchMark & Validation

****************************************************************************************}
unit StringThread;

interface

uses
   Classes, windows, sysutils;

const
   cRandomSizes = False;

type
   TStringThread = class(TThread)
   private
     FStringItems: Integer;
     FValidate: Boolean;
     FIterations: Integer;
     FSize:Integer;
   protected
     procedure StringAction;
   public
     constructor Create(AIterations: Integer; AItems: Integer;
AItemSize:Integer;AValidate: Boolean); reintroduce;
     procedure Execute; override;
   end;

type TLargeByteArray = array[0..MaxInt - 1] of Byte;

procedure FillPattern(const Dest: Pointer; const Size: Integer; const
StartChar: Byte);
function CheckPattern(const Dest: Pointer; const Size: Integer; const
StartChar: Byte): Boolean;

implementation

uses StringThreadTestUnit;

constructor TStringThread.Create(AIterations: Integer; AItems: Integer;
AItemSize:Integer;AValidate: Boolean);
begin
   inherited Create(False);
   FreeOnTerminate := True;
   IncRunningThreads;
   FStringItems := AItems;
   FValidate := AValidate;
   FIterations := AIterations;
   FSize:=AItemSize;
end;

procedure TStringThread.Execute;
var I: Integer;
begin
   try
     for I := 0 to FIterations - 1 do StringAction;
   except
    // Notify TestUnit we had a failure
    NotifyThreadError;
   end;
   DecRunningThreads;
end;

procedure TStringThread.StringAction;
var I: Integer;
   B1, B2: Integer;
   FCB: Byte;
   FillLen: Integer;
   A, B: array of string;
begin
   SetLength(A, FStringItems);
   SetLength(B, FStringItems);
   if cRandomSizes then
   begin
     B1 := Random(FSize) + 1;
     B2 := Random(FSize) + 1;
   end else
   begin
     B1 := FSize;
     B2 := FSize div 2;
   end;
   for I := 0 to FStringItems - 1 do
   begin
     SetLength(A[I], B1);
     if FValidate then
     begin
       FCB := Byte((I mod 250) + 1);
       FillPattern(PChar(A[I]), B1, FCB);
     end;
   end;
   // Reference counter, no copy
   for I := FStringItems - 1 downto 0 do
     B[I] := A[I];
   // Copy resizing
   for I := 0 to FStringItems - 1 do
     SetLength(B[I], B2);
   // Validate and CleanUp
   for I := FStringItems - 1 downto 0 do
   begin
     if FValidate then
     begin
       FCB := Byte((I mod 250) + 1);
       FillLen := length(A[I]);
       if not CheckPattern(PChar(A[I]), FillLen, FCB) then
       begin
        NotifyValidationError;
        Exit;
       end;
       if length(B[I]) < FillLen then FillLen := Length(B[I]);
       if not CheckPattern(PChar(B[I]), FillLen, FCB) then
             begin
        NotifyValidationError;
        Exit;
       end;
     end;
     B[I] := EmptyStr; // Cleanup
     A[I] := EmptyStr;
   end;
end;

// Fill Memory with a Pattern
procedure FillPattern(const Dest: Pointer; const Size: Integer; const
StartChar: Byte);
var I: Integer;
   PC: Byte;
begin
     // Write a three byte pattern starting with the byte passed
   PC := 0;
   for I := 0 to Size - 1 do
   begin
     TLargeByteArray(Dest^)[I] := StartChar + PC;
     Inc(PC);
     if PC = 3 then PC := 0;
   end;
end;

// Check memory for correct Pattern
function CheckPattern(const Dest: Pointer; const Size: Integer; const
StartChar: Byte): Boolean;
var I: Integer;
   PC: Byte;
begin
     // Check a three byte pattern starting with the byte passed
   Result := True;
   PC := 0;
   for I := 0 to Size - 1 do
   begin
     if TLargeByteArray(Dest^)[I] <> StartChar + PC then
     begin
       Result := False;
       Break;
     end;
     Inc(PC);
     if PC = 3 then PC := 0;
   end;
end;

end.

• Previous message: Ivo Tops: "New MEMORY USAGE measurement proposal for MM B&V"
• Next in thread: Dennis: "Re: Two new tests for MM B&V"
• Reply: Dennis: "Re: Two new tests for MM B&V"
• Reply: Martin James: "Re: Two new tests for MM B&V"
• Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]