Why is GDI + over-consuming memory when working with fonts in Windows 10?

Question

My application shows VERY different and VERY annoying memory traces when observed in Windows 7/8 / 8.1 compared to Windows 10. I attached this to the use of fonts:

Instead of using 50-70 MB to list installed fonts and their attributes (as the Windows 7/8 / 8.1 application does), this task requires about 500 MB, which is about ten times more.

Speaking of the required memory, I always refer to the virtual size of the process.

Any idea why this is happening? Looks like some caches that sprawled in Windows 10. Any good workarounds? I am currently planning to map all GDI + font handling calls to GDI calls, as they do not show this strange behavior.

(I discovered a .NET FontFamily memory leak in Windows 10 , but there is no useful answer.)

To narrow it down, I created two sample programs. You can run programs and compare VirtualSize processes yourself.

C # sample, which simply lists all installed fonts and creates a font instance when properly disposing of unmanaged objects:

int i = 0;
foreach (FontFamily fontfamily in FontFamily.Families)
{
    i++;
    try
    {
        Font f = new Font(fontfamily, (float) 8.0, FontStyle.Bold);
        Console.WriteLine("Created Font #{0} {1} ", i, f.Name);

        f.Dispose();
        f = null;
    }
    catch (Exception ex)
    {
        Console.WriteLine("Exception while creating Font {0} {1}", fontfamily.Name, ex.ToString());
    }
    fontfamily.Dispose();
}

Delphi, .NET . , .

program FontTests01;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  Classes,
  Windows,
  System.SysUtils,
  IOUtils,
  WinApi.GDIPAPI,
  WinApi.GDIPOBJ;

const
  cFontlistFilename = 'C:\Temp\fontlist.dat';

type
  TTestCallback = procedure;

function ConsoleWaitForKey: Char;
var
  s: string;
begin
  Readln(s);
  if Length(s) > 0 then
    Result := s[1]
  else
    Result := #0;
end;

procedure TestFontEnumeration(GetFontname: Boolean; GetAvailability: Boolean; FontNamesListFilename: string);
var
  FontCollection: TGPFontCollection;
  FontFamilies: array of TGPFontFamily;
  FontFamily: TGPFontFamily;
  FontName: string;
  i, FontFamiliesRetrieved: Integer;
begin
  if (FontNamesListFilename <> '') and (FileExists(FontNamesListFilename)) then
    DeleteFile(FontNamesListFilename);

  FontCollection := TGPInstalledFontCollection.Create;
  try
    SetLength(FontFamilies, FontCollection.GetFamilyCount);
    ZeroMemory(@FontFamilies[0], SizeOf(TGPFontFamily) * Length(FontFamilies));
    try
      for i := 0 to Length(FontFamilies) - 1 do
        FontFamilies[i] := TGPFontFamily.Create;

      FontCollection.GetFamilies(Length(FontFamilies), FontFamilies, FontFamiliesRetrieved);
      for i := 0 to FontFamiliesRetrieved - 1 do
      begin
        FontFamily := FontFamilies[i];
        if GetFontname then
        begin
          FontFamily.GetFamilyName(FontName);
          Write('Retrieved Font: ' + FontName + ' ');
          if FontNamesListFilename <> '' then
            TFile.AppendAllText(FontNamesListFilename, FontName + #13#10);
        end
        else
          Write(IntToStr(i) + ' ');
        if GetAvailability then
        begin
          if FontFamily.IsAvailable and FontFamily.IsStyleAvailable(FontStyleRegular) then
            Writeln('available ')
          else
            Writeln('NOT available');
        end
        else
          Writeln;
      end;
    finally
      for i := 0 to Length(FontFamilies) - 1 do
        FontFamilies[i].Free;
    end;
  finally
    FontCollection.Free;
  end;
end;

procedure TestFontInstantiation(GetName: Boolean; GetAvailability: Boolean; FontNamesListFilename: string);
var
  List: TStringList;
  FontFamily: TGPFontFamily;
  FontName: string;
  i: Integer;
begin
  List := TStringList.Create;
  try
    List.LoadFromFile(FontNamesListFilename);
    for I := 0 to List.Count - 1 do
    begin
      FontFamily := TGPFontFamily.Create(List[i]);
      try
        if GetName then
        begin
          FontFamily.GetFamilyName(FontName);
          Write('Retrieved Font: ' + FontName + ' ');
        end
        else
          Write(IntToStr(i) + ' ');
        if GetAvailability then
        begin
          if FontFamily.IsAvailable and FontFamily.IsStyleAvailable(FontStyleRegular) then
            Writeln('available ')
          else
            Writeln('NOT available');
        end
        else
          Writeln;
      finally
        FontFamily.Free;
      end;
    end;
  finally
    List.Free;
  end;
end;

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; stdcall;
begin
  Writeln(LogFont.lfFaceName);
  Result := 1;
end;

procedure EnumerateFontsWithGDI;
var
  DC: HDC;
  LFont: TLogFont;
begin
  DC := GetDC(0);
  try
    FillChar(LFont, sizeof(LFont), 0);
    LFont.lfCharset := DEFAULT_CHARSET;
    EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, 0, 0);
  finally
    ReleaseDC(0, DC);
  end;
