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.