DEADSOFTWARE

083704863848142f8e7f8342f3c57a260d1e9959
[d2df-sdl.git] / src / shared / xprofiler.pas
1 (* Copyright (C) DooM 2D:Forever Developers
2 *
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, either version 3 of the License, or
6 * (at your option) any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 *)
16 // stopwatch timer to measure short periods (like frame rendering phases)
17 {$INCLUDE a_modes.inc}
18 unit xprofiler;
20 interface
22 uses
23 SysUtils,
24 {$IF DEFINED(LINUX)}
25 {$DEFINE STOPWATCH_IS_HERE}
26 unixtype, linux
27 {$ELSEIF DEFINED(WINDOWS)}
28 {$DEFINE STOPWATCH_IS_HERE}
29 Windows
30 {$ELSE}
31 {$IFDEF STOPWATCH_IS_HERE}
32 {$UNDEF STOPWATCH_IS_HERE}
33 {$ENDIF}
34 {$WARNING You suck!}
35 {$ENDIF}
36 ;
38 {$IF DEFINED(STOPWATCH_IS_HERE)}
39 type
40 TStopWatch = record
41 strict private
42 mElapsed: Int64;
43 mRunning: Boolean;
44 mStartPosition: UInt64;
46 strict private
47 procedure updateElapsed ();
49 function getElapsedMicro (): Int64;
50 function getElapsedMilli (): Int64;
52 public
53 class function Create (): TStopWatch; static;
54 class function startNew (): TStopWatch; static;
56 public
57 procedure clear (); inline; // full clear
58 procedure start (reset: Boolean=true); // start or restart timer
59 procedure stop ();
60 // the following is like start/stop, but doesn't reset elapsed time
61 procedure pause ();
62 procedure resume ();
64 property elapsedMicro: Int64 read getElapsedMicro;
65 property elapsedMilli: Int64 read getElapsedMilli;
66 property isRunning: Boolean read mRunning;
67 end;
68 {$ENDIF}
71 const
72 TProfHistorySize = 100;
74 type
75 TProfilerBar = record
76 private
77 const FilterFadeoff = 0.05; // 5%
79 private
80 history: array [0..TProfHistorySize-1] of Integer; // circular buffer
81 hisHead: Integer;
82 curval: Single;
83 mName: AnsiString;
84 mLevel: Integer;
86 private
87 procedure initialize (); inline;
88 function getvalue (): Integer; inline;
89 function getvalat (idx: Integer): Integer; inline;
90 function getcount (): Integer; inline;
92 public
93 procedure update (val: Integer);
95 property value: Integer read getvalue;
96 property name: AnsiString read mName;
97 property level: Integer read mLevel;
98 property count: Integer read getcount;
99 property values[idx: Integer]: Integer read getvalat;
100 end;
102 TProfiler = class(TObject)
103 private
104 {$IF DEFINED(STOPWATCH_IS_HERE)}
105 type
106 PProfSection = ^TProfSection;
107 TProfSection = record
108 name: AnsiString;
109 timer: TStopWatch;
110 level: Integer;
111 prevAct: Integer; // this serves as stack
112 end;
114 var
115 xptimer: TStopWatch;
116 xpsecs: array of TProfSection;
117 xpsused: Integer;
118 xpscur: Integer; // currently running section
119 {$ENDIF}
121 public
122 bars: array of TProfilerBar; // 0: total time
123 name: AnsiString;
125 public
126 constructor Create (aName: AnsiString);
127 destructor Destroy (); override;
129 // call this on frame start
130 procedure mainBegin (reallyActivate: Boolean=true);
131 // call this on frame end
132 procedure mainEnd ();
134 procedure sectionBegin (name: AnsiString);
135 procedure sectionEnd ();
137 // this will reuse the section with the given name (if there is any); use `sectionEnd()` to end it as usual
138 procedure sectionBeginAccum (name: AnsiString);
139 end;
142 implementation
144 {$IF DEFINED(LINUX)}
145 type THPTimeType = TTimeSpec;
146 {$ELSE}
147 type THPTimeType = Int64;
148 {$ENDIF}
150 var
151 mFrequency: Int64 = 0;
152 mHasHPTimer: Boolean = false;
155 // ////////////////////////////////////////////////////////////////////////// //
156 procedure initTimerIntr ();
157 var
158 r: THPTimeType;
159 begin
160 if (mFrequency = 0) then
161 begin
162 {$IF DEFINED(LINUX)}
163 if (clock_getres(CLOCK_MONOTONIC, @r) <> 0) then raise Exception.Create('profiler error: cannot get timer resolution');
164 mHasHPTimer := (r.tv_nsec <> 0);
165 if not mHasHPTimer then raise Exception.Create('profiler error: hires timer is not available');
166 mFrequency := 1; // just a flag
167 if (r.tv_nsec <> 0) then mFrequency := 1000000000000000000 div r.tv_nsec;
168 {$ELSE}
169 mHasHPTimer := QueryPerformanceFrequency(r);
170 if not mHasHPTimer then raise Exception.Create('profiler error: hires timer is not available');
171 mFrequency := r;
172 {$ENDIF}
173 end;
174 end;
177 function curTimeMicro (): UInt64; inline;
178 var
179 r: THPTimeType;
180 begin
181 if (mFrequency = 0) then initTimerIntr();
182 {$IF DEFINED(LINUX)}
183 clock_gettime(CLOCK_MONOTONIC, @r);
184 result := UInt64(r.tv_sec)*1000000+UInt64(r.tv_nsec) div 1000; // microseconds
185 {$ELSE}
186 QueryPerformanceCounter(r);
187 result := UInt64(r)*1000000 div mFrequency;
188 {$ENDIF}
189 end;
192 // ////////////////////////////////////////////////////////////////////////// //
193 class function TStopWatch.Create (): TStopWatch;
194 begin
195 result.clear();
196 end;
199 class function TStopWatch.startNew (): TStopWatch;
200 begin
201 result := TStopWatch.Create();
202 result.start();
203 end;
206 procedure TStopWatch.updateElapsed ();
207 var
208 e: UInt64;
209 begin
210 e := curTimeMicro();
211 if (mStartPosition > e) then mStartPosition := e;
212 Inc(mElapsed, e-mStartPosition);
213 mStartPosition := e;
214 end;
217 function TStopWatch.getElapsedMicro (): Int64;
218 begin
219 if mRunning then updateElapsed();
220 result := mElapsed; // microseconds
221 end;
224 function TStopWatch.getElapsedMilli (): Int64;
225 begin
226 if mRunning then updateElapsed();
227 result := mElapsed div 1000; // milliseconds
228 end;
231 procedure TStopWatch.clear ();
232 begin
233 mElapsed := 0;
234 mRunning := false;
235 mStartPosition := 0;
236 end;
239 procedure TStopWatch.start (reset: Boolean=true);
240 begin
241 if mRunning and not reset then exit; // nothing to do
242 mStartPosition := curTimeMicro();
243 mRunning := true;
244 if (reset) then mElapsed := 0;
245 end;
248 procedure TStopWatch.stop ();
249 begin
250 if not mRunning then exit;
251 mRunning := false;
252 updateElapsed();
253 end;
256 procedure TStopWatch.pause ();
257 begin
258 stop();
259 end;
262 procedure TStopWatch.resume ();
263 begin
264 if mRunning then exit;
265 start(false); // don't reset
266 end;
269 // ////////////////////////////////////////////////////////////////////////// //
270 procedure TProfilerBar.initialize (); begin hisHead := -1; curval := 0; end;
272 procedure TProfilerBar.update (val: Integer);
273 var
274 idx: Integer;
275 begin
276 if (val < 0) then val := 0; //else if (val > 1000000) val := 1000000;
277 if (hisHead = -1) then begin hisHead := 0; curval := 0; for idx := 0 to TProfHistorySize-1 do history[idx] := val; end;
278 history[hisHead] := val;
279 Inc(hisHead);
280 if (hisHead = TProfHistorySize) then hisHead := 0;
281 curval := FilterFadeoff*val+(1.0-FilterFadeoff)*curval;
282 end;
284 function TProfilerBar.getvalue (): Integer;
285 //var idx: Integer;
286 begin
287 result := round(curval);
289 result := 0;
290 for idx := 0 to TProfHistorySize-1 do Inc(result, history[idx]);
291 result := result div TProfHistorySize;
293 end;
295 function TProfilerBar.getcount (): Integer; begin result := TProfHistorySize; end;
297 function TProfilerBar.getvalat (idx: Integer): Integer;
298 begin
299 if (idx < 0) or (idx >= TProfHistorySize) then result := 0 else result := history[(hisHead-idx-1+TProfHistorySize*2) mod TProfHistorySize];
300 end;
303 // ////////////////////////////////////////////////////////////////////////// //
304 constructor TProfiler.Create (aName: AnsiString);
305 begin
306 name := aName;
307 bars := nil;
308 {$IF DEFINED(STOPWATCH_IS_HERE)}
309 xptimer.clear();
310 xpsecs := nil;
311 xpsused := 0;
312 xpscur := -1;
313 {$ENDIF}
314 end;
317 destructor TProfiler.Destroy ();
318 begin
319 bars := nil;
320 {$IF DEFINED(STOPWATCH_IS_HERE)}
321 xpsecs := nil;
322 {$ENDIF}
323 inherited;
324 end;
327 procedure TProfiler.mainBegin (reallyActivate: Boolean=true);
328 begin
329 {$IF DEFINED(STOPWATCH_IS_HERE)}
330 xpsused := 0;
331 xpscur := -1;
332 xptimer.clear();
333 if reallyActivate then xptimer.start();
334 {$ENDIF}
335 end;
337 procedure TProfiler.mainEnd ();
338 {$IF DEFINED(STOPWATCH_IS_HERE)}
339 var
340 idx: Integer;
341 emm: Integer;
343 procedure finishProfiling ();
344 var
345 idx: Integer;
346 begin
347 if (xpsused > 0) then
348 begin
349 for idx := 0 to xpsused-1 do
350 begin
351 xpsecs[idx].timer.stop();
352 xpsecs[idx].prevAct := -1;
353 end;
354 end;
355 xptimer.stop();
356 xpscur := -1;
357 end;
358 {$ENDIF}
359 begin
360 {$IF DEFINED(STOPWATCH_IS_HERE)}
361 if not xptimer.isRunning then exit;
362 finishProfiling();
363 if (xpsused > 0) then
364 begin
365 // first time?
366 if (length(bars) = 0) or (length(bars) <> xpsused+1) then
367 begin
368 //if (length(bars) <> 0) then raise Exception.Create('FUUUUUUUUUUUUUUU');
369 SetLength(bars, xpsused+1);
370 for idx := 1 to xpsused do
371 begin
372 bars[idx].initialize();
373 bars[idx].mName := xpsecs[idx-1].name;
374 bars[idx].mLevel := xpsecs[idx-1].level+1;
375 end;
376 bars[0].initialize();
377 bars[0].mName := name;
378 bars[0].mLevel := 0;
379 end;
380 // update bars
381 emm := 0;
382 for idx := 1 to xpsused do
383 begin
384 bars[idx].update(Integer(xpsecs[idx-1].timer.elapsedMicro));
385 Inc(emm, Integer(xpsecs[idx-1].timer.elapsedMicro));
386 end;
387 //bars[0].update(xptimer.elapsedMicro);
388 bars[0].update(emm);
389 end
390 else
391 begin
392 if (length(bars) <> 1) then
393 begin
394 SetLength(bars, 1);
395 bars[0].initialize();
396 bars[0].mName := name;
397 bars[0].mLevel := 0;
398 end;
399 bars[0].update(xptimer.elapsedMicro);
400 end;
401 {$ENDIF}
402 end;
404 procedure TProfiler.sectionBegin (name: AnsiString);
405 {$IF DEFINED(STOPWATCH_IS_HERE)}
406 var
407 sid: Integer;
408 pss: PProfSection;
409 {$ENDIF}
410 begin
411 {$IF DEFINED(STOPWATCH_IS_HERE)}
412 if not xptimer.isRunning then exit;
413 if (Length(xpsecs) = 0) then SetLength(xpsecs, 512); // why not?
414 if (xpsused >= Length(xpsecs)) then raise Exception.Create('too many profile sections');
415 sid := xpsused;
416 Inc(xpsused);
417 pss := @xpsecs[sid];
418 pss.name := name;
419 pss.timer.clear();
420 pss.prevAct := xpscur;
421 // calculate level
422 if (xpscur = -1) then pss.level := 0 else pss.level := xpsecs[xpscur].level+1;
423 xpscur := sid;
424 pss.timer.start();
425 {$ENDIF}
426 end;
428 procedure TProfiler.sectionBeginAccum (name: AnsiString);
429 {$IF DEFINED(STOPWATCH_IS_HERE)}
430 var
431 idx: Integer;
432 {$ENDIF}
433 begin
434 {$IF DEFINED(STOPWATCH_IS_HERE)}
435 if not xptimer.isRunning then exit;
436 if (xpsused > 0) then
437 begin
438 for idx := 0 to xpsused-1 do
439 begin
440 if (xpsecs[idx].name = name) then
441 begin
442 if (idx = xpscur) then raise Exception.Create('profiler error(0): dobule resume: "'+name+'"');
443 if (xpsecs[idx].prevAct <> -1) then raise Exception.Create('profiler error(1): dobule resume: "'+name+'"');
444 xpsecs[idx].prevAct := xpscur;
445 xpscur := idx;
446 xpsecs[idx].timer.resume();
447 exit;
448 end;
449 end;
450 end;
451 sectionBegin(name);
452 {$ENDIF}
453 end;
455 procedure TProfiler.sectionEnd ();
456 {$IF DEFINED(STOPWATCH_IS_HERE)}
457 var
458 pss: PProfSection;
459 {$ENDIF}
460 begin
461 {$IF DEFINED(STOPWATCH_IS_HERE)}
462 if not xptimer.isRunning then exit;
463 if (xpscur = -1) then exit; // this is bug, but meh...
464 pss := @xpsecs[xpscur];
465 pss.timer.stop();
466 // go back to parent
467 xpscur := pss.prevAct;
468 pss.prevAct := -1;
469 {$ENDIF}
470 end;
473 end.