program am_profiler;
{ cross platform version of the am_profiler example by Barry Kelly.
http://blog.barrkel.com/2008/08/anonymous-methods-in-testing-profiling.html
Just added;
- defines
- QueryPerformanceFrequency for linux
- QueryPerformanceCounter for Linux.
2024, Thaddy de Koning }
{$ifdef fpc}
{$if fpc_fullversion < 30301}{$error this code needs fpc 3.3.1 or higher}{$endif}
{$mode delphi}
{$modeswitch functionreferences}
{$modeswitch anonymousfunctions}
{$Endif}
{$ifdef mswindows}{$apptype console}{$endif}
uses
{$ifdef unix}baseunix,linux,{$endif}{$ifdef mswindows}windows,{$endif} SysUtils;
type
TFunc<T> = reference to function:T;
TProc = reference to procedure;
TProc<T1,T2> = reference to procedure(a:T1;b:T2);
TBenchmarker = class
private
const
DefaultIterations = 3;
DefaultWarmups = 1;
var
FReportSink: TProc<string,Double>;
FWarmups: Integer;
FIterations: Integer;
FOverhead: Double;
class var
FFreq: Int64;
class procedure InitFreq;
public
constructor Create(const AReportSink: TProc<string,Double>);
class function Benchmark(const Code: TProc;
Iterations: Integer = DefaultIterations;
Warmups: Integer = DefaultWarmups): Double; overload;
procedure Benchmark(const Name: string; const Code: TProc); overload;
function Benchmark<T>(const Name: string; const Code: TFunc<T>): T; overload;
property Warmups: Integer read FWarmups write FWarmups;
property Iterations: Integer read FIterations write FIterations;
end;
{$ifdef unix}
function QueryPerformanceFrequency(out value:int64):boolean;inline;
begin
Result := true;
Value := 1000000000;
end;
function QueryPerformanceCounter(out value:int64):int64;inline;
var
t:Timespec;
begin
result:=clock_gettime(CLOCK_THREAD_CPUTIME_ID{or clock_monotonic?},@t);
{ assume call succeeds }
value := t.tv_nsec;
if result = -1 then
begin
{ mimic windows error behavior, err=0 }
result :=0;
Value := 0
end;
end;
{$endif}
{ TBenchmarker }
constructor TBenchmarker.Create(const AReportSink: TProc<string, Double>);
begin
InitFreq;
FReportSink := AReportSink;
FWarmups := DefaultWarmups;
if (FFreq = 0) and not QueryPerformanceFrequency(FFreq) then
raise Exception.Create('No high-performance counter available.');
end;
class procedure TBenchmarker.InitFreq;
begin
if (FFreq = 0) and not QueryPerformanceFrequency(FFreq) then
raise Exception.Create('No high-performance counter available.');
end;
procedure TBenchmarker.Benchmark(const Name: string; const Code: TProc);
begin
FReportSink(Name, Benchmark(Code, Iterations, Warmups) - FOverhead);
end;
class function TBenchmarker.Benchmark(const Code: TProc; Iterations,
Warmups: Integer): Double;
var
start, stop: Int64;
i: Integer;
begin
InitFreq;
for i := 1 to Warmups do
Code;
QueryPerformanceCounter(start);
for i := 1 to Iterations do
Code;
QueryPerformanceCounter(stop);
Result := (stop - start) / FFreq / Iterations;
end;
function TBenchmarker.Benchmark<T>(const Name: string; const Code: TFunc<T>): T;
var
start, stop: Int64;
i: Integer;
begin
for i := 1 to FWarmups do
Result := Code;
QueryPerformanceCounter(start);
for i := 1 to FIterations do
Result := Code;
QueryPerformanceCounter(stop);
FReportSink(Name, (stop - start) / FFreq / Iterations - FOverhead);
end;
type
ISomeInterface = interface
procedure IntfCall(const Intf: ISomeInterface; depth: Integer);
end;
TSomeClass = class(TInterfacedObject, ISomeInterface)
public
procedure VirtCall(Inst: TSomeClass; depth: Integer); virtual;
procedure StaticCall(Inst: TSomeClass; depth: Integer);
procedure IntfCall(const Intf: ISomeInterface; depth: Integer);
end;
{ TSomeClass }
procedure TSomeClass.IntfCall(const Intf: ISomeInterface; depth: Integer);
begin
if depth > 0 then
Intf.IntfCall(Intf, depth - 1);
end;
procedure TSomeClass.StaticCall(Inst: TSomeClass; depth: Integer);
begin
if depth > 0 then
StaticCall(Inst, depth - 1);
end;
procedure TSomeClass.VirtCall(Inst: TSomeClass; depth: Integer);
begin
if depth > 0 then
VirtCall(Inst, depth - 1);
end;
procedure UseIt;
const
CallDepth = 10000;
var
b: TBenchmarker;
x: TSomeClass;
intf: ISomeInterface;
begin
b := TBenchmarker.Create(procedure(Name: string; Time: Double)
begin
Writeln(Format('%-20s took %15.6f ms', [Name, time * 1000]));
end);
try
b.Warmups := 100;
b.Iterations := 100;
x := TSomeClass.Create;
intf := x;
b.Benchmark('Static call', procedure
begin
x.StaticCall(x, CallDepth);
end);
b.Benchmark('Virtual call', procedure
begin
x.VirtCall(x, CallDepth);
end);
b.Benchmark('Interface call', procedure
begin
intf.IntfCall(intf, CallDepth);
end);
finally
b.Free;
end;
end;
begin
try
UseIt;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
Recent