end;

procedure TestFontEnumeration_GetFontNames_Only;
begin
  TestFontEnumeration(True, False, cFontlistFilename);
end;

procedure TestFontEnumeration_GetFontAvailability_Only;
begin
  TestFontEnumeration(False, True, '');
end;

procedure TestFontEnumeration_GetFontName_GetFontAvailability_Combined;
begin
  TestFontEnumeration(True, True, '');
end;

procedure TestFontNames_FromFile_CreateNamedGPFontFamilies_Only;
begin
  TestFontInstantiation(False, False, cFontlistFilename);
end;

procedure TestFontNames_FromFile_RetrieveFontNamesAgain;
begin
  TestFontInstantiation(True, False, cFontlistFilename);
end;

procedure TestFontNames_FromFile_GetFontAvailable;
begin
  TestFontInstantiation(False, True, cFontlistFilename);
end;

procedure TestFontNames_FromFile_RetrieveFontNames_GetFontAvailable_Combined;
begin
  TestFontInstantiation(True, True, cFontlistFilename);
end;

procedure Test_EnumerateFontsWithGDI;
begin
  EnumerateFontsWithGDI;
end;

procedure PerformTest(Caption: string; Callback: TTestCallback);
var
  Key: Char;
begin
  Writeln('Before Test ' + Caption + '. Hit "s" to skip, enter to continue.');
  Key := ConsoleWaitForKey;
  if AnsiLowerCase(Key) <> 's' then
  begin
    Callback;
    Writeln('Test ' +  Caption + ' finished. Hit a enter.');
    ConsoleWaitForKey;
  end
  else
    Writeln('Test ' +  Caption + ' skipped.');
  Writeln;
end;

begin
  try
    PerformTest('TestFontEnumeration_GetFontNames_Only', TestFontEnumeration_GetFontNames_Only);
    PerformTest('TestFontEnumeration_GetFontAvailability_Only', TestFontEnumeration_GetFontAvailability_Only);
    PerformTest('TestFontEnumeration_GetFontName_GetFontAvailability_Combined', TestFontEnumeration_GetFontName_GetFontAvailability_Combined);
    PerformTest('TestFontNames_FromFile_CreateNamedGPFontFamilies_Only', TestFontNames_FromFile_CreateNamedGPFontFamilies_Only);
    PerformTest('TestFontNames_FromFile_RetrieveFontNamesAgain', TestFontNames_FromFile_RetrieveFontNamesAgain);
    PerformTest('TestFontNames_FromFile_GetFontAvailable', TestFontNames_FromFile_GetFontAvailable);
    PerformTest('TestFontNames_FromFile_RetrieveFontNames_GetFontAvailable_Combined', TestFontNames_FromFile_RetrieveFontNames_GetFontAvailable_Combined);
    PerformTest('Test_EnumerateFontsWithGDI', Test_EnumerateFontsWithGDI);
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Writeln('Finished.');
  ConsoleWaitForKey;
end.