{
  Alternative memory manager. Main purpose is to economy memory on small
  allocations less then 32 bytes in a chunk. Compatible with FPC.  
    
  To use it, just place a reference to this unit *FIRST* in the uses clause 
  of your project (dpr/lpr-file).
  =====================================================================
  Copyright (C) by Vladimir Kladov, 2005
  ---------------------------------------------------------------------
  mailto: v1kladov@mail.ru (actual in 2022)
}

unit EconoMM;

interface

{$IFDEF LINUX}
{$ELSE}
uses windows;
{$ENDIF}

implementation


var OldMM: TMemoryManager;

{$DEFINE debg_eco}

const 
	Offset_Len = Sizeof(Integer);
	Max_bytes_chunk = 80;
	Max_words_chunk = Max_bytes_chunk div 4;
	Max_chunks = 60;
	FlagBigChunk = $80000000;
	FlagBigChunk_set = $80808080;
	
type
	PBlockMem = ^TBlockMem;
	TBlockMem = record
		d: array[0 .. Max_chunks * 4 + Max_chunks * Offset_Len - 1] of Byte;
		NextBlock: PBlockMem;
		PrevBlock: PBlockMem;
		FirstFree: Byte;
		ChunkSize: Byte;
		CountAllocated: Byte;
		countMaximum: Byte;
		{$IFDEF debg_eco}
		index_block: Integer;
		{$ENDIF}
	end;
	
	TMemBlkSize = {$IFDEF FPC}
					{$IFDEF CPUX64} QWord {$ELSE} LongWord {$ENDIF} 
				  {$ELSE} Integer {$ENDIF}
				  ;
	
var Blocks_nn: array[1..Max_words_chunk] of PBlockMem;
	BlocksEnd: array[1..Max_words_chunk] of PBlockMem;
	{$IFDEF debg_eco}
	total_blocks: Integer;
	{$ENDIF}
	
procedure Allocate_block(var b: PBlockMem; sz: Integer);
var nb: PBlockMem;
	n: Integer;
	i, j: Integer;
begin
  {$IFDEF debg_eco}
  if total_blocks = 10 then
     total_blocks := total_blocks * 1;
  {$ENDIF}
	nb := OldMM.GetMem(Sizeof(TBlockMem));
	FillChar(nb^, Sizeof(TBlockMem), 0);
	nb^.NextBlock := b;
	if b <> nil then b^.PrevBlock := nb;
	nb^.ChunkSize := sz;
	i := 0;
	n := SizeOf(TBlockMem.d) div (sz + Offset_Len);
	nb^.countMaximum := n;
	nb^.FirstFree := n - 1;
	for j := 0 to n-1 do
	begin
	    nb^.d[i] := j-1;
	    PWord(@nb^.d[i+2])^ := i;
	    inc(i, Offset_Len + sz);
	end; 
	b := nb;
	{$IFDEF debg_eco}
	inc(total_blocks);
	b^.index_block := total_blocks;
	{$ENDIF}
end;

procedure Release_block(var b: PBlockMem);
var i: Integer;
begin
	i := b^.ChunkSize div 4;
	
	if b^.PrevBlock = nil then
	   Blocks_nn[i] := b^.NextBlock
	else
	   b^.PrevBlock^.NextBlock := b^.NextBlock;
	   
	if b^.NextBlock = nil then 
	   BlocksEnd[i] := b^.PrevBlock
	else 
	   b^.NextBlock^.PrevBlock := b^.PrevBlock;
	
	OldMM.FreeMem(b);
end;

function EcoGetMem(size: TMemBlkSize ): Pointer;
// Allocate memory block.
var b: PBlockMem;
	sz: Integer;
	f: Integer;
	i, bind: Integer;
