Delphi Win64: memory is growing without leaks when using TThread.Synchronize() - delphi

Question

I am facing an issue within the life application that memory (shown in Task Manager, or in GetProcessMemoryInfo -> PagefileUsage) is constantly growing while there is no any leaks reported by FastMM4.
Trying to narrow the issue, I did my best to create the smallest possible test case, but it still came out too big.
However, I am still posting it here because it's the only way I found to show the issue.
So, what this test does:
Checks occupied memory on startup reported by GetMemoryManagerState() and by GetProcessMemoryInfo().
Creates 10k threads, which allocate some memory.
After all 10k threads are terminated, all allocated memory is freed.
I double checked many times with Eurekalog and FastMM in full debug mode that all created objects do not leak.
Until the Stop button is hit, the process continues to Step 2.
So, despite that I'm sure that all objects are being released, occupied memory after the first run has increased dramatically by almost 170MB.
Digging more into System.SysUtils, I found out that a bit of memory is used for EventCache (which is not cleared automatically after all threads are done), however that doesn't explain 170MB for me (10k thread syncs spawns about 9k PEventItemHolder).
What is even more strange is that, on each next step, occupied memory continues to grow! Despite on each step, the application state should be completely the same (no more objects allocated, no more EventCache spawned).
Application log looks like this:
Before: Mem: Used 67 kb UsedOS: 4 MB
After: Mem: Used 323 kb UsedOS: 170 MB
After: Mem: Used 323 kb UsedOS: 178 MB
After: Mem: Used 323 kb UsedOS: 181 MB
After: Mem: Used 323 kb UsedOS: 176 MB
After: Mem: Used 323 kb UsedOS: 182 MB
After: Mem: Used 323 kb UsedOS: 178 MB
After: Mem: Used 323 kb UsedOS: 206 MB
Why is this happening? Are there any tools to help dig more into the issue, especially in the life application, which is very heavy?
The code:
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Generics.Collections, Generics.Defaults,
Math, psAPI, REST.Client,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls;
const
ThreadsCount = 10000;
type
TForm12 = class(TForm)
MemLabel: TLabel;
MemTimer: TTimer;
bStart: TButton;
bStop: TButton;
Memo1: TMemo;
procedure MemTimerTimer(Sender: TObject);
procedure bStartClick(Sender: TObject);
procedure bStopClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
procedure UpdateMemInfo;
public
procedure LogNextStep;
{ Public declarations }
end;
TOrder = packed record
sx: string[10];
Time: TDateTime;
x,y,z: double;
end;
POrder = ^TOrder;
TTestThread = class(TThread)
WaitFlag: boolean;
public
Num: integer;
ptr: POrder;
R: TRestRequest;
Name: string;
data: array [1..50] of double;
procedure Execute; override;
end;
var
Form12: TForm12;
implementation
{$R *.dfm}
var
GlobalUsedMem, GlobalUsedOSMem, AddedCount: integer; // MB
ThCount, ThGlobalID: integer;
JobDone, TestStopRequest: boolean;
ThList: TList<TTestThread>;
OrderList: TList<POrder>;
procedure CreateNewThread;
begin
TTestThread.Create(false);
end;
procedure CreateNewTest;
begin
TThread.CreateAnonymousThread(
procedure
var
k: integer;
begin
sleep(3000);
for k := 1 to ThreadsCount do
CreateNewThread;
end).Start;
end;
procedure CLeanOrders;
var
o: POrder;
begin
for o in OrderList do FreeMem(o);
OrderList.CLear;
end;
procedure TForm12.bStartClick(Sender: TObject);
begin
UpdateMemInfo;
Memo1.Clear;
Memo1.Lines.Add('Before: ' + MemLabel.Caption);
ThGlobalID := 0;
TestStopRequest := false;
JobDone := false;
AddedCount := 0;
CreateNewTest;
end;
procedure TForm12.bStopClick(Sender: TObject);
begin
TestStopRequest := true;
end;
procedure TForm12.FormClose(Sender: TObject; var Action: TCloseAction);
begin
TestStopRequest := true;
repeat
Application.ProcessMessages;
sleep(10);
until JobDOne;
ThList.Free;
OrderList.Free;
end;
procedure TForm12.FormCreate(Sender: TObject);
begin
JobDone := true;
ThList := TList<TTestThread>.Create;
OrderList := TList<POrder>.Create;
end;
procedure TForm12.LogNextStep;
begin
UpdateMemInfo;
Memo1.Lines.Add('After: ' + MemLabel.Caption);
end;
procedure TForm12.UpdateMemInfo;
var
m4: UInt64;
mx: integer;
st: TMemoryManagerState;
sb: TSmallBlockTypeState;
MemCounters: TProcessMemoryCounters;
begin
MemCounters.cb := SizeOf(MemCounters);
if GetProcessMemoryInfo(GetCurrentProcess, #MemCounters, SizeOf(MemCounters))
then GlobalUsedOSMem := round(MemCounters.PagefileUsage / 1000000);;
GetMemoryManagerState(st);
m4 := st.TotalAllocatedMediumBlockSize + st.TotalAllocatedLargeBlockSize;
for sb in st.SmallBlockTypeStates do begin
m4 := m4 + sb.UseableBlockSize * sb.AllocatedBlockCount;
end;
GlobalUsedMem := round(m4 / 1000);
MemLabel.Caption := Format(' Mem: Used %d kb UsedOS: %d MB O: %d Th: %d ',
[ GlobalUsedMem, GlobalUsedOSMem, OrderList.Count, ThCount ]);
end;
procedure TForm12.MemTimerTimer(Sender: TObject);
begin
UpdateMemInfo;
end;
procedure SyncProc(o: TTestThread);
begin
OrderList.Add(o.ptr);
o.R := TRestRequest.Create(nil);
o.Name := 'Test Thread ' + o.Num.toString;
ThList.Add(o);
inc(AddedCount);
end;
procedure SyncDel(o: TTestThread);
var
k: integer;
s: string;
begin
dec(AddedCount);
ThList.remove(o);
FreeAndNil(o.R);
If AddedCount = 0 then begin
ThGlobalID := 0;
thList.Clear;
CLeanOrders;
Form12.LogNextStep;
If not TestStopRequest then
CreateNewTest;
end;
If (not TestStopRequest) and (random(5) = 1) and (ThCount > 1000) then CreateNewThread;
end;
{ TTestThread }
procedure TTestThread.Execute;
var
k: integer;
pLarge, pSmall, pMed: pointer;
tm1: Uint64;
workingTime: integer;
const
IterCount = 50;
begin
WaitFlag := false;
AtomicIncrement(ThCount);
Num := AtomicIncrement(ThGlobalID) - 1;
sleep(random(500));
GetMem(pLarge, 100500);
GetMem(pMed, 25000);
GetMem(pSmall, 800);
FreeMem(pLarge);
New(ptr);
ptr.Time := Now;
Synchronize( procedure begin SyncProc(self); end );
FreeMem(pMed);
FreeMem(pSmall);
workingTime := 3000 + random (2000);
tm1 := GetTickCount64;
repeat
Sleep(100);
until TestStopRequest or (abs(GetTickCount64 - tm1) > workingTime);
sleep(random(1000));
k := AtomicDecrement(ThCount);
JobDone := (k=0);
FreeOnTerminate := true;
Synchronize( procedure begin SyncDel(self); end );
end;
end.