インクリメンタルGC

参考URL: http://members.at.infoseek.co.jp/zzyyb/gc/incremental-collector.html

program IncGC;

//incremental update collector

{$APPTYPE CONSOLE}

uses
	Crt, SysUtils;

type
	TIGCColor = (igccBlack, igccGray, igccWhite);

	TIGCObject = class;

	TIGCObjectQueue = record
		First, Last: TIGCObject;
		Count: Cardinal;
	end;

	TIGCObjectSpace = record
		Black: TIGCObjectQueue;
		Gray: TIGCObjectQueue;
		White: TIGCObjectQueue;
	end;

	TIGCObject = class(TObject)
		Pred, Succ: TIGCObject;
		References: array of TIGCObject;
		Color: TIGCColor;
		Root: Boolean;
		constructor Create(var ObjectSpace: TIGCObjectSpace);
		procedure AddReference(var ObjectSpace: TIGCObjectSpace; Obj: TIGCObject);
		procedure RemoveReference(var ObjectSpace: TIGCObjectSpace; Obj: TIGCObject);
		procedure SetRoot(var ObjectSpace: TIGCObjectSpace; Value: Boolean);
	end;

procedure AddToObjectQueue(var ObjectQueue: TIGCObjectQueue; Obj: TIGCObject);
begin
	Obj.Pred := ObjectQueue.Last;
	Obj.Succ := nil;
	if ObjectQueue.First = nil then
		ObjectQueue.First := Obj
	else
		ObjectQueue.Last.Succ := Obj;
	ObjectQueue.Last := Obj;
	Inc(ObjectQueue.Count);
end;

procedure RemoveFromObjectQueue(var ObjectQueue: TIGCObjectQueue; Obj: TIGCObject);

	function Check: Boolean;
	var
		I: TIGCObject;
	begin
		I := ObjectQueue.First;
		while I <> nil do
		begin
			if I = Obj then begin Result := True; Exit; end;
			I := I.Succ;
		end;
		Result := False;
	end;

begin
	Assert(ObjectQueue.Count > 0);
	Assert(Check);

	if ObjectQueue.First = Obj then
		ObjectQueue.First := Obj.Succ
	else
		Obj.Pred.Succ := Obj.Succ;
	if ObjectQueue.Last = Obj then
		ObjectQueue.Last := Obj.Pred
	else
		Obj.Succ.Pred := Obj.Pred;
	Dec(ObjectQueue.Count);
end;

procedure ClearObjectQueue(var ObjectQueue: TIGCObjectQueue);
var
	I, Next: TIGCObject;
begin
	I := ObjectQueue.First;
	while I <> nil do
	begin
		Next := I.Succ;
		I.Free;
		I := Next;
	end;
	ObjectQueue.First := nil;
	ObjectQueue.Last := nil;
	ObjectQueue.Count := 0;
end;

procedure InitializeObjectSpace(out ObjectSpace: TIGCObjectSpace);
begin
	FillChar(ObjectSpace, SizeOf(ObjectSpace), 0);
end;

procedure FinalizeObjectSpace(var ObjectSpace: TIGCObjectSpace);
begin
	ClearObjectQueue(ObjectSpace.Black);
	ClearObjectQueue(ObjectSpace.Gray);
	ClearObjectQueue(ObjectSpace.White);
end;

procedure ProcessGC(var ObjectSpace: TIGCObjectSpace);
var
	Obj, R: TIGCObject;
	I: Integer;
