utils/uutlEmbeddedProfiler.pas

unit uutlEmbeddedProfiler;

{$mode objfpc}{$H+}
{$OPTIMIZATION ON}
{$OPTIMIZATION REGVAR}
{$OPTIMIZATION PEEPHOLE}
{$OPTIMIZATION CSE}

interface

uses
  SysUtils;

var
  ProfilerEnabled: boolean;

procedure ProfilerEnterProc(const Addr: Pointer);
procedure ProfilerEnterProc(const Addr: Pointer; const aName: String);
procedure ProfilerLeaveProc;

implementation

{$I uutlEmbeddedProfiler.inc}

{$IFDEF PROFILER_ENABLE}

uses
  Windows, Classes, uutlStreamHelper;

type
  TWriterThread = class(TThread)
  private
    fPF: Int64;
    procedure SaveCurrentWrite;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Execute; override;
  end;

  PEventRecord = ^TEventRecord;
  TEventRecord = packed record
    Name: String;
    Func: PtrUInt;
    Thread: TThreadID;
    When: Int64;
  end;

  TProfileDataFile = class
  private
    fDF: TStream;
  public
    constructor Create(const aFileName: string);
    destructor Destroy; override;
    procedure WriteEnter(Thread: TThreadID; When: Int64; Func: PtrUInt; Name: string);
    procedure WriteLeave(Thread: TThreadID; When: Int64);
  end;

  {$I uutlProfilerBinaryFmt.inc}

const
  MAX_EVENT_COUNT = 1000;
  RETURN_FUNCTION : PtrUInt = PtrUInt(-1);

var
  ProfilerDataFile: TProfileDataFile;
  LineNumberComp: PtrUInt;
  Events: array[0..MAX_EVENT_COUNT-1] of TEventRecord;
  InsertPtr, WritePtr: Integer;
  WriterThread: TWriterThread;
  SLInsert: Cardinal;

procedure InstallWriterThread;
begin
  if not Assigned(WriterThread) then
    WriterThread:= TWriterThread.Create;
end;

procedure UninstallWriterThread;
begin
  if Assigned(WriterThread) then begin
    WriterThread.Terminate;
    WriterThread.WaitFor;
    FreeAndNil(WriterThread);
  end;
end;

procedure NextInsert;
begin
  inc(InsertPtr);
  if InsertPtr >= MAX_EVENT_COUNT then
    InsertPtr:= 0;
  // wait until writer cleared this element
  While Events[InsertPtr].Func <> 0 do
    ThreadSwitch;
end;

procedure CalibrateLineNumberCompensation1(const Addr: PtrUInt);
begin
  LineNumberComp:= Addr;
end;

procedure CalibrateLineNumberCompensation;
label
  mark;
begin
  mark:
    CalibrateLineNumberCompensation1({%H-}PtrUInt(Get_pc_addr));
  //measure out one CALL
  LineNumberComp:= LineNumberComp - {%H-}PtrUInt(@mark);
  //go somewhere into the stack prep before the call
  inc(LineNumberComp);
end;

procedure ProfilerEnterProc(const Addr: Pointer);
begin
  ProfilerEnterProc(Addr, '');
end;

procedure ProfilerEnterProc(const Addr: Pointer; const aName: String);
var
  f: PtrUInt;
  tid: TThreadID;
  er: PEventRecord;
begin
  if not ProfilerEnabled then
    exit;
  tid:= GetCurrentThreadId;
  InstallWriterThread;
  repeat
    System.InterlockedCompareExchange(SLInsert, tid, 0);
  until SLInsert = tid;
  try
    // measure as late (close to measured code) as possible, but still write .Func last, because that's our lockvar
    f:= {%H-}PtrUInt(addr) - LineNumberComp;
    er:= @Events[InsertPtr];
    er^.Thread := tid;
    er^.Name   := aName;
    QueryPerformanceCounter(er^.When);
    er^.Func := f;
    NextInsert;
  finally
    System.InterLockedExchange(SLInsert, 0);
  end;
end;

procedure ProfilerLeaveProc;
var
  t: Int64;
  tid: TThreadID;
  er: PEventRecord;
begin
  if not ProfilerEnabled then
    exit;
  QueryPerformanceCounter(t{%H-});
  tid:= GetCurrentThreadId;
  repeat
    System.InterlockedCompareExchange(SLInsert, tid, 0);
  until SLInsert = tid;
  try
    // measure as early (close to measured code) as possible, but still write .Func last, because that's our lockvar
    er := @Events[InsertPtr];
    er^.Thread := tid;
    er^.When   := t;
    er^.Name   := '';
    er^.Func   := RETURN_FUNCTION;
    NextInsert;
  finally
    System.InterLockedExchange(SLInsert, 0);
  end;
