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