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 引擎的某些内部问题。

我向 embarcadero 支持开了一份 QC (#113795) 和一张(付费)票，但他们没有解决任何问题。

我真的不明白他们怎么能忽视这么严重的问题。因为我们的企业正在成为一个搅局者和破坏者。我们无法向客户提供性能如此差的商业软件。迟早我们将被迫迁移到另一个平台(顺便说一句:使用 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.

Answer 1

我尝试了你的代码，在我的 XE3 电脑上需要 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;