mm: retain repeatedly reused small-block pools

Author: Moonbot-Tech

qualification/suite/scripts/mm/qualify_current_mm.sh

@@ -95,6 +95,8 @@ compile_test standalone small-finalize memory_small_last_free_finalize.dpr \
 compile_test product small-pool-leak-report memory_small_pool_last_free_finalize.dpr \
   -dFPCMM_REPORTMEMORYLEAKS -dFPCMM_MEDIUMLASTFREE_TEST
 compile_test product memory-large-boundary memory_large_boundary.dpr
+compile_test product memory-hot-small-pool memory_hot_small_pool.dpr \
+  -dFPCMM_SMALLPOOL_REUSE_TEST
 compile_test product memory-mega memory_mega.dpr
 compile_test product memory-massive memory_massive.dpr \
   -Fu"$perf_common" -dFPCMM_SMALLLASTFREE_TEST -dFPCMM_MEDIUMLASTFREE_TEST
@@ -127,6 +129,10 @@ run_one memory-large-boundary \
   "$build/memory-large-boundary/memory-large-boundary"
 grep -q 'MEMORY_LARGE_BOUNDARY_PASS' \
   "$results/memory-large-boundary/run.log"
+run_one memory-hot-small-pool \
+  "$build/memory-hot-small-pool/memory-hot-small-pool"
+grep -q 'MEMORY_HOT_SMALL_POOL_PASS' \
+  "$results/memory-hot-small-pool/run.log"
 run_one memory-mega-full "$build/memory-mega/memory-mega" full "$seed"
 grep -q 'MEMORY_MEGA_PASS' "$results/memory-mega-full/run.log"
 run_one memory-massive-quick \

qualification/suite/tests/memory/README.md

@@ -41,6 +41,7 @@ must still report zero failed assertions.
 |---|---|
 | Deferred finalization | `memory_small_pool_last_free_finalize`, `memory_small_last_free_finalize`, and `memory_medium_last_free_finalize` each pass 100 isolated processes with no failed run. |
 | Product boundaries | `memory_large_boundary` checks allocation capacity and first/last-byte access around the large-block transitions. |
+| Hot small-pool reuse | `memory_hot_small_pool` proves that a larger small-block class releases cold empty pools, activates reuse only after repeated churn, and then returns the retained block without changing live-block accounting. |
 | Deterministic breadth | `memory_mega full` checks zero-size and realloc contracts, size classes, every configured realloc transition, pool lifecycle, a shadow-model fuzz pass, cross-thread ownership transfer, and saturation. |
 | Concurrent composition | `memory_massive quick` runs a five-thread ownership pipeline, remote realloc/free, forced `GetMem` contention, both deferred-free lists, and managed-value COW/refcount/unwind. It runs once normally and once with diagnostics enabled. |
 | Randomized composition | `memory_chaos all` mixes raw blocks, RTL-managed values, cross-thread release, realloc, and valid exit-time finalization in release and diagnostic profiles. |

qualification/suite/tests/memory/memory_hot_small_pool.dpr

@@ -0,0 +1,58 @@
+program memory_hot_small_pool;
+
+{$mode delphi}
+{$H+}
+
+uses
+  mormot.core.fpcx64mm;
+
+const
+  ColdFreeCount = 8;
+  TestSize = 1024;
+
+procedure Require(Condition: boolean; const MessageText: string);
+begin
+  if not Condition then
+  begin
+    WriteLn('MEMORY_HOT_SMALL_POOL_FAIL ', MessageText);
+    Halt(1);
+  end;
+end;
+
+var
+  BeforeStatus, AfterStatus: TMMStatus;
+  BlockType: pointer;
+  P, Reused: pointer;
+  I: integer;
+
+begin
+  BeforeStatus := CurrentHeapStatus;
+  BlockType := nil;
+  for I := 1 to ColdFreeCount do
+  begin
+    P := GetMem(TestSize);
+    BlockType := Fpcx64mmTestSmallBlockType(P);
+    FreeMem(P);
+    Require(Fpcx64mmTestSmallEmptyPoolReuseScore(BlockType) = cardinal(I),
+      'cold empty-pool score mismatch');
+    Require(Fpcx64mmTestSmallRetainedPool(BlockType) = nil,
+      'cold size class retained a pool too early');
+  end;
+  P := GetMem(TestSize);
+  BlockType := Fpcx64mmTestSmallBlockType(P);
+  FreeMem(P);
+  Require(Fpcx64mmTestSmallEmptyPoolReuseScore(BlockType) = ColdFreeCount,
+    'hot empty-pool score exceeded its saturation threshold');
+  Require(Fpcx64mmTestSmallRetainedPool(BlockType) <> nil,
+    'hot size class did not retain a reusable pool');
+  Reused := GetMem(TestSize);
+  Require(Reused = P, 'retained hot pool did not return its free block');
+  FreeMem(Reused);
+  AfterStatus := CurrentHeapStatus;
+  Require(AfterStatus.SmallBlocks = BeforeStatus.SmallBlocks,
+    'hot-pool reuse changed the live small-block count');
+  Require(AfterStatus.SmallBlocksSize = BeforeStatus.SmallBlocksSize,
+    'hot-pool reuse changed the live small-byte count');
+  WriteLn('MEMORY_HOT_SMALL_POOL_PASS score=',
+    Fpcx64mmTestSmallEmptyPoolReuseScore(BlockType));
+end.

runtime/mm/mormot.core.fpcx64mm.pas

