type
  // В старых Delphi
  TMemoryManager = record
    GetMem: function(Size: Integer): Pointer;
    FreeMem: function(P: Pointer): Integer;
    ReallocMem: function(P: Pointer; Size: Integer): Pointer;
  end;
 
  // В новых Delphi
  TMemoryManagerEx = record
    { Базовая (обязательная) функциональность }
    GetMem: function(Size: Integer): Pointer;
    FreeMem: function(P: Pointer): Integer;
    ReallocMem: function(P: Pointer; Size: Integer): Pointer;
    { Дополнительная (опциональная) функциональность }
    AllocMem: function(Size: Cardinal): Pointer;
    RegisterExpectedMemoryLeak: function(P: Pointer): Boolean;
    UnregisterExpectedMemoryLeak: function(P: Pointer): Boolean;
  end;

var
   xxx: array of byte;
begin
   setlength(xxx, 100);
   for ii:=100 to 200000 do
      xxx[ii] := 90;

UNIT WindowsMM;
INTERFACE
USES Windows;
IMPLEMENTATION    
type
   TMInteger = Integer;
   SIZE_T = Integer;
var
   gHeap: THandle;

function NewGetMem({$IFNDEF D2010}DataSize: TMInteger{$ELSE}DataSize: NativeInt{$ENDIF}): Pointer;
begin
   if DataSize<=0 then begin
      Result := nil;
      Exit;
   end;
//   Result := VirtualAlloc(nil, DataSize,MEM_COMMIT, PAGE_READWRITE);
   Result := HeapAlloc(gHeap, 0, DataSize);
end;


function NewFreeMem(DataPtr: Pointer): Integer;
begin
   if DataPtr=nil then begin
      Result := 0;
      Exit;
   end;
   HeapFree(gHeap, 0, DataPtr);
//   VirtualFree(DataPtr, 0, MEM_RELEASE);
   Result := 0;
end;

function NewReallocMem(DataPtr: Pointer; {$IFNDEF D2010}DataSize: TMInteger{$ELSE}DataSize: NativeInt{$ENDIF}): Pointer;
begin
   if (DataPtr=nil) or (DataSize<=0) then begin
      Result := nil;
      Exit;
   end;
   Result := HeapRealloc(gHeap, 0, DataPtr, DataSize);
end;




const
   HeapCompatibilityInformation = 0;
   HeapEnableTerminationOnCorruption = 1;
   HEAP_LFH = 2;
var
   HeapSetInformation: function(
      HeapHandle: THandle;
      HeapInformationClass: ULONG;
      HeapInformation: pointer;
      HeapInformationLength: SIZE_T
   ): BOOL; stdcall;

   

procedure InitLowFragmentationHeap(AHeap :THandle);
var
   vModule :HMODULE;
   vHeapInformation :ULONG;
begin
   vModule := GetModuleHandle(kernel32);
   if vModule<>0 then
      @HeapSetInformation := GetProcAddress(vModule, 'HeapSetInformation');
   if Assigned(HeapSetInformation) then begin
      vHeapInformation := HEAP_LFH;
      HeapSetInformation(AHeap, HeapCompatibilityInformation, @vHeapInformation, SizeOf(vHeapInformation));
   end;
end;



const
   DebugMemMgr: TMemoryManager = (
      GetMem    : NewGetMem;
      FreeMem   : NewFreeMem;
      ReallocMem: NewReallocMem
   );
var
   OldMemMgr: TMemoryManager;
   ManagerInstalled: Boolean = False;

procedure InstallMemoryManager;
begin
   if not ManagerInstalled then begin
      GetMemoryManager(OldMemMgr);
      SetMemoryManager(DebugMemMgr);
      gHeap := GetProcessHeap;
      InitLowFragmentationHeap(gHeap);
      ManagerInstalled := True;
   end;
end;

procedure DeinstallMemoryDebugManager;
begin
   if ManagerInstalled then begin
      SetMemoryManager(OldMemMgr);
      ManagerInstalled := False;
   end;
end;



INITIALIZATION
   InstallMemoryManager;
FINALIZATION
  DeinstallMemoryDebugManager;
END.

UNIT WndMM;
INTERFACE
{$IF RTLVersion >= 18.0}
   {$DEFINE MEMORY_MANAGER_EX}
{$IFEND}
              
function SafeGetMem(size: integer): pointer;
function SafeFreeMem(p: pointer): integer;
function SafeReallocMem(p: pointer; size: integer): pointer;
function SafeAllocMem(size: cardinal): pointer;

const
{$IFDEF MEMORY_MANAGER_EX}
   SafeMemoryManager: TMemoryManagerEx = (
      GetMem: SafeGetMem;
      FreeMem: SafeFreeMem;
      ReallocMem: SafeReallocMem;
      AllocMem: SafeAllocMem;
      RegisterExpectedMemoryLeak: nil;
      UnregisterExpectedMemoryLeak: nil;
   );
{$ELSE}
   SafeMemoryManager: TMemoryManager = (
      GetMem: SafeGetMem;
      FreeMem: SafeFreeMem;
      ReallocMem: SafeReallocMem;
   );
type
   TMemoryManagerEx = TMemoryManager;
{$ENDIF}

IMPLEMENTATION
USES Windows;
type
   PBlockInfo = ^TBlockInfo;
   TBlockInfo = record
      start: pointer;
      size: cardinal;
   end;
var
   fCritical: TRTLCriticalSection;

function offset(const p: pointer; const addon: integer): pointer;
begin
   result := pointer( cardinal(p) + addon );
end;

