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 {.$DEFINE XPROFILER_SLOW_AVERAGE}
  19 unit xprofiler;
  20
  21 interface
  22
  23 uses
  24   SysUtils,
  25   {$IF DEFINED(LINUX)}
  26     {$DEFINE STOPWATCH_IS_HERE}
  27     unixtype, linux
  28   {$ELSEIF DEFINED(WINDOWS)}
  29     {$DEFINE STOPWATCH_IS_HERE}
  30     Windows
  31   {$ELSE}
  32     {$IFDEF STOPWATCH_IS_HERE}
  33       {$UNDEF STOPWATCH_IS_HERE}
  34     {$ENDIF}
  35     {$WARNING You suck!}
  36   {$ENDIF}
  37   ;
  38
  39 {$IF DEFINED(STOPWATCH_IS_HERE)}
  40 type
  41   TStopWatch = record
  42   strict private
  43     mElapsed: Int64;
  44     mRunning: Boolean;
  45     mStartPosition: UInt64;
  46
  47   strict private
  48     procedure updateElapsed ();
  49
  50     function getElapsedMicro (): Int64;
  51     function getElapsedMilli (): Int64;
  52
  53   public
  54     class function Create (): TStopWatch; static;
  55     class function startNew (): TStopWatch; static;
  56
  57   public
  58     procedure clear (); inline; // full clear
  59     procedure start (reset: Boolean=true); // start or restart timer
  60     procedure stop ();
  61     // the following is like start/stop, but doesn't reset elapsed time
  62     procedure pause ();
  63     procedure resume ();
  64
  65     property elapsedMicro: Int64 read getElapsedMicro;
  66     property elapsedMilli: Int64 read getElapsedMilli;
  67     property isRunning: Boolean read mRunning;
  68   end;
  69 {$ENDIF}
  70
  71
  72 const
  73   TProfHistorySize = 1000;
  74
  75 type
  76   TProfilerBar = record
  77   private
  78     //const FilterFadeoff = 0.05; // 5%
  79
  80   private
  81     history: array of Integer; // circular buffer
  82     hisLast: Integer;
  83     //curval: Single;
  84     curAccum: UInt64;
  85     curAccumCount: Integer;
  86     mName: AnsiString;
  87     mLevel: Integer;
  88
  89   private
  90     procedure initialize (aHistSize: Integer); inline;
  91     function getvalue (): Integer; inline;
  92     function getvalat (idx: Integer): Integer; inline;
  93     function getcount (): Integer; inline;
  94
  95   public
  96     procedure update (val: Integer);
  97
  98     property value: Integer read getvalue;
  99     property name: AnsiString read mName;
 100     property level: Integer read mLevel;
 101     property count: Integer read getcount;
 102     property values[idx: Integer]: Integer read getvalat;
 103   end;
 104
 105   TProfiler = class(TObject)
 106   private
 107     {$IF DEFINED(STOPWATCH_IS_HERE)}
 108     type
 109       PProfSection = ^TProfSection;
 110       TProfSection = record
 111         name: AnsiString;
 112         timer: TStopWatch;
 113         level: Integer;
 114         prevAct: Integer; // this serves as stack
 115       end;
 116
 117     var
 118       xptimer: TStopWatch;
 119       xpsecs: array of TProfSection;
 120       xpsused: Integer;
 121       xpscur: Integer; // currently running section
 122     {$ENDIF}
 123
 124   public
 125     bars: array of TProfilerBar; // 0: total time
 126     name: AnsiString;
 127     histSize: Integer;
 128
 129   public
 130     constructor Create (aName: AnsiString; aHistSize: Integer);
 131     destructor Destroy (); override;
 132
 133     // call this on frame start
 134     procedure mainBegin (reallyActivate: Boolean=true);
 135     // call this on frame end
 136     procedure mainEnd ();
 137
 138     procedure sectionBegin (name: AnsiString);
 139     procedure sectionEnd ();
 140
 141     // this will reuse the section with the given name (if there is any); use `sectionEnd()` to end it as usual
 142     procedure sectionBeginAccum (name: AnsiString);
 143   end;
 144
 145
 146 implementation
 147
 148 {$IF DEFINED(LINUX)}
 149 type THPTimeType = TTimeSpec;
 150 {$ELSE}
 151 type THPTimeType = Int64;
 152 {$ENDIF}
 153
 154 var
 155   mFrequency: Int64 = 0;
 156   mHasHPTimer: Boolean = false;
 157
 158
 159 // ////////////////////////////////////////////////////////////////////////// //
 160 procedure initTimerIntr ();
 161 var
 162   r: THPTimeType;
 163 begin
 164   if (mFrequency = 0) then
 165   begin
 166 {$IF DEFINED(LINUX)}
 167     if (clock_getres(CLOCK_MONOTONIC, @r) <> 0) then raise Exception.Create('profiler error: cannot get timer resolution');
 168     mHasHPTimer := (r.tv_nsec <> 0);
 169     if not mHasHPTimer then raise Exception.Create('profiler error: hires timer is not available');
 170     mFrequency := 1; // just a flag
 171     if (r.tv_nsec <> 0) then mFrequency := 1000000000000000000 div r.tv_nsec;
 172 {$ELSE}
 173     mHasHPTimer := QueryPerformanceFrequency(r);
 174     if not mHasHPTimer then raise Exception.Create('profiler error: hires timer is not available');
 175     mFrequency := r;
 176 {$ENDIF}
 177   end;
 178 end;
 179
 180
 181 function curTimeMicro (): UInt64; inline;
 182 var
 183   r: THPTimeType;
 184 begin
 185   if (mFrequency = 0) then initTimerIntr();
 186   {$IF DEFINED(LINUX)}
 187   clock_gettime(CLOCK_MONOTONIC, @r);
 188   result := UInt64(r.tv_sec)*1000000+UInt64(r.tv_nsec) div 1000; // microseconds
 189   {$ELSE}
 190   QueryPerformanceCounter(r);
 191   result := UInt64(r)*1000000 div mFrequency;
 192   {$ENDIF}
 193 end;
 194
 195
 196 // ////////////////////////////////////////////////////////////////////////// //
 197 class function TStopWatch.Create (): TStopWatch;
 198 begin
 199   result.clear();
 200 end;
 201
 202
 203 class function TStopWatch.startNew (): TStopWatch;
 204 begin
 205   result := TStopWatch.Create();
 206   result.start();
 207 end;
 208
 209
 210 procedure TStopWatch.updateElapsed ();
 211 var
 212   e: UInt64;
 213 begin
 214   e := curTimeMicro();
 215   if (mStartPosition > e) then mStartPosition := e;
 216   Inc(mElapsed, e-mStartPosition);
 217   mStartPosition := e;
 218 end;
 219
 220
 221 function TStopWatch.getElapsedMicro (): Int64;
 222 begin
 223   if mRunning then updateElapsed();
 224   result := mElapsed; // microseconds
 225 end;
 226
 227
 228 function TStopWatch.getElapsedMilli (): Int64;
 229 begin
 230   if mRunning then updateElapsed();
 231   result := mElapsed div 1000; // milliseconds
 232 end;
 233
 234
 235 procedure TStopWatch.clear ();
 236 begin
 237   mElapsed := 0;
 238   mRunning := false;
 239   mStartPosition := 0;
 240 end;
 241
 242
 243 procedure TStopWatch.start (reset: Boolean=true);
 244 begin
 245   if mRunning and not reset then exit; // nothing to do
 246   mStartPosition := curTimeMicro();
 247   mRunning := true;
 248   if (reset) then mElapsed := 0;
 249 end;
 250
 251
 252 procedure TStopWatch.stop ();
 253 begin
 254   if not mRunning then exit;
 255   mRunning := false;
 256   updateElapsed();
 257 end;
 258
 259
 260 procedure TStopWatch.pause ();
 261 begin
 262   stop();
 263 end;
 264
 265
 266 procedure TStopWatch.resume ();
 267 begin
 268   if mRunning then exit;
 269   start(false); // don't reset
 270 end;
 271
 272
 273 // ////////////////////////////////////////////////////////////////////////// //
 274 procedure TProfilerBar.initialize (aHistSize: Integer); begin SetLength(history, aHistSize); hisLast := -1; curAccum := 0; curAccumCount := 0; end;
 275
 276 procedure TProfilerBar.update (val: Integer);
 277 var
 278   idx: Integer;
 279 begin
 280   if (val < 0) then val := 0; //else if (val > 1000000) val := 1000000;
 281   if (hisLast = -1) then begin hisLast := High(history); curAccum := 0; curAccumCount := 0; for idx := 0 to High(history) do history[idx] := val; end;
 282   if (curAccumCount = Length(history)) then Dec(curAccum, UInt64(history[(hisLast+1) mod Length(history)])) else Inc(curAccumCount);
 283   Inc(hisLast);
 284   if (hisLast >= Length(history)) then hisLast := 0;
 285   Inc(curAccum, UInt64(val));
 286   history[hisLast] := val;
 287   //curval := FilterFadeoff*val+(1.0-FilterFadeoff)*curval;
 288 end;
 289
 290 function TProfilerBar.getvalue (): Integer;
 291 {$IFDEF XPROFILER_SLOW_AVERAGE}
 292 var idx: Integer;
 293 {$ENDIF}
 294 begin
 295   {$IFDEF XPROFILER_SLOW_AVERAGE}
 296   result := 0;
 297   for idx := 0 to High(history) do Inc(result, history[idx]);
 298   result := result div Length(history);
 299   {$ELSE}
 300   //result := round(curval);
 301   if curAccumCount > 0 then result := Integer(curAccum div curAccumCount) else result := 0;
 302   {$ENDIF}
 303 end;
 304
 305 function TProfilerBar.getcount (): Integer; begin result := Length(history); end;
 306
 307 function TProfilerBar.getvalat (idx: Integer): Integer;
 308 begin
 309   if (idx < 0) or (idx >= Length(history)) then result := 0 else result := history[(hisLast-idx+Length(history)*2) mod Length(history)];
 310 end;
 311
 312
 313 // ////////////////////////////////////////////////////////////////////////// //
 314 constructor TProfiler.Create (aName: AnsiString; aHistSize: Integer);
 315 begin
 316   name := aName;
 317   bars := nil;
 318   if (aHistSize < 10) then aHistSize := 10;
 319   if (aHistSize > 10000) then aHistSize := 10000;
 320   histSize := aHistSize;
 321   {$IF DEFINED(STOPWATCH_IS_HERE)}
 322   xptimer.clear();
 323   xpsecs := nil;
 324   xpsused := 0;
 325   xpscur := -1;
 326   {$ENDIF}
 327 end;
 328
 329
 330 destructor TProfiler.Destroy ();
 331 var
 332   idx: Integer;
 333 begin
 334   for idx := 0 to High(bars) do bars[idx].history := nil;
 335   bars := nil;
 336   {$IF DEFINED(STOPWATCH_IS_HERE)}
 337   xpsecs := nil;
 338   {$ENDIF}
 339   inherited;
 340 end;
 341
 342
 343 procedure TProfiler.mainBegin (reallyActivate: Boolean=true);
 344 begin
 345   {$IF DEFINED(STOPWATCH_IS_HERE)}
 346   xpsused := 0;
 347   xpscur := -1;
 348   xptimer.clear();
 349   if reallyActivate then xptimer.start();
 350   {$ENDIF}
 351 end;
 352
 353 procedure TProfiler.mainEnd ();
 354 {$IF DEFINED(STOPWATCH_IS_HERE)}
 355 var
 356   idx: Integer;
 357   emm: Integer;
 358
 359   procedure finishProfiling ();
 360   var
 361     idx: Integer;
 362   begin
 363     if (xpsused > 0) then
 364     begin
 365       for idx := 0 to xpsused-1 do
 366       begin
 367         xpsecs[idx].timer.stop();
 368         xpsecs[idx].prevAct := -1;
 369       end;
 370     end;
 371     xptimer.stop();
 372     xpscur := -1;
 373   end;
 374 {$ENDIF}
 375 begin
 376   {$IF DEFINED(STOPWATCH_IS_HERE)}
 377   if not xptimer.isRunning then exit;
 378   finishProfiling();
 379   if (xpsused > 0) then
 380   begin
 381     // first time?
 382     if (length(bars) = 0) or (length(bars) <> xpsused+1) then
 383     begin
 384       //if (length(bars) <> 0) then raise Exception.Create('FUUUUUUUUUUUUUUU');
 385       SetLength(bars, xpsused+1);
 386       for idx := 1 to xpsused do
 387       begin
 388         bars[idx].initialize(histSize);
 389         bars[idx].mName := xpsecs[idx-1].name;
 390         bars[idx].mLevel := xpsecs[idx-1].level+1;
 391       end;
 392       bars[0].initialize(histSize);
 393       bars[0].mName := name;
 394       bars[0].mLevel := 0;
 395     end;
 396     // update bars
 397     emm := 0;
 398     for idx := 1 to xpsused do
 399     begin
 400       bars[idx].update(Integer(xpsecs[idx-1].timer.elapsedMicro));
 401       Inc(emm, Integer(xpsecs[idx-1].timer.elapsedMicro));
 402     end;
 403     //bars[0].update(xptimer.elapsedMicro);
 404     bars[0].update(emm);
 405   end
 406   else
 407   begin
 408     if (length(bars) <> 1) then
 409     begin
 410       SetLength(bars, 1);
 411       bars[0].initialize(histSize);
 412       bars[0].mName := name;
 413       bars[0].mLevel := 0;
 414     end;
 415     bars[0].update(xptimer.elapsedMicro);
 416   end;
 417   {$ENDIF}
 418 end;
 419
 420 procedure TProfiler.sectionBegin (name: AnsiString);
 421 {$IF DEFINED(STOPWATCH_IS_HERE)}
 422 var
 423   sid: Integer;
 424   pss: PProfSection;
 425 {$ENDIF}
 426 begin
 427   {$IF DEFINED(STOPWATCH_IS_HERE)}
 428   if not xptimer.isRunning then exit;
 429   if (Length(xpsecs) = 0) then SetLength(xpsecs, 512); // why not?
 430   if (xpsused >= Length(xpsecs)) then raise Exception.Create('too many profile sections');
 431   sid := xpsused;
 432   Inc(xpsused);
 433   pss := @xpsecs[sid];
 434   pss.name := name;
 435   pss.timer.clear();
 436   pss.prevAct := xpscur;
 437   // calculate level
 438   if (xpscur = -1) then pss.level := 0 else pss.level := xpsecs[xpscur].level+1;
 439   xpscur := sid;
 440   pss.timer.start();
 441   {$ENDIF}
 442 end;
 443
 444 procedure TProfiler.sectionBeginAccum (name: AnsiString);
 445 {$IF DEFINED(STOPWATCH_IS_HERE)}
 446 var
 447   idx: Integer;
 448 {$ENDIF}
 449 begin
 450   {$IF DEFINED(STOPWATCH_IS_HERE)}
 451   if not xptimer.isRunning then exit;
 452   if (xpsused > 0) then
 453   begin
 454     for idx := 0 to xpsused-1 do
 455     begin
 456       if (xpsecs[idx].name = name) then
 457       begin
 458         if (idx = xpscur) then raise Exception.Create('profiler error(0): dobule resume: "'+name+'"');
 459         if (xpsecs[idx].prevAct <> -1) then raise Exception.Create('profiler error(1): dobule resume: "'+name+'"');
 460         xpsecs[idx].prevAct := xpscur;
 461         xpscur := idx;
 462         xpsecs[idx].timer.resume();
 463         exit;
 464       end;
 465     end;
 466   end;
 467   sectionBegin(name);
 468   {$ENDIF}
 469 end;
 470
 471 procedure TProfiler.sectionEnd ();
 472 {$IF DEFINED(STOPWATCH_IS_HERE)}
 473 var
 474   pss: PProfSection;
 475 {$ENDIF}
 476 begin
 477   {$IF DEFINED(STOPWATCH_IS_HERE)}
 478   if not xptimer.isRunning then exit;
 479   if (xpscur = -1) then exit; // this is bug, but meh...
 480   pss := @xpsecs[xpscur];
 481   pss.timer.stop();
 482   // go back to parent
 483   xpscur := pss.prevAct;
 484   pss.prevAct := -1;
 485   {$ENDIF}
 486 end;
 487
 488
 489 end.