end;

{ TWriterThread }

constructor TWriterThread.Create;
begin
  inherited Create(false);
  QueryPerformanceFrequency(fPF);
end;

destructor TWriterThread.Destroy;
begin
  inherited Destroy;
end;

procedure TWriterThread.Execute;
begin
  while not Terminated do begin
    while Events[WritePtr].Func<>0 do begin
      SaveCurrentWrite;
      inc(WritePtr);
      if WritePtr >= MAX_EVENT_COUNT then
        WritePtr:= 0;
    end;
    Sleep(1);
  end;
  //finish up remaining data, by now, writing is disabled
  while Events[WritePtr].Func<>0 do begin
    SaveCurrentWrite;
    inc(WritePtr);
    if WritePtr >= MAX_EVENT_COUNT then
      WritePtr:= 0;
  end;
end;

procedure TWriterThread.SaveCurrentWrite;
begin
  if Events[WritePtr].Func = 0 then
    exit;
  if Events[WritePtr].Func = RETURN_FUNCTION  then
    ProfilerDataFile.WriteLeave(Events[WritePtr].Thread, (Events[WritePtr].When * 1000 * 1000) div fPF)
  else begin
    ProfilerDataFile.WriteEnter(Events[WritePtr].Thread, (Events[WritePtr].When * 1000 * 1000) div fPF, Events[WritePtr].Func, Events[WritePtr].Name);
  end;
  Events[WritePtr].Func:= 0;
end;

{ TProfileDataFile }

constructor TProfileDataFile.Create(const aFileName: string);
var
  H: TPBHeader;
  hh: THandle;
begin
  inherited Create;
  fDF:= TutlPagedBufferStream.Create(TFileStream.Create(aFileName, fmCreate), 4096*64, true);
  H.VersionMagic:= NtoBE(HEADER_VER_MAGIC);
  H.PtrSize:= Sizeof(PtrUInt);
  H.ProgramName:= ExtractFileName(ParamStr(0));
  hh:= FileOpen(ParamStr(0), fmOpenRead or fmShareDenyNone);
  try
    H.ProgramFileSize:= FileSeek(hh, 0, soFromEnd);
  finally
    FileClose(hh);
  end;
  fDF.Write(H, sizeof(H));
end;

destructor TProfileDataFile.Destroy;
begin
  FreeAndNil(fDF);
  inherited;
end;

procedure TProfileDataFile.WriteEnter(Thread: TThreadID; When: Int64; Func: PtrUInt; Name: string);
var
  H: TPBEventHeader;
  R: TPBEventEnterProc;
begin
  H.ThreadID:= Thread;
  H.Timestamp:= When;
  H.Kind:= PB_KIND_ENTER;
  fDF.Write(H, Sizeof(H));
  R.Func:= Func;
  R.NameLen:= Length(Name);
  fDF.Write(R, Sizeof(R));
  if R.NameLen > 0 then
    fDF.Write(Name[1], R.NameLen);
end;

procedure TProfileDataFile.WriteLeave(Thread: TThreadID; When: Int64);
var
  H: TPBEventHeader;
begin
  H.ThreadID:= Thread;
  H.Timestamp:= When;
  H.Kind:= PB_KIND_EXIT;
  fDF.Write(H, Sizeof(H));
end;


{$ELSE}

procedure ProfilerEnterProc(const Addr: Pointer); inline;
begin end;

procedure ProfilerEnterProc(const Addr: Pointer; const aName: String); inline;
begin end;

procedure ProfilerLeaveProc; inline;
begin end;

{$ENDIF}

initialization
  {$IFDEF PROFILER_ENABLE}
  ProfilerEnabled:= false;
  InsertPtr:= 0;
  WritePtr:= 0;
  WriterThread:= nil;
  CalibrateLineNumberCompensation;
  ProfilerDataFile:= TProfileDataFile.Create(ChangeFileExt(ParamStr(0), '.profbin'));
  ProfilerEnabled:= true;
  {$ENDIF}

finalization
  {$IFDEF PROFILER_ENABLE}
  ProfilerEnabled:= false;
  UninstallWriterThread;
  FreeAndNil(ProfilerDataFile);
  {$ENDIF}
end.