jvcllaz: Add TJvProfiler.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6859 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2019-04-22 22:51:58 +00:00
parent 1dc7fd8705
commit a908ae901c
11 changed files with 1132 additions and 3 deletions
--- a/components/jvcllaz/run/JvCmp/jvprofilerform.lfm
+++ b/components/jvcllaz/run/JvCmp/jvprofilerform.lfm
@ -0,0 +1,143 @@
+object ProfReport: TProfReport
+  Left = 470
+  Height = 305
+  Top = 178
+  Width = 550
+  ActiveControl = lvReport
+  BorderIcons = [biSystemMenu]
+  Caption = 'Profiler Report'
+  ClientHeight = 305
+  ClientWidth = 550
+  Color = clBtnFace
+  Font.Color = clBlack
+  Icon.Data = {
+    FE0200000000010001002020040000000000E802000016000000280000002000
+    0000400000000100040000000000000200000000000000000000000000000000
+    0000000000000000800000800000008080008000000080008000808000008080
+    8000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
+    FF00000007777777777777777777777777000000777777777777777777777777
+    77700030000000000000000000000007777703BBBBBBBBBBBBBBBBBBBBBBBB80
+    77773BBBBBBBBBBBBBBBBBBBBBBBBBB807773BBBBBBBBBBBBBBBBBBBBBBBBBBB
+    07773BBBBBBBBBBBB8008BBBBBBBBBBB07703BBBBBBBBBBBB0000BBBBBBBBBB8
+    077003BBBBBBBBBBB0000BBBBBBBBBB0770003BBBBBBBBBBB8008BBBBBBBBB80
+    7700003BBBBBBBBBBBBBBBBBBBBBBB077000003BBBBBBBBBBB0BBBBBBBBBB807
+    70000003BBBBBBBBB808BBBBBBBBB07700000003BBBBBBBBB303BBBBBBBB8077
+    000000003BBBBBBBB000BBBBBBBB0770000000003BBBBBBB80008BBBBBB80770
+    0000000003BBBBBB30003BBBBBB077000000000003BBBBBB00000BBBBB807700
+    00000000003BBBBB00000BBBBB07700000000000003BBBBB00000BBBB8077000
+    000000000003BBBB00000BBBB0770000000000000003BBBB00000BBB80770000
+    0000000000003BBB80008BBB077000000000000000003BBBBBBBBBB807700000
+    00000000000003BBBBBBBBB07700000000000000000003BBBBBBBB8077000000
+    000000000000003BBBBBBB0770000000000000000000003BBBBBB80770000000
+    0000000000000003BBBBB077000000000000000000000003BBBB807000000000
+    00000000000000003BB800000000000000000000000000000333000000000000
+    0000F8000003F0000001C0000000800000000000000000000000000000010000
+    00018000000380000003C0000007C0000007E000000FE000000FF000001FF000
+    001FF800003FF800003FFC00007FFC00007FFE0000FFFE0000FFFF0001FFFF00
+    01FFFF8003FFFF8003FFFFC007FFFFC007FFFFE00FFFFFE01FFFFFF07FFFFFF8
+    FFFF
+  }
+  OnShow = FormShow
+  Position = poScreenCenter
+  ShowHint = True
+  LCLVersion = '2.1.0.0'
+  object Panel1: TPanel
+    Left = 0
+    Height = 37
+    Top = 268
+    Width = 550
+    Align = alBottom
+    AutoSize = True
+    BevelOuter = bvNone
+    ClientHeight = 37
+    ClientWidth = 550
+    TabOrder = 0
+    object SaveBtn: TButton
+      AnchorSideLeft.Control = Panel1
+      AnchorSideTop.Control = Panel1
+      AnchorSideTop.Side = asrCenter
+      Left = 6
+      Height = 25
+      Hint = 'Save report to a file (compatible with Excel)'
+      Top = 6
+      Width = 75
+      BorderSpacing.Around = 6
+      Caption = '&Save...'
+      OnClick = SaveBtnClick
+      TabOrder = 0
+    end
+    object TrimBtn: TButton
+      AnchorSideLeft.Control = SaveBtn
+      AnchorSideLeft.Side = asrBottom
+      AnchorSideTop.Control = Panel1
+      AnchorSideTop.Side = asrCenter
+      Left = 87
+      Height = 25
+      Hint = 'Remove unused calls from the list'
+      Top = 6
+      Width = 75
+      BorderSpacing.Around = 6
+      Caption = '&Trim'
+      OnClick = TrimBtnClick
+      TabOrder = 1
+    end
+    object OKBtn: TButton
+      AnchorSideTop.Control = Panel1
+      AnchorSideTop.Side = asrCenter
+      AnchorSideRight.Control = Panel1
+      AnchorSideRight.Side = asrBottom
+      Left = 469
+      Height = 25
+      Hint = 'Close report window'
+      Top = 6
+      Width = 75
+      Anchors = [akTop, akRight]
+      BorderSpacing.Around = 6
+      Cancel = True
+      Caption = '&Close'
+      Default = True
+      ModalResult = 1
+      OnClick = OKBtnClick
+      TabOrder = 2
+    end
+  end
+  object lvReport: TListView
+    Left = 0
+    Height = 268
+    Hint = 'Click the top column to sort the items'
+    Top = 0
+    Width = 550
+    Align = alClient
+    BorderStyle = bsNone
+    Columns = <    
+      item
+        Caption = 'Function / Procedure '
+        Width = 160
+      end    
+      item
+        Alignment = taRightJustify
+        Caption = 'Total time (ms)'
+        Width = 100
+      end    
+      item
+        Alignment = taRightJustify
+        Caption = 'Calls'
+      end    
+      item
+        Alignment = taRightJustify
+        Caption = 'Average time (ms)'
+        Width = 120
+      end    
+      item
+        Alignment = taRightJustify
+        Caption = 'Percent (%)'
+        Width = 90
+      end>
+    GridLines = True
+    MultiSelect = True
+    RowSelect = True
+    TabOrder = 1
+    ViewStyle = vsReport
+    OnColumnClick = lvReportColumnClick
+  end
+end
--- a/components/jvcllaz/run/JvCmp/jvprofilerform.pas
+++ b/components/jvcllaz/run/JvCmp/jvprofilerform.pas
@ -0,0 +1,525 @@
+{-----------------------------------------------------------------------------
+The contents of this file are subject to the Mozilla Public License
+Version 1.1 (the "License"); you may not use this file except in compliance
+with the License. You may obtain a copy of the License at
+http://www.mozilla.org/MPL/MPL-1.1.html
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
+the specific language governing rights and limitations under the License.
+
+The Original Code is: JvProfilerForm.PAS, released on 2002-05-26.
+
+The Initial Developer of the Original Code is Certified Software Corp. [certsoft att quest-net dott com]
+Portions created by Peter Th�rnqvist are Copyright (C) 1996 Certified Software Corp.
+All Rights Reserved.
+
+Contributor(s): Peter Th�rnqvist [peter3 at sourceforge dot net]
+
+You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
+located at http://jvcl.delphi-jedi.org
+
+Known Issues:
+ Use QueryPerformanceCounter / Frequency instead of GetTickCount (the high resolution timer)
+-----------------------------------------------------------------------------}
+// $Id$
+
+unit JvProfilerForm;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, Dialogs, ComCtrls, StdCtrls, Controls, ExtCtrls, Forms;
+
+const
+  MaxProfEntries = 1024; { maximum number of "blocks" to profile }
+  MaxStackSize = 1024;   { maximum nesting of blocks at any one time }
+
+var
+  OddClick: Boolean = True;
+
+type
+  TJvProfileInfo = array [0..MaxProfEntries - 1] of record
+    InOutTime: Longint;
+    TimeSpent: Longint;
+    Calls: Longint;
+    StringID: string;
+  end;
+
+  TProcStack = array [1..MaxStackSize] of record
+    CallerID: Integer;
+    EntryTime: Longint;
+  end;
+
+  TProfReport = class(TForm)
+    Panel1: TPanel;
+    SaveBtn: TButton;
+    lvReport: TListView;
+    OKBtn: TButton;
+    TrimBtn: TButton;
+    procedure FormShow(Sender: TObject);
+    procedure lvReportColumnClick(Sender: TObject; Column: TListColumn);
+    procedure SaveBtnClick(Sender: TObject);
+    procedure OKBtnClick(Sender: TObject);
+    procedure TrimBtnClick(Sender: TObject);
+  public
+    StartTime: Integer;
+    EndTime: Integer;
+    LastProc: Integer;
+    ProfileInfo: TJvProfileInfo;
+  end;
+
+  TJvProfiler = class(TComponent)
+  private
+    FProfileInfo: TJvProfileInfo;
+    FNames: TStringList;
+    FStack: TProcStack;
+    FStartTime: Longint;
+    FEndTime: Longint;
+    FLastProc: Integer;
+    FStackSize: Integer;
+    FEnabled: Boolean;
+    FStarted: Boolean;
+    FSorted: Boolean;
+    FOnStart: TNotifyEvent;
+    FOnStop: TNotifyEvent;
+    function GetNames: TStrings;
+    procedure SetNames(Value: TStrings);
+    procedure SetEnabled(Value: Boolean);
+    procedure SetSorted(Value: Boolean);
+  protected
+    procedure DoStart; virtual;
+    procedure DoStop; virtual;
+    procedure Initialize; virtual;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Start;
+    procedure EnterID(ID: Integer);
+    procedure EnterName(const AName: string);
+    procedure ExitName(const AName: string);
+    procedure ExitID(ID: Integer);
+    procedure Stop;
+    procedure ShowReport;
+  published
+    property Enabled: Boolean read FEnabled write SetEnabled default False;
+    property Names: TStrings read GetNames write SetNames;
+    property Sorted: Boolean read FSorted write SetSorted default False;
+    property OnStart: TNotifyEvent read FOnStart write FOnStart;
+    property OnStop: TNotifyEvent read FOnStop write FOnStop;
+  end;
+
+
+implementation
+
+uses
+ {$IFDEF LINUX}
+  baseunix, unix, linux, users,
+ {$ELSE}
+  Windows,
+ {$ENDIF}
+  SysUtils, LazUTF8,
+  JvConsts, JvTypes, JvResources;
+
+{$R *.lfm}
+
+const
+  EmptyLine = '0.00';
+  DefHeader2 =
+    'Profiler 32 - (C) 1996 Certified Software Corp, portions Copyright (C) 1997 by Peter Th�rnqvist; all rights reserved.';
+
+type
+  PProfType = ^TProfType;
+  TProfType = record
+    InOutTime: Integer;
+    TimeSpent: Integer;
+    Calls: Integer;
+    StringID: string;
+  end;
+
+  PStackType = ^TStackType;
+  TStackType = record
+    CallerID: Integer;
+    EntryTime: Integer;
+  end;
+
+function GetUserName: String;
+// http://forum.lazarus.freepascal.org/index.php/topic,23171.msg138057.html#msg138057
+{$IFDEF WINDOWS}
+const
+  MaxLen = 256;
+var
+  Len: DWORD;
+  WS: WideString;
+  Res: windows.BOOL;
+{$ENDIF}
+begin
+  Result := '';
+ {$IFDEF UNIX}
+  {$IF (DEFINED(LINUX)) OR (DEFINED(FREEBSD))}
+  Result := SysToUtf8(users.GetUserName(fpgetuid));   //GetUsername in unit Users, fpgetuid in unit BaseUnix
+  {$ELSE Linux/BSD}
+  Result := GetEnvironmentVariableUtf8('USER');
+  {$ENDIF UNIX}
+ {$ELSE}
+ {$IFDEF WINDOWS}
+  Len := MaxLen;
+  {$IFnDEF WINCE}
+  if Win32MajorVersion <= 4 then begin
+    SetLength(Result,MaxLen);
+    Res := Windows.GetUserName(@Result[1], Len);
+    //writeln('GetUserNameA = ',Res);
+    if Res then begin
+      SetLength(Result,Len-1);
+      Result := WinCPToUtf8(Result);
+    end else
+      SetLength(Result,0);
+  end
+  else
+  {$ENDIF NOT WINCE}
+  begin
+    SetLength(WS, MaxLen-1);
+    Res := Windows.GetUserNameW(@WS[1], Len);
+    //writeln('GetUserNameW = ',Res);
+    if Res then begin
+      SetLength(WS, Len - 1);
+      Result := Utf16ToUtf8(WS);
+    end else
+      SetLength(Result,0);
+  end;
+  {$ENDIF WINDOWS}
+  {$ENDIF UNIX}
+end;
+
+function GetComputerName : string;
+{$IFDEF WINDOWS}
+var
+  len : cardinal;
+begin
+  len := MAX_COMPUTERNAME_LENGTH + 1;
+  SetLength(result, len);
+  if Windows.GetComputerName(PChar(result), len) then begin
+    SetLength(Result, len);
+    Result := WinCPToUTF8(Result);
+  end
+  else
+    RaiseLastWin32Error;
+end;
+{$ELSE}
+begin
+  Result := GetHostName;
+end;
+{$ENDIF}
+
+
+//=== { TJvProfiler } ========================================================
+
+constructor TJvProfiler.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FNames := TStringList.Create;
+end;
+
+destructor TJvProfiler.Destroy;
+begin
+  Stop;
+  FNames.Free;
+  inherited Destroy;
+end;
+
+procedure TJvProfiler.Initialize;
+var
+  I: Integer;
+begin
+  FEnabled := False;
+  FStarted := False;
+  FStartTime := 0;
+  FEndTime := 0;
+  FStackSize := 0;
+  FLastProc := -1;
+  { build ID list }
+  for I := 0 to FNames.Count - 1 do
+  begin
+    if Length(Trim(FNames[I])) < 1 then
+      Continue;                         { skip empty ID's }
+    if FLastProc > MaxProfEntries then
+      raise EJVCLException.CreateResFmt(@RsEMaxNumberOfIDsExceededd, [MaxProfEntries - 1]);
+    Inc(FLastProc);
+    with FProfileInfo[FLastProc] do
+    begin
+      TimeSpent := 0;
+      Calls := 0;
+      StringID := FNames[I];
+    end;
+  end;
+end;
+
+procedure TJvProfiler.EnterID(ID: Integer);
+var
+  Snap: Integer;
+begin
+  if FEnabled then
+  begin
+    Snap := GetTickCount;
+    if FStackSize > MaxStackSize then
+      raise EJVCLException.CreateResFmt(@RsEMaxStackSizeExceededd, [MaxStackSize]);
+    Inc(FStackSize);
+
+    with FStack[FStackSize] do
+    begin
+      EntryTime := Snap;
+      CallerID := ID
+    end;
+
+    with FProfileInfo[ID] do
+    begin
+      Inc(Calls);
+      InOutTime := Snap;
+    end;
+  end;
+end;
+
+procedure TJvProfiler.EnterName(const AName: string);
+begin
+  EnterID(FNames.IndexOf(AName));
+end;
+
+procedure TJvProfiler.ExitName(const AName: string);
+begin
+  ExitID(FNames.IndexOf(AName));
+end;
+
+procedure TJvProfiler.ExitID(ID: Integer);
+var
+  Snap, Elapsed: Integer;
+begin
+  if Enabled then
+  begin
+    Snap := GetTickCount;
+    with FProfileInfo[ID] do
+    begin
+      Elapsed := Snap - InOutTime;
+      TimeSpent := TimeSpent + Elapsed;
+    end;
+    if FStackSize > 0 then
+      Dec(FStackSize);
+    if FStackSize > 0 then
+      with FProfileInfo[FStack[FStackSize].CallerID] do
+        TimeSpent := TimeSpent - Elapsed;
+  end;
+end;
+
+procedure TJvProfiler.DoStart;
+begin
+  if Assigned(FOnStart) then
+    FOnStart(Self);
+end;
+
+procedure TJvProfiler.DoStop;
+begin
+  if Assigned(FOnStop) then
+    FOnStop(Self);
+end;
+
+procedure TJvProfiler.Start;
+begin
+  if FEnabled and not FStarted then
+  begin
+    //    Initialize;
+    DoStart;
+    FStartTime := GetTickCount;
+    FStarted := True;
+  end;
+end;
+
+procedure TJvProfiler.Stop;
+begin
+  if FEnabled and FStarted then
+  begin
+    FEndTime := GetTickCount;
+    DoStop;
+    FStarted := False;
+  end;
+end;
+
+function TJvProfiler.GetNames: TStrings;
+begin
+  Result := FNames;
+end;
+
+procedure TJvProfiler.SetNames(Value: TStrings);
+begin
+  FNames.Assign(Value);
+  Initialize;
+end;
+
+procedure TJvProfiler.SetEnabled(Value: Boolean);
+begin
+  if FEnabled <> Value then
+    FEnabled := Value;
+end;
+
+procedure TJvProfiler.SetSorted(Value: Boolean);
+begin
+  if FSorted <> Value then
+  begin
+    FSorted := Value;
+    FNames.Sorted := FSorted;
+    Initialize;
+  end;
+end;
+
+procedure TJvProfiler.ShowReport;
+begin
+  if FEnabled then
+  begin
+    if FStarted then
+      Stop;
+    with TProfReport.Create(nil) do
+    begin
+      EndTime := FEndTime;
+      StartTime := FStartTime;
+      LastProc := FLastProc;
+      ProfileInfo := FProfileInfo;
+      ShowModal;
+      Free;
+    end;
+  end;
+end;
+
+//=== { TProfReport } ========================================================
+
+procedure TProfReport.FormShow(Sender: TObject);
+const
+  NumberFormat = '%4.2f';
+var
+  ThisProc: Integer;
+  TotalSum: Integer;
+  LItem: TListItem;
+begin
+  OddClick := True;
+  TotalSum := (EndTime - StartTime);
+  if TotalSum = 0 then
+    Exit;
+  lvReport.Items.BeginUpdate;
+  lvReport.Items.Clear;
+  for ThisProc := 0 to LastProc do
+    with ProfileInfo[ThisProc] do
+    begin
+      LItem := lvReport.Items.Add;
+      LItem.Caption := StringID;        { function ID }
+      if Calls <> 0 then
+      begin
+        LItem.SubItems.Add(Format(NumberFormat, [TimeSpent * 1.0]));  { Total time spent here }
+        LItem.SubItems.Add(IntToStr(Calls)); { Total number of calls }
+        LItem.SubItems.Add(Format(NumberFormat, [TimeSpent / Calls]));  { average time }
+        LItem.SubItems.Add(Format(NumberFormat, [TimeSpent / TotalSum * 100.0]));  { percentage }
+      end
+      else
+      begin
+        LItem.SubItems.Add(EmptyLine);
+        LItem.SubItems.Add('0');
+        LItem.SubItems.Add(EmptyLine);
+        LItem.SubItems.Add(EmptyLine);
+      end;
+    end;
+  Caption := Format(RsTotalElapsedTimedms, [RsDefCaption, TotalSum]);
+  lvReport.Items.EndUpdate;
+end;
+
+function IsFloat(S: string): Boolean;
+var
+  x: Double;
+begin
+  Result := TryStrToFloat(S, x);
+end;
+
+function DefSort(lParam1, lParam2: TListItem; lParamSort: Integer): Integer; stdcall;
+var
+  l1, l2: Extended;
+begin
+  if lParamSort = 0 then
+    Result := AnsiCompareText(lParam1.Caption, lParam2.Caption)
+  else
+  begin
+    if not IsFloat(lParam1.SubItems[lParamSort - 1]) then
+      l1 := -1.0
+    else
+      l1 := StrToFloat(lParam1.SubItems[lParamSort - 1]);
+    if not IsFloat(lParam2.SubItems[lParamSort - 1]) then
+      l2 := -1.0
+    else
+      l2 := StrToFloat(lParam2.SubItems[lParamSort - 1]);
+    Result := Round((l1 * 1000) - (l2 * 1000));
+  end;
+  if OddClick then
+    Result := -Result;
+end;
+
+procedure TProfReport.lvReportColumnClick(Sender: TObject; Column: TListColumn);
+begin
+  //  lvReport.Items.BeginUpdate;
+  lvReport.CustomSort(TLVCompare(@DefSort), Column.Index);
+  OddClick := not OddClick;
+  //  lvReport.Items.EndUpdate;
+end;
+
+procedure TProfReport.SaveBtnClick(Sender: TObject);
+var
+  OutList: TStringList;
+  S: string;
+  I, J: Integer;
+begin
+  with TSaveDialog.Create(nil) do
+  begin
+    Filter := RsTextFormatsasctxtinfdocAllFiles;
+    if Execute then
+    begin
+      OutList := TStringList.Create;
+      OutList.Add(Format(RsDefHeader, [DateToStr(Now), GetUserName,
+        GetComputerName]));
+      OutList.Add(DefHeader2);
+      S := '';
+      for I := 0 to lvReport.Columns.Count - 1 do
+        S := S + lvReport.Columns[I].Caption + Tab;
+      OutList.Add(S);
+      S := '';
+      with lvReport do
+        for I := 0 to Items.Count - 1 do
+        begin
+          with Items[I] do
+          begin
+            S := S + Caption + Tab;
+            for J := 0 to SubItems.Count - 1 do
+              S := S + SubItems[J] + Tab;
+            OutList.Add(S);
+          end;
+          S := '';
+        end;
+      OutList.SaveToFile(Filename);
+      OutList.Free;
+    end;
+    Free;
+  end;
+end;
+
+procedure TProfReport.OKBtnClick(Sender: TObject);
+begin
+  Close;
+end;
+
+procedure TProfReport.TrimBtnClick(Sender: TObject);
+var
+  I: Integer;
+begin
+  lvReport.Items.BeginUpdate;
+  for I := lvReport.Items.Count - 1 downto 0 do
+    { no calls = not used }
+    if lvReport.Items[I].SubItems[1] = '0' then
+      lvReport.Items.Delete(I);
+  lvReport.Items.EndUpdate;
+end;
+
+end.