function SafeGetMem(size: integer): pointer;
var
   block: PBlockInfo;
   size2, BlockSize: cardinal;
begin
   size2 := size + sizeof(TBlockInfo);

   BlockSize := size2 div 4096;
   if size2 mod 4096>0 then inc(BlockSize);
   BlockSize := BlockSize*4096;

   block := VirtualAlloc(nil, BlockSize, MEM_COMMIT, PAGE_READWRITE);
   block.start := offset(block, sizeof(TBlockInfo));
   block.size := size;

   result := block.start;
end;

function SafeAllocMem(size: cardinal): pointer;
begin
   result := SafeGetMem(size);
end;

function min(const i1, i2: integer): integer;
begin
   result := i1;
   if i2<result then result := i2;
end;

function SafeFreeMem(p: pointer): integer;
begin
   p := offset(p, -sizeof(TBlockInfo));
   VirtualFree(p, 0, MEM_RELEASE);
   result := 0;
end;

function SafeReallocMem(p: pointer; size: integer): pointer;
var
   block: PBlockInfo;
   BlockSize: integer;
begin
   block := offset(p, -sizeof(TBlockInfo));
   result := SafeAllocMem(size);
   BlockSize := min(block.size, size);
   Move(p^, result^, BlockSize);
   SafeFreeMem(p);
end;

INITIALIZATION
   InitializeCriticalSection(fCritical);
FINALIZATION
   DeleteCriticalSection(fCritical);
END.

UNIT WndMMInstall;
INTERFACE
IMPLEMENTATION
USES WndMM;
var
  FOldManager: TMemoryManagerEx;

procedure InstallSafeMemoryManager;
begin
   GetMemoryManager(FOldManager);
   SetMemoryManager(SafeMemoryManager);
end;

procedure UninstallSafeMemoryManager;
begin
   SetMemoryManager(FOldManager);
end;

INITIALIZATION
   InstallSafeMemoryManager;
FINALIZATION
   UninstallSafeMemoryManager;
END.

UNIT NatalyMM;
INTERFACE
USES Windows;
IMPLEMENTATION
type
   TMInteger = Integer;
   SIZE_T = Integer;
var
   gHeap: THandle;
const
   Protector0 = 1.3; {выделяем памяти в несколько раз больше, чем нужно}
   Protector1 = 64; {резервируем это количество байт до выделяемого участка}
   Protector2 = 128; {резервируем это количество байт после выделяемого участка}

procedure GetMMAndSize(DataPtr: integer; var MM, size: integer);
begin
   MM := DataPtr-Protector1;
   size := HeapSize(gHeap, 0, pointer(MM));
end;

function NewGetMem(DataSize: integer): Pointer;
var
   MM: integer;
begin
   if DataSize<=0 then begin
      result := nil;
      Exit;
   end;

   {обернем все слоем ваты}
   MM := integer(HeapAlloc(gHeap, 0, round(Protector0*DataSize) + Protector1 + Protector2));
   result := pointer(MM+Protector1);
end;

function NewFreeMem(DataPtr: Pointer): Integer;
var
   MM, size: integer;
begin
   if DataPtr=nil then begin
      Result := 0;
      Exit;
   end;

   GetMMAndSize(integer(DataPtr), MM, Size);

   HeapFree(gHeap, 0, pointer(MM));
   result := 0;
end;

function NewReallocMem(DataPtr: Pointer; DataSize: integer): pointer;
var
   MM, size: integer;
begin
   if (DataPtr=nil) or (DataSize<=0) then begin
      Result := nil;
      Exit;
   end;

   GetMMAndSize(integer(DataPtr), MM, size);

   MM := integer(HeapRealloc(gHeap, 0, pointer(MM), round(Protector0*DataSize) + Protector1 + Protector2));
   result := pointer(integer(MM)+Protector1);
end;

const
   HeapCompatibilityInformation = 0;
   HeapEnableTerminationOnCorruption = 1;
   HEAP_LFH = 2;
var
   HeapSetInformation: function(
      HeapHandle: THandle;
      HeapInformationClass: ULONG;
      HeapInformation: pointer;
      HeapInformationLength: SIZE_T
   ): BOOL; stdcall;

procedure InitLowFragmentationHeap(AHeap :THandle);
var
   vModule: HMODULE;
   vHeapInformation :ULONG;
begin
   vModule := GetModuleHandle(kernel32);
   if vModule<>0 then
      @HeapSetInformation := GetProcAddress(vModule, 'HeapSetInformation');
   if Assigned(HeapSetInformation) then begin
      vHeapInformation := HEAP_LFH;
      HeapSetInformation(AHeap, HeapCompatibilityInformation, @vHeapInformation, SizeOf(vHeapInformation));
   end;
end;

const
   DebugMemMgr: TMemoryManager = (
      GetMem    : NewGetMem;
      FreeMem   : NewFreeMem;
      ReallocMem: NewReallocMem
   );
var
   OldMemMgr: TMemoryManager;
   ManagerInstalled: Boolean = False;

procedure InstallMemoryManager;
begin
   if not ManagerInstalled then begin
      GetMemoryManager(OldMemMgr);
      SetMemoryManager(DebugMemMgr);
      gHeap := GetProcessHeap;
      InitLowFragmentationHeap(gHeap);
      ManagerInstalled := True;
   end;
end;

procedure DeinstallMemoryDebugManager;
begin
   if ManagerInstalled then begin
      SetMemoryManager(OldMemMgr);
      ManagerInstalled := False;
   end;
end;

INITIALIZATION
   InstallMemoryManager;
FINALIZATION
   DeinstallMemoryDebugManager;
END.