begin
	if ObjectSpace.Gray.Count > 0 then
	begin
		WriteLn(ObjectSpace.Black.Count:10, ObjectSpace.Gray.Count:10, ObjectSpace.White.Count:10); {*}
		Obj := ObjectSpace.Gray.First;
		RemoveFromObjectQueue(ObjectSpace.Gray, Obj);
		Obj.Color := igccBlack;
		AddToObjectQueue(ObjectSpace.Black, Obj);
		for I := Low(Obj.References) to High(Obj.References) do
		begin
			R := Obj.References[I];
			if (R <> nil) and (R.Color = igccWhite) then
			begin
				RemoveFromObjectQueue(ObjectSpace.White, R);
				R.Color := igccGray;
				AddToObjectQueue(ObjectSpace.Gray, R);
			end;
		end;
	end
	else
	begin
		WriteLn('*****************'); {*}
		WriteLn('**** Collect ****'); {*}
		WriteLn('*****************'); {*}
		ClearObjectQueue(ObjectSpace.White);
		while ObjectSpace.Black.Count > 0 do
		begin
			Obj := ObjectSpace.Black.First;
			RemoveFromObjectQueue(ObjectSpace.Black, Obj);
			if Obj.Root then
			begin
				Obj.Color := igccGray;
				AddToObjectQueue(ObjectSpace.Gray, Obj);
			end
			else
			begin
				Obj.Color := igccWhite;
				AddToObjectQueue(ObjectSpace.White, Obj);
			end
		end;	
	end;
end;

constructor TIGCObject.Create(var ObjectSpace: TIGCObjectSpace);
begin
	ProcessGC(ObjectSpace);
	ProcessGC(ObjectSpace);

	inherited Create;
	Color := igccWhite;
	AddToObjectQueue(ObjectSpace.White, Self);
end;

procedure TIGCObject.AddReference(var ObjectSpace: TIGCObjectSpace; Obj: TIGCObject);
var
	I: Integer;
begin
	if (Color = igccBlack) and (Obj.Color = igccWhite) then
	begin
		RemoveFromObjectQueue(ObjectSpace.White, Obj);
		Obj.Color := igccGray;
		AddToObjectQueue(ObjectSpace.Gray, Obj);
	end;
	for I := Low(References) to High(References) do
	begin
		if References[I] = nil then
		begin
			References[I] := Obj;
			Exit;
		end;
	end;
	SetLength(References, Length(References) + 1);
	References[High(References)] := Obj;
end;

procedure TIGCObject.RemoveReference(var ObjectSpace: TIGCObjectSpace; Obj: TIGCObject);
var
	I: Integer;
begin
	for I := Low(References) to High(References) do
		if References[I] = Obj then
		begin
			References[I] := nil;
			Exit;
		end;
end;

procedure TIGCObject.SetRoot(var ObjectSpace: TIGCObjectSpace; Value: Boolean);
begin
	Root := Value;
	if Value and (Color = igccWhite) then
	begin
		RemoveFromObjectQueue(ObjectSpace.White, Self);
		Color := igccGray;
		AddToObjectQueue(ObjectSpace.Gray, Self);
	end;
end;

var
	ObjectSpace: TIGCObjectSpace;
	Root, Obj: TIGCObject;
begin
	InitializeObjectSpace(ObjectSpace);

	Root := TIGCObject.Create(ObjectSpace);
	Root.SetRoot(ObjectSpace, True);
	repeat
		if Random(100) = 0 then
		begin
			Obj := TIGCObject.Create(ObjectSpace);
			Obj.SetRoot(ObjectSpace, True);
			Obj.AddReference(ObjectSpace, Root);
			Root.SetRoot(ObjectSpace, False);
		end
		else if Random(2) = 0 then
		begin
			Obj := TIGCObject.Create(ObjectSpace);
			Root.AddReference(ObjectSpace, Obj);
		end
		else if Root.References <> nil then
		begin
			Obj := Root.References[Random(Length(Root.References))];
			if Obj <> nil then Root.RemoveReference(ObjectSpace, Obj);
		end;
	until False;

	FinalizeObjectSpace(ObjectSpace);
end.

例によってソース貼って解説無しという悪癖発動。
これでオブジェクトの割り当てにこないだの固定長メモリアロケータを使えば、それなりに高速にできるかな…。

マルチスレッドにも対応させたいのですが、サッパリ分からん。新規オブジェクトが参照される前に他のスレッドで灰が全部処理されて白が消されたりとかありそう。新規を灰にしたところで他のスレッドで二巡したら終わりだし。新規は灰でしかもルートにして、何かに参照されてからルートを解除…とかやらないとだめなのでしょうか？