固定長メモリマネージャ1

眠い頭で二時間ぐらいで書いてみました。

type
	TFixedMemoryManager = object
	private
		Memory: Pointer;
		UnitSize: Cardinal;
		First: Pointer;
		Last: Pointer;
		CachedBlock: Pointer;
	public
		constructor Initialize(AUnitSize: Cardinal);
		destructor Finalize;
		function Allocate: Pointer;
		procedure Free(AUnit: Pointer);
	end;

{ TFixedMemoryManager }

type
	PFixedMemRec = ^TFixedMemRec;
	TFixedMemRec = record
		NextUsed, NextFree: Pointer;
	end;

function TFixedMemoryManager.Allocate: Pointer;
var
	NewCommitSize: Integer;
begin
	if First = Last then
	begin
		NewCommitSize := UnitSize * 1024;

		if VirtualAlloc(Last, NewCommitSize, MEM_COMMIT, PAGE_READWRITE) = nil then
			OutOfMemoryError;

		Result := First;

		Inc(Cardinal(Last), NewCommitSize);
		Inc(Cardinal(First), UnitSize);

		PFixedMemRec(First)^.NextUsed := Last;
		PFixedMemRec(First)^.NextFree := Last;
	end
	else
	begin
		Result := First;
		Inc(Cardinal(First), UnitSize);
		if First = PFixedMemRec(Result)^.NextUsed then
			First := PFixedMemRec(Result)^.NextFree
		else
		begin
			PFixedMemRec(First)^ := PFixedMemRec(Result)^;
		end
	end;
	if CachedBlock = Result then CachedBlock := First;
end;

destructor TFixedMemoryManager.Finalize;
var
	Commited: Cardinal;
begin
	Commited := Cardinal(Last) - Cardinal(Memory);
	if Commited <> 0 then
		VirtualFree(Memory, Commited, MEM_DECOMMIT);
	if Memory <> nil then
	begin
{$IFOPT C+}
		if not VirtualFree(Memory, 0, MEM_RELEASE) then RaiseLastOSError;
{$ELSE}
		VirtualFree(Memory, 0, MEM_RELEASE);
{$ENDIF}
	end;	
end;

procedure TFixedMemoryManager.Free(AUnit: Pointer);
var
	Block, NextFreeBlock: PFixedMemRec;
	NextUnit: Pointer;
begin
	NextUnit := Pointer(Cardinal(AUnit) + UnitSize);

	if Cardinal(AUnit) < Cardinal(First) then
	begin
		if NextUnit = First then
		begin
			PFixedMemRec(AUnit)^ := PFixedMemRec(First)^;
		end
		else
		begin
			PFixedMemRec(AUnit)^.NextUsed := NextUnit;
			PFixedMemRec(AUnit)^.NextFree := First;
		end;
		First := AUnit;
		if Cardinal(CachedBlock) < Cardinal(First) then CachedBlock := First;
	end
	else
	begin
		Block := First;
		if Cardinal(CachedBlock) <= Cardinal(AUnit) then
			Block := CachedBlock;

		while Cardinal(AUnit) >= Cardinal(Block^.NextFree) do
			Block := Block^.NextFree;

		NextFreeBlock := Block^.NextFree;

		if AUnit = Block^.NextUsed then
		begin
			Block^.NextUsed := NextUnit;
			if Block^.NextUsed = NextFreeBlock then
			begin
				Block^ := NextFreeBlock^;
			end;
		end
		else if NextUnit = NextFreeBlock then
		begin
			if NextFreeBlock = Last then
			begin
				PFixedMemRec(AUnit)^.NextUsed := Last;
				PFixedMemRec(AUnit)^.NextFree := Last;
			end
			else
			begin
				PFixedMemRec(AUnit)^ := NextFreeBlock^;
			end;
			Block^.NextFree := AUnit;
		end
		else
		begin
			PFixedMemRec(AUnit)^.NextUsed := NextUnit;
			PFixedMemRec(AUnit)^.NextFree := NextFreeBlock;
			Block^.NextFree := AUnit;
		end;
		CachedBlock := Block;
	end
end;

constructor TFixedMemoryManager.Initialize(AUnitSize: Cardinal);
const
	MaxLogicalLimitation = 1024 * 1024 * 1024; {1GB!}
var
	LogicalLimitation: Cardinal;
begin
	UnitSize := AUnitSize;
	if AUnitSize < SizeOf(TFixedMemRec) then
		UnitSize := SizeOf(TFixedMemRec);

	First := nil;
	Last := nil;

	LogicalLimitation := MaxLogicalLimitation;
	repeat
		Memory := VirtualAlloc(nil, LogicalLimitation, MEM_RESERVE, PAGE_READWRITE);
		if Memory <> nil then Break;
		LogicalLimitation := LogicalLimitation div 2;
		if LogicalLimitation < AUnitSize then
			OutOfMemoryError;
	until False;

	First := Memory;
	Last := Memory;
	CachedBlock := Memory;
end;

Win32のヒープ関数と比べて、メモリ消費が半分くらいになります。
VirtualAllocを本格活用したのは初めてですが、使えますね。作業中同時に同じような事をしないのが前提ですが、広い連続アドレス空間を占拠することで、拡張時にも全体のコピーが不要なvectorとなります。
それはいいんですが、ヒープ関数より遅かったです。何が遅いって、解放のときの線形探索が遅いです。CachedBlock入れてようやく勝ちました。

割り当て/解放の傾向が、がばっと割り当ててがばっと解放して、しかも解放する群は割り当てた群と異なり新旧混じってる悪質なものであることも影響してるのでしょうか。
Lokiのように解放も探索せずにできるようにしないと…