固定長メモリマネージャ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のように解放も探索せずにできるようにしないと…
固定長メモリマネージャ2
というわけでModern C++ Design*1を引っ張り出してきて、起きた頭で書き直し。
type TFixedMemoryManager = object private Memory: Pointer; UnitSize: Cardinal; First: Pointer; Last: Pointer; public constructor Initialize(AUnitSize: Cardinal); destructor Finalize; function Allocate: Pointer; procedure Free(AUnit: Pointer); end;
{ TFixedMemoryManager } function TFixedMemoryManager.Allocate: Pointer; var NewCommitSize: Integer; Next, I: Pointer; 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); I := First; while Cardinal(I) < Cardinal(Last) do begin Next := Pointer(Cardinal(I) + UnitSize); PPointer(I)^ := Next; I := Next; end; end else begin Result := First; First := PPointer(Result)^; end; 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); begin PPointer(AUnit)^ := First; First := AUnit; end; constructor TFixedMemoryManager.Initialize(AUnitSize: Cardinal); const MaxLogicalLimitation = 1024 * 1024 * 1024; {1GB!} var LogicalLimitation: Cardinal; begin UnitSize := AUnitSize; if AUnitSize < SizeOf(Pointer) then UnitSize := SizeOf(Pointer); 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; end;
速い!圧倒的に速い!
ヒープ関数や上の実装の1/10以上速く動きます。
*1:この本初めて役に立ったかも…
一応貼ってみる
Come to BorCon 2004 (US) to see the next Delphi release!
http://bdn.borland.com/article/0,1410,32499,00.html
http://pc5.2ch.net/test/read.cgi/tech/1089454618/513-
申告はどうすればいいのだろう。
それ以前にBorlandのひとがチェックに来ても日本語ワカランでスルーされそうな恐さが…。