|
- 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.
|