@@ -343,6 +343,12 @@ function Fpcx64mmTestSmallLastFreeCount(P: pointer): cardinal;
 procedure Fpcx64mmTestCorruptSmallLastFreeHead(P: pointer);
 {$endif FPCMM_SMALLLASTFREE_TEST}
 
+{$ifdef FPCMM_SMALLPOOL_REUSE_TEST}
+function Fpcx64mmTestSmallBlockType(P: pointer): pointer;
+function Fpcx64mmTestSmallEmptyPoolReuseScore(BlockType: pointer): cardinal;
+function Fpcx64mmTestSmallRetainedPool(BlockType: pointer): pointer;
+{$endif FPCMM_SMALLPOOL_REUSE_TEST}
+
 {$ifdef FPCMM_MEDIUMLASTFREE_TEST}
 procedure Fpcx64mmTestLockMedium(P: pointer; Locked: boolean);
 function Fpcx64mmTestMediumLastFree(P: pointer): pointer;
@@ -1075,6 +1081,7 @@ procedure NotifyMediumLargeFree(var Arena: TMMStatusArena; Size: PtrUInt);
   SmallBlockDownsizeCheckAdder = 64;
   SmallBlockUpsizeAdder        = 32;
   SmallBlockTypePO2            = 6;  // SizeOf(TSmallBlockType)=64
+  SmallBlockHotPoolThreshold   = 8;
 
   MediumBlockPoolSizeMem       = 20 * 64 * 1024;
   MediumBlockPoolSize          = MediumBlockPoolSizeMem - 16;
@@ -1159,11 +1166,12 @@ procedure NotifyMediumLargeFree(var Arena: TMMStatusArena; Size: PtrUInt);
     NextSequentialFeedBlockAddress: pointer;
     MaxSequentialFeedBlockAddress: pointer;
     CurrentSequentialFeedPool: PSmallBlockPoolHeader;
-    GetmemCount: cardinal;
-    FreememCount: cardinal;
-    LastFreeLocked: boolean;
-    Padding: array[1 .. 3] of byte;
-    LastFreeCount: cardinal;
+    GetmemCount: cardinal;
+    FreememCount: cardinal;
+    LastFreeLocked: boolean;
+    EmptyPoolReuseScore: byte;
+    Padding: array[1 .. 2] of byte;
+    LastFreeCount: cardinal;
   end;
   PSmallBlockType = ^TSmallBlockType;
 
@@ -3997,14 +4005,24 @@ function _FreeMem(P: pointer): PtrUInt;
         {$endif NOSFRAME}
         {$ifdef FPCMM_MOONSHARD}
 @EmptySequentialFeedPool:
-        // Keep one reusable first block for the hottest tiny size classes
+        // Keep one empty pool after repeated single-block churn. Tiny classes
+        // retain it immediately; larger small classes first prove reuse.
+        // Those larger classes are global, not per-thread/per-arena: retaining
+        // every one is bounded to about 1.2 MiB with the current pool table.
         {$ifdef MSWINDOWS}
         cmp     word ptr [rbx].TSmallBlockType.BlockSize, 256
+        jbe     @StoreFreeBlock
+        cmp     byte ptr [rbx].TSmallBlockType.EmptyPoolReuseScore, SmallBlockHotPoolThreshold
+        jae     @StoreFreeBlock
+        inc     byte ptr [rbx].TSmallBlockType.EmptyPoolReuseScore
         {$else}
         cmp     word ptr [rsi].TSmallBlockType.BlockSize, 256
-        {$endif MSWINDOWS}
         jbe     @StoreFreeBlock
-        jmp     @IsSequentialFeedPool
+        cmp     byte ptr [rsi].TSmallBlockType.EmptyPoolReuseScore, SmallBlockHotPoolThreshold
+        jae     @StoreFreeBlock
+        inc     byte ptr [rsi].TSmallBlockType.EmptyPoolReuseScore
+        {$endif MSWINDOWS}
+        jmp     @IsSequentialFeedPool
         {$endif FPCMM_MOONSHARD}
 @ProcessPendingBin:
         // Release the next SmallLastFree list block while we own the lock
@@ -5378,6 +5396,27 @@ procedure Fpcx64mmTestCorruptSmallLastFreeHead(P: pointer);
 end;
 {$endif FPCMM_SMALLLASTFREE_TEST}
 
+{$ifdef FPCMM_SMALLPOOL_REUSE_TEST}
+function Fpcx64mmTestSmallBlockType(P: pointer): pointer;
+begin
+  result := PSmallBlockPoolHeader(
+    PPtrUInt(PByte(P) - BlockHeaderSize)^ and DropSmallFlagsMask)^.BlockType;
+end;
+
+function Fpcx64mmTestSmallEmptyPoolReuseScore(BlockType: pointer): cardinal;
+begin
+  result := PSmallBlockType(BlockType)^.EmptyPoolReuseScore;
+end;
+
+function Fpcx64mmTestSmallRetainedPool(BlockType: pointer): pointer;
+begin
+  if PSmallBlockType(BlockType)^.MaxSequentialFeedBlockAddress <> nil then
+    result := PSmallBlockType(BlockType)^.CurrentSequentialFeedPool
+  else
+    result := nil;
+end;
+{$endif FPCMM_SMALLPOOL_REUSE_TEST}
+
 {$ifdef FPCMM_MEDIUMLASTFREE_TEST}
 function TestMediumInfo(P: pointer): PMediumBlockInfo;
 begin