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 // TStopWatch is based on the code by Inoussa OUEDRAOGO, Copyright (c) 2012
  18 {$INCLUDE a_modes.inc}
  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   private
  43   {$IF DEFINED(LINUX)}
  44     type TBaseMesure = TTimeSpec;
  45   {$ELSE}
  46     type TBaseMesure = Int64;
  47   {$ENDIF}
  48
  49   strict private
  50     class var mFrequency: Int64;
  51     class var mIsHighResolution: Boolean;
  52
  53   strict private
  54     mElapsed: Int64;
  55     mRunning: Boolean;
  56     mStartPosition: TBaseMesure;
  57
  58   strict private
  59     class procedure initTimerIntr (); static;
  60
  61     procedure updateElapsed ();
  62
  63     function getElapsedMilliseconds (): Int64;
  64     function getElapsedMicroseconds (): Int64;
  65     function getElapsedTicks (): Int64;
  66
  67   public
  68     class function Create (): TStopWatch; static;
  69     class function startNew (): TStopWatch; static;
  70
  71     class property frequency : Int64 read mFrequency;
  72     class property isHighResolution : Boolean read mIsHighResolution;
  73
  74   public
  75     procedure clear (); inline; // full clear
  76     procedure start (); // start or restart timer
  77     procedure stop ();
  78
  79     property elapsedMilli: Int64 read getElapsedMilliseconds;
  80     property elapsedMicro: Int64 read getElapsedMicroseconds;
  81     property elapsedTicks: Int64 read getElapsedTicks;
  82     property isRunning: Boolean read mRunning;
  83   end;
  84 {$ENDIF}
  85
  86
  87 const
  88   TProfHistorySize = 100;
  89
  90 type
  91   TProfilerBar = record
  92   private
  93     const FilterFadeoff = 0.05; // 5%
  94
  95   private
  96     history: array [0..TProfHistorySize-1] of Integer; // circular buffer
  97     hisHead: Integer;
  98     curval: Single;
  99     mName: AnsiString;
 100     mLevel: Integer;
 101
 102   private
 103     procedure initialize (); inline;
 104     function getvalue (): Integer; inline;
 105     function getvalat (idx: Integer): Integer; inline;
 106     function getcount (): Integer; inline;
 107
 108   public
 109     procedure update (val: Integer);
 110
 111     property value: Integer read getvalue;
 112     property name: AnsiString read mName;
 113     property level: Integer read mLevel;
 114     property count: Integer read getcount;
 115     property values[idx: Integer]: Integer read getvalat;
 116   end;
 117
 118   TProfiler = class(TObject)
 119   public
 120     bars: array of TProfilerBar;
 121     name: AnsiString;
 122
 123   public
 124     constructor Create (aName: AnsiString);
 125     destructor Destroy (); override;
 126
 127     procedure mainBegin (reallyActivate: Boolean=true);
 128     procedure mainEnd ();
 129
 130     procedure sectionBegin (name: AnsiString);
 131     procedure sectionEnd ();
 132   end;
 133
 134
 135 // call this on frame start
 136 procedure xprofBegin (reallyActivate: Boolean=true);
 137 // call this on frame end
 138 procedure xprofEnd ();
 139
 140 function xprofTotalMicro (): Int64; // total duration, microseconds
 141 function xprofTotalMilli (): Int64; // total duration, milliseconds
 142 function xprofTotalCount (): Integer; // all items
 143
 144 // don't fuckup pairing of there, 'cause they can be nested!
 145 procedure xprofBeginSection (name: AnsiString);
 146 procedure xprofEndSection ();
 147
 148 function xprofNameAt (idx: Integer): AnsiString;
 149 function xprofMicroAt (idx: Integer): Int64;
 150 function xprofMilliAt (idx: Integer): Int64;
 151 function xprofHasChildrenAt (idx: Integer): Boolean;
 152 function xprofLevelAt (idx: Integer): Integer;
 153
 154 // iterator
 155 function xprofItReset (): Boolean; // false: no sections
 156 function xprofItCount (): Integer; // from current item to eol (not including children, but including current item)
 157 // current item info
 158 function xprofItName (): AnsiString; // current section name
 159 function xprofItMicro (): Int64; // current section duration, microseconds
 160 function xprofItMilli (): Int64; // current section duration, milliseconds
 161 function xprofItHasChildren (): Boolean;
 162 function xprofItIsChild (): Boolean;
 163 function xprofItLevel (): Integer; // 0: top
 164
 165 function xprofItDive (): Boolean; // dive into childrens
 166 function xprofItPop (): Boolean; // pop into parent
 167 function xprofItNext (): Boolean; // move to next sibling; false: no more siblings (and current item is unchanged)
 168
 169
 170 implementation
 171
 172 const
 173   TicksPerNanoSecond = 100;
 174   TicksPerMilliSecond = 10000;
 175   TicksPerSecond = 10000000000000000;
 176
 177
 178 // ////////////////////////////////////////////////////////////////////////// //
 179 class procedure TStopWatch.initTimerIntr ();
 180 {$IF DEFINED(LINUX)}
 181 var
 182   r: TBaseMesure;
 183 {$ENDIF}
 184 begin
 185   if (mFrequency = 0) then
 186   begin
 187 {$IF DEFINED(LINUX)}
 188     mIsHighResolution := (clock_getres(CLOCK_MONOTONIC, @r) = 0);
 189     mIsHighResolution := mIsHighResolution and (r.tv_nsec <> 0);
 190     if (r.tv_nsec <> 0) then mFrequency := 1000000000000000000 div r.tv_nsec;
 191 {$ELSE}
 192     mIsHighResolution := QueryPerformanceFrequency(mFrequency);
 193 {$ENDIF}
 194   end;
 195 end;
 196
 197
 198 class function TStopWatch.Create (): TStopWatch;
 199 begin
 200   initTimerIntr();
 201   result.clear();
 202 end;
 203
 204
 205 class function TStopWatch.startNew (): TStopWatch;
 206 begin
 207   result := TStopWatch.Create();
 208   result.start();
 209 end;
 210
 211
 212 function TStopWatch.getElapsedMilliseconds (): Int64;
 213 begin
 214   if (mFrequency = 0) then begin result := 0; exit; end;
 215   if mRunning then updateElapsed();
 216   {$IF DEFINED(LINUX)}
 217     result := mElapsed div 1000000;
 218   {$ELSE}
 219     result := elapsedTicks*TicksPerMilliSecond;
 220   {$ENDIF}
 221 end;
 222
 223
 224 function TStopWatch.getElapsedMicroseconds (): Int64;
 225 begin
 226   if (mFrequency = 0) then begin result := 0; exit; end;
 227   if mRunning then updateElapsed();
 228   {$IF DEFINED(LINUX)}
 229   result := mElapsed div 1000;
 230   {$ELSE}
 231   result := elapsedTicks*(TicksPerMilliSecond div 100);
 232   {$ENDIF}
 233 end;
 234
 235
 236 function TStopWatch.getElapsedTicks (): Int64;
 237 begin
 238   if (mFrequency = 0) then begin result := 0; exit; end;
 239   if mRunning then updateElapsed();
 240   {$IF DEFINED(LINUX)}
 241   result := mElapsed div TicksPerNanoSecond;
 242   {$ELSE}
 243   result := (mElapsed*TicksPerSecond) div mFrequency;
 244   {$ENDIF}
 245 end;
 246
 247
 248 procedure TStopWatch.clear ();
 249 begin
 250   //FillChar(self, sizeof(self), 0);
 251   mElapsed := 0;
 252   mRunning := false;
 253   //mStartPosition: TBaseMesure;
 254 end;
 255
 256
 257 procedure TStopWatch.start ();
 258 begin
 259   //if mRunning then exit;
 260   if (mFrequency = 0) then initTimerIntr();
 261   mRunning := true;
 262   mElapsed := 0;
 263   {$IF DEFINED(LINUX)}
 264   clock_gettime(CLOCK_MONOTONIC, @mStartPosition);
 265   {$ELSE}
 266   QueryPerformanceCounter(mStartPosition);
 267   {$ENDIF}
 268 end;
 269
 270
 271 procedure TStopWatch.updateElapsed ();
 272 var
 273   locEnd: TBaseMesure;
 274   {$IF DEFINED(LINUX)}
 275   s, n: Int64;
 276   {$ENDIF}
 277 begin
 278   {$IF DEFINED(LINUX)}
 279   clock_gettime(CLOCK_MONOTONIC, @locEnd);
 280   if (locEnd.tv_nsec < mStartPosition.tv_nsec) then
 281   begin
 282     s := locEnd.tv_sec-mStartPosition.tv_sec-1;
 283     n := 1000000000000000000+locEnd.tv_nsec-mStartPosition.tv_nsec;
 284   end
 285   else
 286   begin
 287     s := locEnd.tv_sec-mStartPosition.tv_sec;
 288     n := locEnd.tv_nsec-mStartPosition.tv_nsec;
 289   end;
 290   mElapsed := mElapsed+(s*1000000000000000000)+n;
 291   {$ELSE}
 292   QueryPerformanceCounter(locEnd);
 293   mElapsed := mElapsed+(UInt64(locEnd)-UInt64(mStartPosition));
 294   {$ENDIF}
 295 end;
 296
 297
 298 procedure TStopWatch.stop ();
 299 begin
 300   if not mRunning then exit;
 301   mRunning := false;
 302   updateElapsed();
 303 end;
 304
 305
 306 // ////////////////////////////////////////////////////////////////////////// //
 307 // high-level profiler
 308 {$IF DEFINED(STOPWATCH_IS_HERE)}
 309 type
 310   PProfSection = ^TProfSection;
 311   TProfSection = record
 312     name: AnsiString;
 313     timer: TStopWatch;
 314     parent: Integer; // section index in xpsecs or -1
 315     firstChild: Integer; // first child, or -1
 316     next: Integer; // next sibling, or -1
 317     level: Integer;
 318   end;
 319
 320 var
 321   xptimer: TStopWatch;
 322   xpsecs: array of TProfSection = nil;
 323   xpsused: Integer = 0;
 324   xpscur: Integer = -1; // currently running section
 325   xpslevel: Integer = 0;
 326   xitcur: Integer = -1; // for iterator
 327
 328
 329 // call this on frame start
 330 procedure xprofBegin (reallyActivate: Boolean=true);
 331 begin
 332   xpsused := 0;
 333   xpscur := -1;
 334   xitcur := -1; // reset iterator
 335   xpslevel := 0;
 336   xptimer.clear();
 337   if reallyActivate then xptimer.start();
 338 end;
 339
 340
 341 // call this on frame end
 342 procedure xprofEnd ();
 343 begin
 344   if not xptimer.isRunning then exit;
 345   while xpscur <> -1 do
 346   begin
 347     xpsecs[xpscur].timer.stop();
 348     xpscur := xpsecs[xpscur].parent;
 349   end;
 350   xptimer.stop();
 351 end;
 352
 353
 354 // don't fuckup pairing of there, 'cause they can be nested!
 355 //FIXME: rewrite without schlemiel's algo!
 356 procedure xprofBeginSection (name: AnsiString);
 357 var
 358   sid, t: Integer;
 359   pss: PProfSection;
 360 begin
 361   if not xptimer.isRunning then exit;
 362   if (Length(xpsecs) = 0) then SetLength(xpsecs, 65536); // why not?
 363   if (xpsused >= Length(xpsecs)) then raise Exception.Create('too many profile sections');
 364   sid := xpsused;
 365   Inc(xpsused);
 366   pss := @xpsecs[sid];
 367   pss.name := name;
 368   pss.timer.clear();
 369   pss.parent := xpscur;
 370   pss.firstChild := -1;
 371   pss.next := -1;
 372   pss.level := xpslevel;
 373   Inc(xpslevel);
 374   // link to list
 375   if (xpscur <> -1) then
 376   begin
 377     // child
 378     t := xpsecs[xpscur].firstChild;
 379     if (t = -1) then
 380     begin
 381       xpsecs[xpscur].firstChild := sid;
 382     end
 383     else
 384     begin
 385       while (xpsecs[t].next <> -1) do t := xpsecs[t].next;
 386       xpsecs[t].next := sid;
 387     end;
 388   end
 389   else
 390   begin
 391     // top level
 392     if (sid <> 0) then
 393     begin
 394       t := 0;
 395       while (xpsecs[t].next <> -1) do t := xpsecs[t].next;
 396       xpsecs[t].next := sid;
 397     end;
 398   end;
 399   xpscur := sid;
 400   pss.timer.start();
 401 end;
 402
 403
 404 procedure xprofEndSection ();
 405 var
 406   pss: PProfSection;
 407 begin
 408   if not xptimer.isRunning then exit;
 409   if (xpscur = -1) then exit; // this is bug, but meh...
 410   Dec(xpslevel);
 411   pss := @xpsecs[xpscur];
 412   pss.timer.stop();
 413   // go back to parent
 414   xpscur := pss.parent;
 415 end;
 416
 417
 418 procedure xprofGlobalInit ();
 419 begin
 420   //SetLength(xpsecs, 1024); // 'cause why not? 'cause don't pay for something you may not need
 421   xptimer.clear();
 422 end;
 423
 424
 425 // ////////////////////////////////////////////////////////////////////////// //
 426 // iterator
 427 function xprofTotalMicro (): Int64; begin result := xptimer.elapsedMicro; end;
 428 function xprofTotalMilli (): Int64; begin result := xptimer.elapsedMilli; end;
 429
 430 // all items
 431 function xprofTotalCount (): Integer;
 432 begin
 433   if xptimer.isRunning then result := 0 else result := xpsused;
 434 end;
 435
 436
 437 function xprofNameAt (idx: Integer): AnsiString; begin if xptimer.isRunning or (idx < 0) or (idx >= xpsused) then result := '' else result := xpsecs[idx].name; end;
 438 function xprofMicroAt (idx: Integer): Int64; begin if xptimer.isRunning or (idx < 0) or (idx >= xpsused) then result := 0 else result := xpsecs[idx].timer.elapsedMicro; end;
 439 function xprofMilliAt (idx: Integer): Int64; begin if xptimer.isRunning or (idx < 0) or (idx >= xpsused) then result := 0 else result := xpsecs[idx].timer.elapsedMilli; end;
 440 function xprofHasChildrenAt (idx: Integer): Boolean; begin if xptimer.isRunning or (idx < 0) or (idx >= xpsused) then result := false else result := (xpsecs[idx].firstChild <> -1); end;
 441 function xprofLevelAt (idx: Integer): Integer; begin if xptimer.isRunning or (idx < 0) or (idx >= xpsused) then result := 0 else result := xpsecs[idx].level; end;
 442
 443
 444 // false: no sections
 445 function xprofItReset (): Boolean;
 446 begin
 447   result := false;
 448   xitcur := -1;
 449   if xptimer.isRunning then exit;
 450   if (xpsused = 0) then exit; // no sections
 451   xitcur := 0;
 452   assert(xpsecs[0].parent = -1);
 453   result := true;
 454 end;
 455
 456
 457 // from current item to eol (not including children, but including current item)
 458 function xprofItCount (): Integer;
 459 var
 460   idx: Integer;
 461 begin
 462   result := 0;
 463   idx := xitcur;
 464   while (idx <> -1) do
 465   begin
 466     Inc(result);
 467     idx := xpsecs[idx].next;
 468   end;
 469 end;
 470
 471
 472 // current item info
 473 function xprofItName (): AnsiString; begin if (xitcur = -1) then result := '' else result := xpsecs[xitcur].name; end;
 474 function xprofItMicro (): Int64; begin if (xitcur = -1) then result := 0 else result := xpsecs[xitcur].timer.elapsedMicro; end;
 475 function xprofItMilli (): Int64; begin if (xitcur = -1) then result := 0 else result := xpsecs[xitcur].timer.elapsedMilli; end;
 476 function xprofItHasChildren (): Boolean; begin if (xitcur = -1) then result := false else result := (xpsecs[xitcur].firstChild <> -1); end;
 477 function xprofItIsChild (): Boolean; begin if (xitcur = -1) then result := false else result := (xpsecs[xitcur].parent <> -1); end;
 478 function xprofItLevel (): Integer; begin if (xitcur = -1) then result := 0 else result := xpsecs[xitcur].level; end;
 479
 480 // dive into childrens
 481 function xprofItDive (): Boolean;
 482 begin
 483   if (xitcur = -1) or (xpsecs[xitcur].firstChild = -1) then
 484   begin
 485     result := false;
 486   end
 487   else
 488   begin
 489     result := true;
 490     xitcur := xpsecs[xitcur].firstChild;
 491   end;
 492 end;
 493
 494 // pop into parent
 495 function xprofItPop (): Boolean;
 496 begin
 497   if (xitcur = -1) or (xpsecs[xitcur].parent = -1) then
 498   begin
 499     result := false;
 500   end
 501   else
 502   begin
 503     result := true;
 504     xitcur := xpsecs[xitcur].parent;
 505   end;
 506 end;
 507
 508 // move to next sibling; false: no more siblings (and current item is unchanged)
 509 function xprofItNext (): Boolean;
 510 begin
 511   if (xitcur = -1) or (xpsecs[xitcur].next = -1) then
 512   begin
 513     result := false;
 514   end
 515   else
 516   begin
 517     result := true;
 518     xitcur := xpsecs[xitcur].next;
 519   end;
 520 end;
 521
 522 {$ELSE}
 523 procedure xprofBegin (reallyActivate: Boolean=true); begin end;
 524 procedure xprofEnd (); begin end;
 525 procedure xprofBeginSection (name: AnsiString); begin end;
 526 procedure xprofEndSection (); begin end;
 527
 528 function xprofTotalMicro (): Int64; begin result := 0; end;
 529 function xprofTotalMilli (): Int64; begin result := 0; end;
 530 function xprofTotalCount (): Integer; begin result := 0; end;
 531
 532 function xprofNameAt (idx: Integer): AnsiString; begin result := ''; end;
 533 function xprofMicroAt (idx: Integer): Int64; begin result := 0; end;
 534 function xprofMilliAt (idx: Integer): Int64; begin result := 0; end;
 535 function xprofHasChildrenAt (idx: Integer): Boolean; begin result := false; end;
 536 function xprofLevelAt (idx: Integer): Integer; begin result := 0; end;
 537
 538 function xprofItReset (): Boolean; begin result := false; end;
 539 function xprofItCount (): Integer; begin result := 0; end;
 540 // current item info
 541 function xprofItName (): AnsiString; begin result := ''; end;
 542 function xprofItMicro (): Int64; begin result := 0; end;
 543 function xprofItMilli (): Int64; begin result := 0; end;
 544 function xprofItHasChildren (): Boolean; begin result := false; end;
 545 function xprofItIsChild (): Boolean; begin result := false; end;
 546
 547 function xprofItDepth (): Integer; begin result := 0; end;
 548
 549 function xprofItDive (): Boolean; begin result := false; end;
 550 function xprofItPop (): Boolean; begin result := false; end;
 551 function xprofItNext (): Boolean; begin result := false; end;
 552 {$ENDIF}
 553
 554
 555 // ////////////////////////////////////////////////////////////////////////// //
 556 procedure TProfilerBar.initialize (); begin hisHead := -1; curval := 0; end;
 557
 558 procedure TProfilerBar.update (val: Integer);
 559 var
 560   idx: Integer;
 561 begin
 562   if (val < 0) then val := 0; //else if (val > 1000000) val := 1000000;
 563   if (hisHead = -1) then begin hisHead := 0; curval := 0; for idx := 0 to TProfHistorySize-1 do history[idx] := val; end;
 564   history[hisHead] := val;
 565   Inc(hisHead);
 566   if (hisHead = TProfHistorySize) then hisHead := 0;
 567   curval := FilterFadeoff*val+(1.0-FilterFadeoff)*curval;
 568 end;
 569
 570 function TProfilerBar.getvalue (): Integer; begin result := round(curval); end;
 571
 572 function TProfilerBar.getcount (): Integer; begin result := TProfHistorySize; end;
 573
 574 function TProfilerBar.getvalat (idx: Integer): Integer;
 575 begin
 576   if (idx < 0) or (idx >= TProfHistorySize) then result := 0 else result := history[(hisHead-idx-1+TProfHistorySize*2) mod TProfHistorySize];
 577 end;
 578
 579
 580 // ////////////////////////////////////////////////////////////////////////// //
 581 constructor TProfiler.Create (aName: AnsiString);
 582 begin
 583   name := aName;
 584   bars := nil;
 585 end;
 586
 587
 588 destructor TProfiler.Destroy ();
 589 begin
 590   bars := nil;
 591   inherited;
 592 end;
 593
 594
 595 procedure TProfiler.mainBegin (reallyActivate: Boolean=true);
 596 begin
 597   xprofBegin(reallyActivate);
 598 end;
 599
 600 procedure TProfiler.mainEnd ();
 601 var
 602   idx: Integer;
 603 begin
 604   xprofEnd();
 605   if (xprofTotalCount > 0) then
 606   begin
 607     // first time?
 608     if (length(bars) = 0) or (length(bars) <> xprofTotalCount+1) then
 609     begin
 610       //if (length(bars) <> 0) then raise Exception.Create('FUUUUUUUUUUUUUUU');
 611       SetLength(bars, xprofTotalCount+1);
 612       for idx := 1 to xprofTotalCount do
 613       begin
 614         bars[idx].initialize();
 615         bars[idx].mName := xprofNameAt(idx-1);
 616         bars[idx].mLevel := xprofLevelAt(idx-1)+1;
 617       end;
 618       bars[0].initialize();
 619       bars[0].mName := name;
 620       bars[0].mLevel := 0;
 621     end;
 622     // update bars
 623     for idx := 1 to xprofTotalCount do bars[idx].update(xprofMicroAt(idx-1));
 624     bars[0].update(xprofTotalMicro);
 625   end;
 626 end;
 627
 628 procedure TProfiler.sectionBegin (name: AnsiString);
 629 begin
 630   xprofBeginSection(name);
 631 end;
 632
 633 procedure TProfiler.sectionEnd ();
 634 begin
 635   xprofEndSection();
 636 end;
 637
 638
 639 begin
 640   {$IF DEFINED(STOPWATCH_IS_HERE)}
 641   xprofGlobalInit();
 642   {$ENDIF}
 643 end.