Serious FireMonkey performance issues when there are a lot of controls at screen

Question

It's already a while we are working with FireMonkey at office. After a while we noticed it wasn't exactly so lightning fast due to GPU acceleration as Embarcadero tells us.

So we built a basic application just for testing FireMonkey performance. Basically it's a form with a panel on the bottom (alBottom) that works as status bar and an all client (alClient) Panel. The panel on the bottom has a progressbar and an animation.

We added a method to the form that frees whatever control is present in the all client panel and fulfil it with cells of a custom type and a "mouse over" style and update the animation, the progress bar and the form's caption with info about the fulfilling progress. The most important info is the required time.

Finally we added such method to the OnResize of the form, run the application and maximized the form (1280x1024).

The result with XE2 was really slow. It took around 11 seconds. In addition since the panel is fulfilled till the application is ready to receive user input there is an additional delay of about 10 seconds (like freezing). For an overall of 21 seconds.

With XE3 the situation got worst. For the same operation it took an overall of 25 seconds (14 + 11 freezing).

And rumours tell XE4 is going to be a lot worst of XE3.

This is quite scaring considering exactly the same application, using VCL instead of FireMonkey and using SpeedButtons in order to have the same "mouse over effect" takes just 1.5 seconds!!! So the problem clearly reside in some internal FireMonkey engine problem(s).

I opened a QC (#113795) and a (paid) ticket to embarcadero support but nothing they won't solve it.

I seriously don't understand how they can ignore such heavy issue. For our enterprise is being a show-stopper and a deal breaker. We cannot offer commercial software to our customer with such poor performance. Earlier or later we will be forced to move to another platform (BTW: the same code Delphi Prism with WPF takes 1.5 seconds as the VCL one).

If anybody has any idea about how to solve the issue or try to improve this test performance and want to help I would be really glad of it.

Thank you in advance.

Bruno Fratini

The application is the following one:

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

I tried your code, it takes 00:10:439 on my PC on XE3 to fill screen with cells. By disabling these lines:

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

This goes down to 00:00:106 (!).

Updating visual controls (such as ProgressBar or Form.Caption) is very expensive. If you really think you need that, do that only every 100-th iteration, or better, only every 250 processor ticks.

If that does not help with performance, please run your code with these lines disabled and update the question.

Further, I've added code to test the repainting time:

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);

When run for a first time, creating all the controls takes 00:00:072, repainting takes 00:03:089. So it's not the object management but the first time repainting which is slow.

Second time repainting is considerably faster.

Since there's a discussion in comments, here's how you do progress updates:

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;

Answer 2

I only have XE2 and the code is not exactlly the same but, as said by some other guys the pb seems to be on the

Application.ProcessMessages;

line. So I sugess to 'refresh' your components with 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;

On my PC, a 210 Cells screen is generated in 0.150 s instead of 3.7 s with the original code, to be tested in your environnement...

Answer 3

Why are you testing

"Repaint", "InvalidateRect", "Scene.EndUpdate"

I can see from your code that most expensive operation is recreating controls. And why are you doing it in OnResize event (maybe put some button for recreating controls)

this loop alone can eat like 30% of execution time

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

it should be like: (avoid list memory copy after each free)

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

and don't run ProcessMessages in loop (or at least run only in every 10th iteration or so)

use AQTime to profile your code (it will show what is tacking that long)