begin
	if size > Max_bytes_chunk then
	begin
  		Result := OldMM.GetMem( size + SizeOf(Integer) );
  		PInteger(Result)^ := FlagBigChunk_set;
  		Result := Pointer(IntPtr(Result) + SizeOf(Integer));
  		Exit;
	end;
	Result := nil;
	sz := ((size + 3) shr 2) shl 2;
	bind := sz shr 2; // sz div 4;
	b := Blocks_nn[bind];
	if (b = nil) or (b^.FirstFree = $FF) then
	begin 
		Allocate_block(Blocks_nn[bind], sz);
		b := Blocks_nn[bind];
		if BlocksEnd[bind] = nil then BlocksEnd[bind] := b;
	end;
   	inc(b^.CountAllocated);
   	f := b^.FirstFree;
   	i := (sz + Offset_Len) * f;
   	b^.FirstFree := b^.d[i];
   	b^.d[i] := size;
   	Result := @ b^.d[i + Offset_Len];
   	///////////////////////////////// if no more free chunks,
   	///////////////////////////////// move block to the end
   	if (b^.FirstFree = $FF) and (b^.NextBlock <> nil) then
   	begin
   	     if Blocks_nn[bind] = b then
   	  	   Blocks_nn[bind] := b^.NextBlock;
   	     if b^.PrevBlock <> nil then
   	  	   b^.PrevBlock^.NextBlock := b^.NextBlock;
   	     if b^.NextBlock <> nil then
   	  	   b^.NextBlock^.PrevBlock := b^.PrevBlock;
   	     //------- now, insert to the end of blocks array
   	     b^.PrevBlock := BlocksEnd[bind];
   	     b^.NextBlock := nil;
   	     b^.PrevBlock^.NextBlock := b;
   	     BlocksEnd[bind] := b; 
   	end;
end;

{$IFDEF FPC}
function EcoAllocMem(size: TMemBlkSize) : Pointer;
// Allocate memory block.
begin
  Result := EcoGetMem( size );
  if Result <> nil then FillChar(Result, size, 0);
end;
{$ENDIF}

{$ifdef debg_eco}
var count__EcoFreeMem: Integer;
{$ENDIF}

function EcoFreeMem(p: Pointer): TMemBlkSize;
// Deallocate memory block.
var size, sz: DWORD;
	chunk: PByte;
	i, bind: Integer;
	b: PBlockMem;
begin
  {$ifdef debg_eco}
  inc(count__EcoFreeMem);
  if (count__EcoFreeMem = 968901) then
  begin
       count__EcoFreeMem := count__EcoFreeMem * 1;
  end;
  {$ENDIF}
	if p = nil then Exit;
	size := PDWORD( IntPtr(p) - Offset_Len )^;
	if (size and FlagBigChunk) <> 0 then
	begin
		p := Pointer( IntPtr(p) - SizeOf(Integer) );
  		Result := OldMM.FreeMem( p );
  		Exit;
	end;
	Result := size and $FF;
	sz := (Result + 3) and not 3;
	chunk := PByte(IntPtr(p) - Offset_Len);
	i := size shr 16;
	b := PBlockMem(IntPtr(chunk) - i);

	chunk^ := b^.FirstFree;
	b^.FirstFree := (IntPtr(chunk) - IntPtr(b)) div (Offset_Len + sz); 
	dec(b^.CountAllocated);
	if (b^.CountAllocated = 0) and (
		 (b^.PrevBlock <> nil) or (b^.NextBlock <> nil) 
		 and (b^.NextBlock^.CountAllocated < b^.NextBlock^.countMaximum)
	   ) then
	begin
	    Release_block(b);
	    Exit;
	end;
	
	//////////////////////////////////// if block was full, move it to the begin
	if (b^.CountAllocated = b^.countMaximum - 1) and (b^.PrevBlock <> nil) then
	begin
		bind := sz div 4;
		b^.PrevBlock^.NextBlock := b^.NextBlock;
		if b^.NextBlock <> nil then
		   b^.NextBlock^.PrevBlock := b^.PrevBlock
		else
		   BlocksEnd[bind] := b^.PrevBlock;
		//-------------------- new, insert as the 1st block
		b^.NextBlock := Blocks_nn[bind];
		b^.NextBlock^.PrevBlock := b;
		b^.PrevBlock := nil;
		Blocks_nn[bind] := b;
	end;
end;

