MakeScreenshot leaking?

Question

Good evening all!

In a current project, i'm experiencing a rather worrying memory leak that i just can't seem to plug.

I left the application running overnight with standard usage going on and when i awoke 8 hours later, it was eating up ~750MB memory whereas it started at ~50MB. Windows Task Manager isn't suited for checking for leaks other than allowing you to find out that one exists in the first place.

I cleared up a few other memory leaks already, with the major one being related to Firemonkeys' TGlowEffect. It isn't detected by ReportLeaksOnShutdown but the memory usage of it becomes extremely excessive on dynamically modified object (e.g. rotation or scale changes).

I've tracked it down to a timer (and disabling it stops the leak completely), and i require assistance in fixing it if possible.

Description: This code uses the Firemonkey MakeScreenshot function to save the visual appearance of a TPanel (SigPanel) to a TMemoryStream. This stream data is then uploaded to a remote FTP server using standard code (see below). Inside SigPanel, there are 4 TLabel children, 1 TRectangle child, and 6 TImage children.

Notes: CfId is a global string and is generated based upon a random extended float value that is then hashed along with the DateTime in format yyyymmdd_hhnnsszzz. This generation is done when the form is created, and it repeats until it get's a valid CfId (i.e. doesn't contain characters illegal for use in Windows filenames). Once it gets a valid CfId, it doesn't run again at all (as there's no further need for me to generate a new ID). This allows me to almost completely eliminate the chance of duplicate CfId.

The code in the timer is as follows;

var
  i : Integer;
  SigStream : TMemoryStream;
begin
  SigStream := TMemoryStream.Create;
  SigPanel.MakeScreenshot.SaveToStream(SigStream);
  SigPanel.MakeScreenshot.Free;
  if VT2SigUp.Connected then
  begin
    VT2SigUp.Put(SigStream,'Sig_'+CfId+'.png',False);
  end else
  begin
    VT2SigUp.Connect;
    VT2SigUp.Put(SigStream,'Sig_'+CfId+'.png',False);
  end;
    SigStream.Free;
end;

With the timer NOT running, the code functions completely without leaks and ReportMemoryLeaksOnShutdown does NOT generate a message. With the timer enabled and being allowed to "run" at least once, i'm getting a lot of leakage which increases the more times the timer runs. The reported leaks are as follows;

Small Block Leaks

1 - 12 Bytes: Unknown x 1
13 - 20 Bytes: TList x 5, Unknown x 1
21 - 28 Bytes: TFont x 2, TGradientPoint x 8, TGradientPoints x 4, Unknown x 4
29 - 36 Bytes: TObjectList<FMX.Types.TCanvasSaveState> x 1, TBrushBitmap x 4,
TBrushGrab x 4, TPosition x 24, TGradient x 4, UnicodeString x1
37 - 44 Bytes: TBrushResource x 4
53 - 60 Bytes: TBrush x 4
61 - 68 Bytes: TBitmap x 5
69 - 76 Bytes: TD2DCanvasSaveState x 1
205 - 220 Bytes: TCanvasD2D x 1

Sizes of Medium and Large Block Leaks
200236

As the timer runs, these values are multiplied n times (n being the number of times the timer has run). The medium and large blocks have n worth of 200236 (e.g. if the timer has run 3 times, it's 200236, 200236, 200326).

Of Interest, if i remove the code associated with MakeScreenshot, the leak no longer exists, and memory usage remains at a somewhat normal level. Beside the usual memory usage, there's nothing out of the ordinary and no leaks are reported. I've tried multiple samples of code, both with saving to a stream and uploading from there, or saving to stream > File and then uploading the file, but there appears to be a leak within the function itself. I even added MakeScreenshot.Free once i discovered a leak here, but i simply can't seem to plug it, and of course, i've used try..finally in one of my code "test runs".

I've even run the code with GDI+ as the canvas type and the same leak occurs there (with the only change being that the D2D leaks reference GDI+ instead).

I'd very much appreciate any research or notes anyone has on this, and moreover, a solution to the issue.

Answer 1

You are not freeing the bitmap that MakeScreenshot creates.

procedure TForm1.Button1Click(Sender: TObject);
var
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  Panel1.MakeScreenshot.SaveToStream(ms);
  ms.Free;
end;

The above code does not keep a reference to the created bitmap, hence has no chance to free it. Instead change your design like the below:

procedure TForm1.Button2Click(Sender: TObject);
var
  ms: TMemoryStream;
  bmp: TBitmap;
begin
  ms := TMemoryStream.Create;
  bmp := Panel1.MakeScreenshot;
  bmp.SaveToStream(ms);
  ms.Free;
  bmp.Free;
end;

With the below code you're in fact creating two bitmaps and freeing one of them.

  SigPanel.MakeScreenshot.SaveToStream(SigStream);
  SigPanel.MakeScreenshot.Free;

In the end, your code would be more like the below:

var
  i : Integer;
  Bmp: TBitmap;
  SigStream : TMemoryStream;
begin
  SigStream := TMemoryStream.Create;
  try
    Bmp := SigPanel.MakeScreenshot;
    try
      Bmp.SaveToStream(SigStream);
      if not VT2SigUp.Connected then
        VT2SigUp.Connect;
      VT2SigUp.Put(SigStream, 'Sig_'+CfId+'.png', False);
    finally
      Bmp.Free;
    end;
  finally
    SigStream.Free;
  end;
end;

Answer 2

I tried using it in fmx, but it didn't work so I took a similar function from FMXexpress, which was also memory leaked and modified it.

I transformed the function into a procedure where you pass 2 parameters. The first is an object where you want the makescreen and the second the target object. At the end it clears the memory.

class Procedure MakeScaleScreenshot(Sender: TControl; SetImg: TImage);

Class Procedure MakeScaleScreenshot(Sender: TControl; SetImg: TImage);
var
  fScreenScale: Single;
  Result:TBitmap;
function GetScreenScale: Single;
  var
    ScreenService: IFMXScreenService;
  begin
    Result := 1;
    if TPlatformServices.Current.SupportsPlatformService(IFMXScreenService,
      IInterface(ScreenService)) then
    begin
      Result := ScreenService.GetScreenScale;
    end;
  end;

begin    
  fScreenScale := GetScreenScale;
  Result := TBitmap.Create(Round(Sender.Width * fScreenScale), Round(Sender.Height * fScreenScale));
  Result.Clear(0);

  if Result.Canvas.BeginScene then
  try
    Sender.PaintTo(Result.Canvas, RectF(0, 0, Result.Width, Result.Height));
  finally
    Result.Canvas.EndScene;
    SetImg.Bitmap:=Result;
  end;

 Result.FreeHandle;
 Result.DisposeOf;

end;

//how to use

Procedure
Begin
  {TControl source screen}, {Img destiny of the TImage type}
  MakeScaleScreenshot(Image1,Image2);
end;