unit uutlEmbeddedProfiler;

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

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, lineinfo{%H-}, Classes, fgl, unFastFileStream;

type
  TWriterThread = class(TThread)
  private type
    TCacheEntry = record
      Name, Src: ShortString; Line: integer;
    end;
    TCacheList = specialize TFPGMap<PtrUInt, TCacheEntry>;
  private
    fAddressCache: TCacheList;
    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
  public
    constructor Create(const {%H-}aFileName: string);
    procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); virtual; abstract;
    procedure WriteLeave(Thread: TThreadID; When: Int64); virtual; abstract;
  end;

{$DEFINE __HEAD}
  //{$I uutlProfilerPlainText.inc}
  {$I uutlProfilerPlainTextMMap.inc}
{$UnDef __HEAD}
  //{$I uutlProfilerPlainText.inc}
  {$I uutlProfilerPlainTextMMap.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 TestDebugInfoPresent;
var
  f,s: ShortString;
  l: LongInt;
begin
  f:= '';
  s:= '';
  l:= 0;
  if not GetLineInfo({%H-}PtrUInt(@TestDebugInfoPresent),f,s,l) then begin
    raise Exception.Create('Profiler is enabled, but no suitable debug info could be found.');
    Halt();
  end;
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;

{ TProfileDataFile }

constructor TProfileDataFile.Create(const aFileName: string);
begin
  inherited Create;
end;

{ TWriterThread }

constructor TWriterThread.Create;
begin
  inherited Create(false);
  fAddressCache:= TCacheList.Create;
  fAddressCache.Sorted:= true;
  QueryPerformanceFrequency(fPF);
end;

destructor TWriterThread.Destroy;
begin
  FreeAndNil(fAddressCache);
  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;
var
  ce: TCacheEntry;
  i: integer;
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
    i:= fAddressCache.IndexOf(Events[WritePtr].Func);
    if i < 0 then begin
      ce.Line:= 0;
      ce.Src:= '';
      GetLineInfo(Events[WritePtr].Func,ce.Name,ce.Src,ce.Line);
      if (ce.Name = '') then
        ce.Name := Format('0x%.16x', [Events[WritePtr].Func]);
      fAddressCache.Add(Events[WritePtr].Func, ce);
    end else
      ce:= fAddressCache.Data[i];
    if (Events[WritePtr].Name <> '') then
      ce.Name := '[' + Events[WritePtr].Name + '] ' + ce.Name;
    ProfilerDataFile.WriteEnter(Events[WritePtr].Thread, (Events[WritePtr].When * 1000 * 1000) div fPF, ce.Name, ce.Src, ce.Line);
  end;
  Events[WritePtr].Func:= 0;
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;
  TestDebugInfoPresent;
  //ProfilerDataFile:= TProfilePlainText.Create(ChangeFileExt(ParamStr(0), '.profraw'));
  //ProfilerDataFile:= TProfileBinary.Create(ChangeFileExt(ParamStr(0), '.profbin'));
  ProfilerDataFile:= TProfilePlainTextMMap.Create(ChangeFileExt(ParamStr(0), '.profraw'));
  ProfilerEnabled:= true;
  {$ENDIF}

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