{$IFDEF FPC}
function EcoFreeMemSize(p: Pointer; Size: TMemBlkSize): TMemBlkSize;
begin
	Result := EcoFreeMem(p);
end;
function EcoMemSize(p: Pointer): TMemBlkSize;
begin
	Result := PDWORD(IntPtr(p) - Offset_Len)^;
	if (Result and FlagBigChunk) = 0 then
	begin
	    Result := Result and $FF;
	    Exit;
	end;
	p := Pointer(IntPtr(p) - Sizeof(Integer));
	Result := OldMM.MemSize(p) - SizeOf(Integer);
end;
procedure EcoInitThread;
begin
	oldMM.InitThread;
end;
procedure EcoDoneThread;
begin
	oldMM.DoneThread;
end;
procedure EcoRelocateHeap;
begin
	oldMM.RelocateHeap;
end;
function EcoGetHeapStatus: THeapStatus;
var r: THeapStatus;
begin
	FillChar(r, sizeof(r), 0);
	Result := r;
end;
function EcoGetFPCHeapStatus: TFPCHeapStatus;
begin
	FillChar(EcoGetFPCHeapStatus, sizeof(EcoGetFPCHeapStatus), 0);
end;
{$ENDIF}

{$IFDEF debg_eco}
var count__EcoReallocMem: Integer;
{$ENDIF}

function EcoReallocMem(
		{$IFDEF FPC}var{$ENDIF} p: Pointer;  size: TMemBlkSize): Pointer;
// Resize memory block.
var sz, len: Cardinal;
	blk: Pointer;
begin
     {$IFDEF debg_eco}
     inc(count__EcoReallocMem);
     if (count__EcoReallocMem = 41595) then
     begin
          count__EcoReallocMem := count__EcoReallocMem * 1;
     end;
     {$ENDIF}

  if p = nil then
  begin
      Result := EcoGetMem(size);
      p := Result;
      Exit;
  end;
  sz := PInteger (IntPtr(p) - Offset_Len) ^ ;
  if (sz and FlagBigChunk) <> 0 then
       sz := OldMM.MemSize(Pointer (IntPtr(p) - SizeOf(Integer))) 
    	   - SizeOf(Integer)
  else sz := sz and $FF;
  	 
  if sz = size then 
  begin
  	Result := p;
  	Exit;
  end;
  if (sz <= Max_bytes_chunk) and (size <= Max_bytes_chunk)
  and (sz = ((size + 3) and not 3)) then
  begin
  	blk := Pointer( IntPtr(p) - SizeOf(Integer) );
  	PByte(blk)^ := size;
  	Exit;
  end;
  if size = 0 then
  begin
  	EcoFreeMem(p);
  	Result := nil;
  	{$IFDEF FPC}
  	p := nil;
  	{$ENDIF}
  	Exit;
  end;

  Result := EcoGetMem(size);
  len := size;
  if len > sz then len := sz;
  
  move(p^, Result^, len);
  EcoFreeMem(p);
  
  {$IFDEF FPC}
  p := Result;
  {$ENDIF}
end;

const
  EcoMemoryManager: TMemoryManager = (
  {$IFDEF FPC}
	NeedLock: true;
  {$ENDIF}
    GetMem: {$IFDEF FPC}@{$ENDIF} EcoGetMem;
    FreeMem: {$IFDEF FPC}@{$ENDIF} EcoFreeMem;
  {$IFDEF FPC}
	FreeMemSize: @EcoFreeMemSize;
	AllocMem: @EcoAllocMem;
  {$IFDEF FPC}
    ReallocMem: {$IFDEF FPC}@{$ENDIF} EcoReallocMem;
  {$ENDIF}
	MemSize: @EcoMemSize;
	InitThread: @EcoInitThread;
	DoneThread: @EcoDoneThread;
	RelocateHeap: @EcoRelocateHeap;
	GetHeapStatus: @EcoGetHeapStatus;
	GetFPCHeapStatus: @EcoGetFPCHeapStatus;
  {$ENDIF}
  );

initialization

  GetMemoryManager( OldMM );
  SetMemoryManager( EcoMemoryManager );

finalization

  SetMemoryManager( OldMM );

end.
