performance - 当屏幕上有很多控件时出现严重的 FireMonkey 性能问题

Question

我们在办公室与 FireMonkey 合作已经有一段时间了。过了一段时间，我们注意到由于 GPU 加速，它并没有像 Embarcadero 告诉我们的那样快如闪电。

所以我们构建了一个基本的应用程序来测试 FireMonkey 的性能。基本上它是一个底部有一个面板（alBottom）的表单，用作状态栏和一个所有客户端（alClient）面板。底部的面板有一个进度条和一个动画。

我们向表单添加了一个方法，该方法可以释放所有客户端面板中存在的任何控件，并使用自定义类型的单元格和“鼠标悬停”样式来实现它，并使用有关信息的信息更新动画、进度条和表单的标题充实的进步。最重要的信息是所需的时间。

最后我们在表单的 OnResize 中添加了这样的方法，运行应用程序并最大化表单（1280x1024）。

XE2 的结果真的很慢。花了大约11秒。此外，由于面板在应用程序准备好接收用户输入之前完成，因此会有大约 10 秒的额外延迟（如冻结）。总共21秒。

XE3 的情况变得最糟糕。对于相同的操作，总共需要 25 秒（14 + 11 冻结）。

有传言称 XE4 将比 XE3 更糟糕。

考虑到完全相同的应用程序，使用 VCL 而不是 FireMonkey 并使用 SpeedButtons 来获得相同的“鼠标悬停效果”，这非常令人恐惧，只需 1.5 秒！所以问题显然存在于一些内部 FireMonkey 引擎问题。

我打开了 QC (#113795) 和 embarcadero 支持的（付费）票，但他们解决不了问题。

我真的不明白他们怎么能忽视这么严重的问题。对于我们的企业来说，它是一个表演者和破坏者。我们不能向我们的客户提供性能如此差的商业软件。早晚我们将被迫迁移到另一个平台（顺便说一句：使用 WPF 的相同代码 Delphi Prism 与 VCL 的代码一样需要 1.5 秒）。

如果有人对如何解决问题或尝试提高此测试性能有任何想法并想提供帮助，我将非常高兴。

先感谢您。

布鲁诺·弗拉蒂尼

该应用程序如下：

unit Performance01Main;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Rtti, System.Classes,
  System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Objects;

const
  cstCellWidth = 45;
  cstCellHeight = 21;

type

  TCell = class(TStyledControl)
  private
    function GetText: String;
    procedure SetText(const Value: String);
    function GetIsFocusCell: Boolean;
  protected
    FSelected: Boolean;
    FMouseOver: Boolean;
    FText: TText;
    FValue: String;
    procedure ApplyStyle; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure DoMouseEnter; override;
    procedure DoMouseLeave; override;
    procedure ApplyTrigger(TriggerName: string);
  published
    property IsSelected: Boolean read FSelected;
    property IsFocusCell: Boolean read GetIsFocusCell;
    property IsMouseOver: Boolean read FMouseOver;
    property Text: String read GetText write SetText;
  end;

  TFormFireMonkey = class(TForm)
    StyleBook: TStyleBook;
    BottomPanel: TPanel;
    AniIndicator: TAniIndicator;
    ProgressBar: TProgressBar;
    CellPanel: TPanel;
    procedure FormResize(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  protected
    FFocused: TCell;
    FEntered: Boolean;
  public
    procedure CreateCells;
  end;

var
  FormFireMonkey: TFormFireMonkey;

implementation

uses
  System.Diagnostics;

{$R *.fmx}

{ TCell }

procedure TCell.ApplyStyle;
begin
  inherited;
  ApplyTrigger('IsMouseOver');
  ApplyTrigger('IsFocusCell');
  ApplyTrigger('IsSelected');
  FText:= (FindStyleResource('Text') as TText);
  if (FText <> Nil) then
    FText.Text := FValue;
end;

procedure TCell.ApplyTrigger(TriggerName: string);
begin
  StartTriggerAnimation(Self, TriggerName);
  ApplyTriggerEffect(Self, TriggerName);
end;

procedure TCell.DoMouseEnter;
begin
  inherited;
  FMouseOver:= True;
  ApplyTrigger('IsMouseOver');
end;

procedure TCell.DoMouseLeave;
begin
  inherited;
  FMouseOver:= False;
  ApplyTrigger('IsMouseOver');
end;

function TCell.GetIsFocusCell: Boolean;
begin
  Result:= (Self = FormFireMonkey.FFocused);
end;

function TCell.GetText: String;
begin
  Result:= FValue;
end;

procedure TCell.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
var
  OldFocused: TCell;
begin
  inherited;
  FSelected:= not(FSelected);
  OldFocused:= FormFireMonkey.FFocused;
  FormFireMonkey.FFocused:= Self;
  ApplyTrigger('IsFocusCell');
  ApplyTrigger('IsSelected');
  if (OldFocused <> Nil) then
    OldFocused.ApplyTrigger('IsFocusCell');
end;

procedure TCell.SetText(const Value: String);
begin
  FValue := Value;
  if Assigned(FText) then
    FText.Text:= Value;
end;

{ TForm1 }

procedure TFormFireMonkey.CreateCells;
var
  X, Y: Double;
  Row, Col: Integer;
  Cell: TCell;
  T: TTime;
  // Workaround suggested by Himself 1
  // Force update only after a certain amount of iterations
  // LP: Single;

  // Workaround suggested by Himself 2
  // Force update only after a certain amount of milliseconds
  // Used cross-platform TStopwatch as suggested by LU RD
  // Anyway the same logic was tested with TTime and GetTickCount
  // SW: TStopWatch;

begin
  T:= Time;
  Caption:= 'Creating cells...';

  {$REGION 'Issue 2 workaround: Update form size and background'}
  // Bruno Fratini:
  // Without (all) this code the form background and area is not updated till the
  // cells calculation is finished
  BeginUpdate;
  Invalidate;
  EndUpdate;
  // Workaround suggested by Philnext
  // replacing ProcessMessages with HandleMessage
  // Application.HandleMessage;
  Application.ProcessMessages;
  {$ENDREGION}

  // Bruno Fratini:
  // Update starting point step 1
  // Improving performance
  CellPanel.BeginUpdate;

  // Bruno Fratini:
  // Freeing the previous cells (if any)
  while (CellPanel.ControlsCount > 0) do
    CellPanel.Controls[0].Free;

  // Bruno Fratini:
  // Calculating how many rows and columns can contain the CellPanel
  Col:= Trunc(CellPanel.Width / cstCellWidth);
  if (Frac(CellPanel.Width / cstCellWidth) > 0) then
    Col:= Col + 1;
  Row:= Trunc(CellPanel.Height / cstCellHeight);
  if (Frac(CellPanel.Height / cstCellHeight) > 0) then
    Row:= Row + 1;

  // Bruno Fratini:
  // Loop variables initialization
  ProgressBar.Value:= 0;
  ProgressBar.Max:= Row * Col;
  AniIndicator.Enabled:= True;
  X:= 0;
  Col:= 0;

  // Workaround suggested by Himself 2
  // Force update only after a certain amount of milliseconds
  // Used cross-platform TStopwatch as suggested by LU RD
  // Anyway the same logic was tested with TTime and GetTickCount
  // SW:= TStopwatch.StartNew;

  // Workaround suggested by Himself 1
  // Force update only after a certain amount of iterations
  // LP:= 0;

  // Bruno Fratini:
  // Loop for fulfill the Width
  while (X < CellPanel.Width) do
  begin
    Y:= 0;
    Row:= 0;
    // Bruno Fratini:
    // Loop for fulfill the Height
    while (Y < CellPanel.Height) do
    begin
      // Bruno Fratini:
      // Cell creation and bounding into the CellPanel
      Cell:= TCell.Create(CellPanel);
      Cell.Position.X:= X;
      Cell.Position.Y:= Y;
      Cell.Width:= cstCellWidth;
      Cell.Height:= cstCellHeight;
      Cell.Parent:= CellPanel;

      // Bruno Fratini:
      // Assigning the style that gives something like Windows 7 effect
      // on mouse move into the cell
      Cell.StyleLookup:= 'CellStyle';

      // Bruno Fratini:
      // Updating loop variables and visual controls for feedback
      Y:= Y + cstCellHeight;
      Row:= Row + 1;
      ProgressBar.Value:= ProgressBar.Value + 1;
      // Workaround suggested by Himself 1
      // Force update only after a certain amount of iterations
      // if ((ProgressBar.Value - LP) >= 100) then

      // Workaround suggested by Himself 2
      // Force update only after a certain amount of milliseconds
      // Used cross-platform TStopwatch as suggested by LU RD
      // Anyway the same logic was tested with TTime and GetTickCount
      // if (SW.ElapsedMilliseconds >= 30) then

      // Workaround suggested by Philnext with Bruno Fratini's enhanchment
      // Skip forcing refresh when the form is not focused for the first time
      // This avoid the strange side effect of overlong delay on form open
      // if FEntered then
      begin
        Caption:= 'Elapsed time: ' + FormatDateTime('nn:ss:zzz', Time - T) +
                  ' (min:sec:msec) Cells: ' + IntToStr(Trunc(ProgressBar.Value));

        {$REGION 'Issue 4 workaround: Forcing progress and animation visual update'}
        // Bruno Fratini:
        // Without the ProcessMessages call both the ProgressBar and the
        // Animation controls are not updated so no feedback to the user is given
        // that is not acceptable. By the other side this introduces a further
        // huge delay on filling the grid to a not acceptable extent
        // (around 20 minutes on our machines between form maximization starts and
        // it arrives to a ready state)

        // Workaround suggested by Philnext
        // replacing ProcessMessages with HandleMessage
        // Application.HandleMessage;
        Application.ProcessMessages;
        {$ENDREGION}

        // Workaround suggested by Himself 1
        // Force update only after a certain amount of iterations
        // LP:= ProgressBar.Value;

        // Workaround suggested by Himself 2
        // Force update only after a certain amount of milliseconds
        // Used cross-platform TStopwatch as suggested by LU RD
        // Anyway the same logic was tested with TTime and GetTickCount
        // SW.Reset;
        // SW.Start;
      end;
    end;
    X:= X + cstCellWidth;
    Col:= Col + 1;
  end;

  // Bruno Fratini:
  // Update starting point step 2
  // Improving performance
  CellPanel.EndUpdate;

  AniIndicator.Enabled:= False;
  ProgressBar.Value:= ProgressBar.Max;
  Caption:= 'Elapsed time: ' + FormatDateTime('nn:ss:zzz', Time - T) +
            ' (min:sec:msec) Cells: ' + IntToStr(Trunc(ProgressBar.Value));

  // Bruno Fratini:
  // The following lines are required
  // otherwise the cells won't be properly paint after maximizing
  BeginUpdate;
  Invalidate;
  EndUpdate;
  // Workaround suggested by Philnext
  // replacing ProcessMessages with HandleMessage
  // Application.HandleMessage;
  Application.ProcessMessages;
end;

procedure TFormFireMonkey.FormActivate(Sender: TObject);
begin
  // Workaround suggested by Philnext with Bruno Fratini's enhanchment
  // Skip forcing refresh when the form is not focused for the first time
  // This avoid the strange side effect of overlong delay on form open
  FEntered:= True;
end;

procedure TFormFireMonkey.FormResize(Sender: TObject);
begin
  CreateCells;
end;

end.

score 28 · Accepted Answer

我尝试了您的代码，在 XE3 上的 PC 上需要 00:10:439 才能用单元格填充屏幕。通过禁用这些行：

  //ProgressBar.Value:= ProgressBar.Value + 1;
  //Caption:= 'Elapsed time: ' + FormatDateTime('nn:ss:zzz', Time - T) +
  //          ' (min:sec:msec) Cells: ' + IntToStr(Trunc(ProgressBar.Value));
  ...
  //Application.ProcessMessages;

这下降到 00:00:106 (!)。

更新视觉控件（例如 ProgressBar 或 Form.Caption）非常昂贵。如果您真的认为您需要这样做，请仅每 100 次迭代执行一次，或者更好的是，仅每 250 个处理器周期执行一次。

如果这对性能没有帮助，请在禁用这些行的情况下运行您的代码并更新问题。

此外，我添加了代码来测试重绘时间：

T:= Time;
// Bruno Fratini:
// The following lines are required
// otherwise the cells won't be properly paint after maximizing
//BeginUpdate;
Invalidate;
//EndUpdate;
Application.ProcessMessages;
Caption := Caption + ', Repaint time: '+FormatDateTime('nn:ss:zzz', Time - T);

第一次运行时，创建所有控件需要 00:00:072，重绘需要 00:03:089。所以不是对象管理而是第一次重绘很慢。

第二次重绘要快得多。

由于评论中有讨论，以下是您如何进行进度更新：

var LastUpdateTime: cardinal;
begin
  LastUpdateTime := GetTickCount - 250;
  for i := 0 to WorkCount-1 do begin
    //...
    //Do a part of work here

    if GetTickCount-LastUpdateTime > 250 then begin
      ProgressBar.Position := i;
      Caption := IntToStr(i) + ' items done.';
      LastUpdateTime := GetTickCount;
      Application.ProcessMessages; //not always needed
    end;
  end;
end;

score 5 · Accepted Answer

我只有 XE2 并且代码并不完全相同，但是正如其他一些人所说的那样，pb 似乎在

Application.ProcessMessages；

线。所以我建议用 realign ex 来“刷新”你的组件：

  ProgressBar.Value:= ProgressBar.Value + 1;
  Caption:= 'Elapsed time: ' + FormatDateTime('nn:ss:zzz', Time - T) +
            ' (min:sec:msec) Cells: ' + IntToStr(Trunc(ProgressBar.Value));

  // in comment : Application.ProcessMessages;
  // New lines : realign for all the components needed to be refreshes
  AniIndicator.Realign;
  ProgressBar.Realign;

在我的 PC 上，使用原始代码在 0.150 秒而不是 3.7 秒内生成 210 个单元格屏幕，以便在您的环境中进行测试...

score 4 · Accepted Answer

你为什么要测试

“重绘”、“InvalidateRect”、“Scene.EndUpdate”

我可以从您的代码中看到，最昂贵的操作是重新创建控件。你为什么要在 OnResize 事件中这样做（也许放一些按钮来重新创建控件）

仅此循环就可以占用 30% 的执行时间

  while (CellPanel.ControlsCount > 0) do
    CellPanel.Controls[0].Free;

它应该是这样的：（避免在每次空闲后复制列表内存）

for i := CellPanel.ControlsCount - 1 downto 0 do
   CellPanel.Controls[i].Free;

并且不要在循环中运行 ProcessMessages（或者至少在每 10 次迭代左右运行一次）

使用 AQTime 来分析你的代码（它会显示什么是这么长的）

performance - 当屏幕上有很多控件时出现严重的 FireMonkey 性能问题

3 回答 3

Related

Reference