A garbage collector for C and C++ (and a wrapper for Delphi): The Boehm-Demers-Weiser conservative C/C++ Garbage Collector

December 2020
M	T	W	T	F	S	S
	1	2	3	4	5	6
7	8	9	10	11	12	13
14	15	16	17	18	19	20
21	22	23	24	25	26	27
28	29	30	31

Posted by jpluimers on 2020/12/30

I bumped into [WayBack] A garbage collector for C and C++ a while ago, for which the source is at [WayBack] GitHub – ivmai/bdwgc: The Boehm-Demers-Weiser conservative C/C++ Garbage Collector (libgc, bdwgc, boehm-gc).

There is a (very old!) wrapper for Delphi too: [WayBack] 21646 API for Boehm Garbage Collector DLL

Barry Kelly <barry_j_kelly@hotmail.com>,
19 April 2004
——————————————————
This archive contains a simple API unit for the Boehm Garbage Collector DLL, along with another unit which makes it easier to use with classes, and a demonstration application. Also included is the Boehm GC DLL binary, along with source code in the gc_dll_src directory.

The files:

BoehmGc.pas
———–
This unit exports a dozen or so routines from the Boehm GC dll. Since the GC integrates with and replaces the Delphi default memory manager, you probably don’t need to use this unit unless you want to fine-tune the behaviour of the DLL. The DLL exports more routines than are in this unit; the C prototypes are in the gc_dll_src/gc.h header file, and can be imported as needed. If you allocate large chunks of memory (>100K) which don’t contain references to other chunks (and thus don’t need to be scanned for pointers), there are routines in this unit which you can use to increase performance.

General advice: don’t tweak until you need to tweak.

Gc.pas
——
This is the main unit. Put this unit first in the uses clause of you project and the project will automatically use garbage collection. If you want to use objects which require finalization and you don’t want to have to call TObject.Free / TObject.Destroy on them manually, you can use the MarkForFinalization(TObject) function. The basic pattern is to register the object for finalization in its constructor and unregister it with UnmarkForFinalization in its destructor. This handles the two most common use cases for finalization: GC-invoked finalization and manual finalization. Note that it’s always safe to behave as if GC doesn’t exist, and use GetMem/FreeMem, New/Dispose, Create/Free etc. The use of these units simply allows you to also program with garbage collection.

GcTest.dpr & GcTest.exe
———————–
This program contains simple sample code demonstrating the garbage collector in action.

BoehmGC.dll
———–
This contains the implementation of the garbage collector itself. The DLL can be recompiled from the source in gc_dll_src with various options, including multithreaded support, different pointer alignment granularities, etc.

****
The original Boehm GC source comes from: http://www.hpl.hp.com/personal/Hans_Boehm/gc/

I’m Barry Kelly: barry_j_kelly@hotmail.com

You can do anything you like with my source code (*.pas, *.dpr).

See the file gc_dll_src/LICENSEa for permissions for the GC itself.

</barry_j_kelly@hotmail.com>

Although when trying to download, I got this for both cc.embarcadero.com/Download.aspx?id=21646 and cc.embarcadero.com/Download.aspx?id=21646&prot=ftp:

Access to the path ‘\\etnaedndb02.embarcadero.com\f\webcache\cc\2004\4\19\21646.zip’ is denied.

An error has occurred while processing the page.

Please try to refresh the page, or return to the home page.

: ETNACDC04

and [WayBack] Jeroen Pluimers auf Twitter: “It looks like the @EmbarcaderoTech code central file cc.embarcadero.com/Item/21646 is broken: “Access to the path ‘\https://t.co/3f3blXN9mp\f\webcache\cc\2004\4\19\https://t.co/0UJUtWvxVV’ is denied.” when exploring or downloading.…”

Explore the files in this upload

File Exploration is Disabled

We’re sorry, but errors in the uploaded zip file prevent it from being explored.

The error generated by the Zip attachment is:

Access to the path ‘\\etnaedndb02.embarcadero.com\f\webcache\cc\2004\4\19\21646.zip’ is denied.You may still be able to repair the zip file contents if you download the entire zip locally. You may also want to ask the author to repost the attachment.

Via [WayBack] delphi – Reference-counting for objects – Stack Overflow which also points to:

Downloads of stable versions: [WayBack] Download · ivmai/bdwgc Wiki · GitHub

–jeroen

	program GCTest;

	uses
	Forms,
	Main in 'Main.pas' {frmMain},
	stGC in 'stGC.pas',
	SampleGCObjects in 'SampleGCObjects.pas',
	SampleGCThread in 'SampleGCThread.pas',
	stGCFieldFinder in 'stGCFieldFinder.pas',
	SampleGCObjects2 in 'SampleGCObjects2.pas';

	{$R *.res}

	begin
	Application.Initialize;
	Application.CreateForm(TfrmMain, frmMain);
	Application.Run;
	end.

view raw

GCTest.dpr

hosted with ❤ by GitHub

	object frmMain: TfrmMain
	Left = 192
	Top = 116
	Width = 623
	Height = 331
	Caption = 'Garbage Collection Simulation'
	Color = clBtnFace
	Font.Charset = DEFAULT_CHARSET
	Font.Color = clWindowText
	Font.Height = –11
	Font.Name = 'Tahoma'
	Font.Style = []
	OldCreateOrder = False
	PixelsPerInch = 96
	TextHeight = 13
	object btnStart: TButton
	Left = 8
	Top = 8
	Width = 75
	Height = 25
	Caption = 'Start'
	TabOrder = 0
	OnClick = btnStartClick
	end
	object btnStop: TButton
	Left = 8
	Top = 70
	Width = 75
	Height = 25
	Caption = 'Stop'
	Enabled = False
	TabOrder = 1
	OnClick = btnStopClick
	end
	object btnNewThread: TButton
	Left = 8
	Top = 39
	Width = 75
	Height = 25
	Caption = 'New Thread'
	Enabled = False
	TabOrder = 2
	OnClick = btnNewThreadClick
	end
	object StatusBar1: TStatusBar
	Left = 0
	Top = 278
	Width = 615
	Height = 19
	Font.Charset = DEFAULT_CHARSET
	Font.Color = clWindowText
	Font.Height = –11
	Font.Name = 'Tahoma'
	Font.Style = []
	Panels = <
	item
	Width = 100
	end
	item
	Width = 250
	end
	item
	Width = 120
	end
	item
	Width = 100
	end>
	SimplePanel = False
	UseSystemFont = False
	end
	object rgSweepMode: TRadioGroup
	Left = 96
	Top = 8
	Width = 185
	Height = 65
	Caption = 'Sweep Mode'
	ItemIndex = 1
	Items.Strings = (
	'Incremental'
	'Stop the world')
	TabOrder = 4
	end
	object chbNewThreads: TCheckBox
	Left = 296
	Top = 12
	Width = 249
	Height = 17
	Caption = 'Launch new threads automatically'
	Checked = True
	State = cbChecked
	TabOrder = 5
	end
	object rgBlockGranularity: TRadioGroup
	Left = 96
	Top = 79
	Width = 185
	Height = 105
	Hint = 'Set to 8 bytes if caching is disabled'
	Caption = 'Block granularity'
	ItemIndex = 0
	Items.Strings = (
	'8 bytes'
	'16 bytes'
	'32 bytes'
	'64 bytes')
	ParentShowHint = False
	ShowHint = True
	TabOrder = 6
	end
	object rgCacheCapacity: TRadioGroup
	Left = 96
	Top = 190
	Width = 185
	Height = 79
	Caption = 'Instance Cache Capacity'
	ItemIndex = 0
	Items.Strings = (
	'0 (disabled)'
	'100,000'
	'200,000')
	TabOrder = 7
	end
	object gbSampleClasses: TGroupBox
	Left = 296
	Top = 35
	Width = 185
	Height = 105
	Caption = 'Sample Classes'
	TabOrder = 8
	object chbStatic: TCheckBox
	Left = 16
	Top = 21
	Width = 97
	Height = 17
	Caption = 'Static'
	Checked = True
	State = cbChecked
	TabOrder = 0
	end
	object chbDynamic: TCheckBox
	Left = 16
	Top = 44
	Width = 97
	Height = 17
	Caption = 'Dynamic'
	Checked = True
	State = cbChecked
	TabOrder = 1
	end
	object chbConvoluted: TCheckBox
	Left = 16
	Top = 67
	Width = 97
	Height = 17
	Caption = 'Convoluted'
	TabOrder = 2
	end
	end
	object Timer1: TTimer
	Interval = 100
	OnTimer = Timer1Timer
	Left = 504
	Top = 8
	end
	end

view raw

Main.dfm

hosted with ❤ by GitHub

	unit Main;

	interface

	uses
	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
	Dialogs, SampleGCThread, StdCtrls, ComCtrls, AppEvnts, ExtCtrls;

	type
	TfrmMain = class(TForm)
	btnStart: TButton;
	btnStop: TButton;
	btnNewThread: TButton;
	StatusBar1: TStatusBar;
	Timer1: TTimer;
	rgSweepMode: TRadioGroup;
	chbNewThreads: TCheckBox;
	rgBlockGranularity: TRadioGroup;
	rgCacheCapacity: TRadioGroup;
	gbSampleClasses: TGroupBox;
	chbStatic: TCheckBox;
	chbDynamic: TCheckBox;
	chbConvoluted: TCheckBox;
	procedure btnStartClick(Sender: TObject);
	procedure btnStopClick(Sender: TObject);
	procedure btnNewThreadClick(Sender: TObject);
	procedure Timer1Timer(Sender: TObject);
	private
	fSweepThread: tSweepThread;
	fStartTick: Cardinal;
	procedure DisableOptions;
	procedure EnableOptions;
	procedure AbleOptions(aEnable: Boolean);
	public
	{ Public declarations }
	end;

	var
	frmMain: TfrmMain;

	implementation

	uses
	stGC, SampleGCObjects, SampleGCObjects2;

	{$R *.dfm}

	procedure TfrmMain.btnStartClick(Sender: TObject);
	begin
	btnStart.Enabled := False;
	DisableOptions;
	btnNewThread.Enabled := True;
	btnStop.Enabled := True;
	tGCManager.GetDefault.SetUseLocks(rgSweepMode.ItemIndex = 1);
	tSweepThread.NoNewThreads(not chbNewThreads.Checked);
	tSweepThread.EnableStatic(chbStatic.Checked);
	tSweepThread.EnableDynamic(chbDynamic.Checked);
	tSweepThread.EnableConvoluted(chbConvoluted.Checked);
	case rgBlockGranularity.ItemIndex of
	0: tGCManager.GetDefault.SetBlockGranularity(8);
	1: tGCManager.GetDefault.SetBlockGranularity(16);
	2: tGCManager.GetDefault.SetBlockGranularity(32);
	3: tGCManager.GetDefault.SetBlockGranularity(64);
	end;
	case rgCacheCapacity.ItemIndex of
	0: tGCManager.GetDefault.SetCacheCapacity(0);
	1: tGCManager.GetDefault.SetCacheCapacity(100000);
	2: tGCManager.GetDefault.SetCacheCapacity(200000);
	end;
	FreeAndNil(fSweepThread);
	fSweepThread := tSweepThread.Create(False);
	tSweepThread.ResetSampleStepCount;
	fStartTick := GetTickCount;
	tSampleThread.Create(0);
	end;

	procedure TfrmMain.btnStopClick(Sender: TObject);
	begin
	btnNewThread.Enabled := False;
	tSweepThread.TerminateAll(True);
	if Assigned(fSweepThread) then begin
	fSweepThread.Terminate;
	fSweepThread.WaitFor;
	FreeAndNil(fSweepThread);
	end;
	tGCManager.GetDefault.Sweep;
	EnableOptions;
	btnStart.Enabled := True;
	end;

	procedure TfrmMain.DisableOptions;
	begin
	AbleOptions(False);
	end;

	procedure TfrmMain.EnableOptions;
	begin
	AbleOptions(True);
	end;

	procedure TfrmMain.AbleOptions(aEnable: Boolean);
	begin
	rgSweepMode.Enabled := aEnable;
	rgBlockGranularity.Enabled := aEnable;
	rgCacheCapacity.Enabled := aEnable;
	chbNewThreads.Enabled := aEnable;
	gbSampleClasses.Enabled := aEnable;
	chbStatic.Enabled := aEnable;
	chbDynamic.Enabled := aEnable;
	chbConvoluted.Enabled := aEnable;
	end;

	procedure TfrmMain.btnNewThreadClick(Sender: TObject);
	begin
	tSampleThread.Create(0);
	end;

	procedure TfrmMain.Timer1Timer(Sender: TObject);
	begin
	StatusBar1.Panels[0].Text := 'Threads: ' +
	IntToStr(tSweepThread.GetThreadCount) +
	'(' + IntToStr(tSweepThread.GetActiveThreadCount) + ')';
	if Assigned(fSweepThread) then begin
	StatusBar1.Panels[1].Text := 'Sweep Time: ' +
	IntToStr(fSweepThread.MaxTicks) + '/' +
	IntToStr(fSweepThread.AvgTicks) + '/' +
	IntToStr(fSweepThread.LastTicks) +
	' ms (max/avg/last)';
	StatusBar1.Panels[3].Text := 'Steps: ' +
	IntToStr((1000*tSweepThread.GetSampleStepCount) div Integer(GetTickCount – fStartTick)) +
	' steps/s';
	end;
	StatusBar1.Panels[2].Text := 'Instances: ' + IntToStr(tGCManager.GetDefault.ObjectCount);
	end;

	end.

view raw

Main.pas

hosted with ❤ by GitHub

	unit SampleGCObjects;

	interface

	uses
	SysUtils,
	stGC;

	type
	tGCObject = class;

	iGCObject = interface
	['{272BF9CB-790A-41AC-A5F0-E49D8760E601}']
	function GetObject: tGCObject;
	end;

	tGCObjectArray = array of iGCField;

	tGCObject = class(tGCAbstractObject,iGCObject)
	private
	fOwner: iGCField;
	fLock: TMultiReadExclusiveWriteSynchronizer;
	function GetOwner: tGCObject;
	protected
	function FieldToObject(const aField: iGCField): tGCObject;
	procedure ObjectToField(aObject: tGCObject; var aField: iGCField);
	function GetCount: Integer; virtual;
	function GetItems(aIndex: Integer): iGCObject; virtual;
	procedure SetItems(aIndex: Integer; const Value: iGCObject); virtual; abstract;
	{ iGCInternal }
	procedure Lock; override;
	procedure Unlock; override;
	procedure InitializeLock; override;
	procedure FinalizeLock; override;
	{ iGCObject }
	function GetObject: tGCObject;
	public
	constructor CreateOwner(aOwner: tGCObject; out aRef);
	procedure RemoveOwner;
	property Owner: tGCObject read GetOwner;
	property Count: Integer read GetCount;
	property Items[aIndex: Integer]: iGCObject read GetItems write SetItems;
	end;

	tGCObjectWithStaticFields = class(tGCObject)
	private
	fA: iGCField;
	fB: iGCField;
	fC: iGCField;
	procedure SetA(const Value: tGCObject);
	procedure SetB(const Value: tGCObject);
	procedure SetC(const Value: tGCObject);
	function GetA: tGCObject;
	function GetB: tGCObject;
	function GetC: tGCObject;
	protected
	function GetCount: Integer; override;
	function GetItems(aIndex: Integer): iGCObject; override;
	procedure SetItems(aIndex: Integer; const Value: iGCObject); override;
	public
	property A: tGCObject read GetA write SetA;
	property B: tGCObject read GetB write SetB;
	property C: tGCObject read GetC write SetC;
	end;

	tGCObjectWithDynamicFields = class(tGCObject)
	private
	fItems: tGCObjectArray;
	protected
	function GetCount: Integer; override;
	function GetItems(aIndex: Integer): iGCObject; override;
	procedure SetItems(aIndex: Integer; const Value: iGCObject); override;
	{ iGCInternal }
	procedure Lock; override;
	procedure Unlock; override;
	procedure InitializeLock; override;
	procedure FinalizeLock; override;
	public
	procedure AddItem(aItem: iGCObject); overload;
	function AddItem: iGCObject; overload;
	procedure Delete(aIndex: Integer);
	end;

	implementation

	{ tGCObjectWithStaticFields }

	function tGCObjectWithStaticFields.GetA: tGCObject;
	begin
	Result := FieldToObject(fA);
	end;

	function tGCObjectWithStaticFields.GetB: tGCObject;
	begin
	Result := FieldToObject(fB);
	end;

	function tGCObjectWithStaticFields.GetC: tGCObject;
	begin
	Result := FieldToObject(fC);
	end;

	function tGCObjectWithStaticFields.GetCount: Integer;
	begin
	Result := 3 + inherited GetCount;
	end;

	function tGCObjectWithStaticFields.GetItems(aIndex: Integer): iGCObject;
	begin
	case aIndex – inherited GetCount of
	0: Result := FieldToObject(fA);
	1: Result := FieldToObject(fB);
	2: Result := FieldToObject(fC);
	else
	Result := inherited GetItems(aIndex);
	end;
	end;

	procedure tGCObjectWithStaticFields.SetA(const Value: tGCObject);
	begin
	ObjectToField(Value,fA);
	end;

	procedure tGCObjectWithStaticFields.SetB(const Value: tGCObject);
	begin
	ObjectToField(Value,fB);
	end;

	procedure tGCObjectWithStaticFields.SetC(const Value: tGCObject);
	begin
	ObjectToField(Value,fC);
	end;

	procedure tGCObjectWithStaticFields.SetItems(aIndex: Integer;
	const Value: iGCObject);
	var
	lObj: tGCObject;
	begin
	if Assigned(Value) then
	lObj := Value.GetObject
	else
	lObj := nil;
	case aIndex – inherited GetCount of
	0: SetA(lObj);
	1: SetB(lObj);
	2: SetC(lObj);
	end;
	end;

	{ tGCObject }

	constructor tGCObject.CreateOwner(aOwner: tGCObject; out aRef);
	begin
	SafeAssignFieldInterface(aRef,Self);
	SafeAssignFieldInterface(fOwner,aOwner);
	end;

	function tGCObject.FieldToObject(const aField: iGCField): tGCObject;
	begin
	Lock;
	try
	if Assigned(aField) then
	Result := tGCObject(aField.GetInstance)
	else
	Result := nil;
	finally
	Unlock;
	end;
	end;

	procedure tGCObject.FinalizeLock;
	begin
	FreeAndNil(fLock);
	end;

	function tGCObject.GetCount: Integer;
	begin
	Result := 1;
	end;

	function tGCObject.GetItems(aIndex: Integer): iGCObject;
	begin
	Result := nil;
	if aIndex = 0 then begin
	Result := FieldToObject(fOwner);
	end;
	end;

	function tGCObject.GetObject: tGCObject;
	begin
	Result := Self;
	end;

	function tGCObject.GetOwner: tGCObject;
	begin
	Result := FieldToObject(fOwner);
	end;

	procedure tGCObject.InitializeLock;
	begin
	if not GetManager.UseLocks then
	fLock := TMultiReadExclusiveWriteSynchronizer.Create;
	end;

	procedure tGCObject.Lock;
	begin
	if Assigned(fLock) then
	fLock.BeginRead;
	end;

	procedure tGCObject.ObjectToField(aObject: tGCObject; var aField: iGCField);
	begin
	if Assigned(fLock) then
	fLock.BeginWrite;
	try
	SafeAssignFieldInterface(aField,aObject);
	finally
	if Assigned(fLock) then
	fLock.EndWrite;
	end;
	end;

	procedure tGCObject.RemoveOwner;
	begin
	fOwner := nil;
	end;

	procedure tGCObject.Unlock;
	begin
	if Assigned(fLock) then
	fLock.EndRead;
	end;

	{ tGCObjectWithDynamicFields }

	procedure tGCObjectWithDynamicFields.AddItem(aItem: iGCObject);
	var
	lIdx: Integer;
	begin
	fLock.BeginWrite;
	try
	lIdx := Length(fItems);
	SetLength(fItems,lIdx+1);
	if Assigned(aItem) then
	SafeAssignFieldInterface(fItems[lIdx],aItem.GetObject)
	else
	SafeAssignFieldInterface(fItems[lIdx],nil)
	finally
	fLock.EndWrite;
	end;
	end;

	function tGCObjectWithDynamicFields.AddItem: iGCObject;
	var
	lIdx: Integer;
	begin
	fLock.BeginWrite;
	try
	lIdx := Length(fItems);
	SetLength(fItems,lIdx+1);
	Result := tGCObjectWithDynamicFields.CreateOwner(Self,fItems[lIdx]);
	finally
	fLock.EndWrite;
	end;
	end;

	procedure tGCObjectWithDynamicFields.Delete(aIndex: Integer);
	var
	lIdx, lCount: Integer;
	begin
	fLock.BeginWrite;
	try
	lCount := Length(fItems);
	if aIndex < lCount then begin
	for lIdx := aIndex+1 to lCount-1 do
	SafeAssignFieldInterface(fItems[lIdx-1],fItems[lIdx]);
	SetLength(fItems,lCount-1);
	end;
	finally
	fLock.EndWrite;
	end;
	end;

	procedure tGCObjectWithDynamicFields.FinalizeLock;
	begin
	FreeAndNil(fLock);
	end;

	function tGCObjectWithDynamicFields.GetCount: Integer;
	begin
	Lock;
	try
	Result := Length(fItems) + inherited GetCount;
	finally
	Unlock;
	end;
	end;

	function tGCObjectWithDynamicFields.GetItems(aIndex: Integer): iGCObject;
	var
	lBase: Integer;
	begin
	Lock;
	try
	Result := nil;
	lBase := inherited GetCount;
	if aIndex < lBase then
	Result := inherited GetItems(aIndex)
	else if aIndex-lBase < Length(fItems) then
	Result := FieldToObject(fItems[aIndex-lBase])
	else
	Result := nil;
	finally
	Unlock;
	end;
	end;

	procedure tGCObjectWithDynamicFields.InitializeLock;
	begin
	fLock := TMultiReadExclusiveWriteSynchronizer.Create;
	end;

	procedure tGCObjectWithDynamicFields.Lock;
	begin
	fLock.BeginRead;
	end;

	procedure tGCObjectWithDynamicFields.SetItems(aIndex: Integer;
	const Value: iGCObject);
	var
	lObj: tGCObject;
	lLockAlways: Boolean;
	begin
	if Assigned(Value) then
	lObj := Value.GetObject
	else
	lObj := nil;
	lLockAlways := not GetManager.UseLocks;
	if lLockAlways then
	fLock.BeginWrite
	else
	Lock;
	try
	if (aIndex < Length(fItems)) and (aIndex >= 0) then
	SafeAssignFieldInterface(fItems[aIndex],lObj);
	finally
	if lLockAlways then
	fLock.EndWrite
	else
	Unlock;
	end;
	end;

	procedure tGCObjectWithDynamicFields.Unlock;
	begin
	fLock.EndRead;
	end;

	end.

view raw

SampleGCObjects.pas

hosted with ❤ by GitHub

	unit SampleGCObjects2;

	interface

	uses
	Classes, SysUtils,
	stGC, SampleGCObjects;

	type
	tGCStringList = class;

	iGCStringList = interface
	['{738211F8-2E4C-4037-84B9-1D4E654AEE74}']
	function GetList: tGCStringList;
	end;

	tGCStringList = class(TStringList,IUnknown,iGCInternal,iGCField,iGCStringList)
	private
	fObjects: tGCObjectArray;
	fLock: TMultiReadExclusiveWriteSynchronizer;
	protected
	class function FieldToObject(const aField: iGCField): TObject;
	{ TStringList }
	function GetObject(Index: Integer): TObject; override;
	procedure PutObject(Index: Integer; AObject: TObject); override;
	procedure SetCapacity(NewCapacity: Integer); override;
	procedure InsertItem(Index: Integer; const S: string; AObject: TObject); override;
	{ IUnknown }
	function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
	function _AddRef: Integer; stdcall;
	function _Release: Integer; stdcall;
	{ iGCField }
	function GetInstance: TObject;
	function _AddFieldRef: Integer; stdcall;
	function _ReleaseField: Integer; stdcall;
	function iGCField._AddRef = _AddFieldRef;
	function iGCField._Release = _ReleaseField;
	{ iGCInternal }
	procedure FinalizeLock;
	procedure InitializeLock;
	procedure Lock;
	procedure Unlock;
	function iGCInternal._AddRef = _AddFieldRef;
	function iGCInternal._Release = _ReleaseField;
	{ iGCStringList }
	function GetList: tGCStringList;
	public
	constructor Create;
	procedure Delete(Index: Integer); override;
	class function NewInstance: TObject; override;
	procedure FreeInstance; override;
	procedure AfterConstruction; override;
	procedure BeforeDestruction; override;
	end;

	tInnerRec = record
	fObjects: tGCObjectArray;
	fCount: Integer;
	end;

	tInnerArray = array [0..7] of tInnerRec;

	tOuterRec = record
	fStaticList: tInnerArray;
	fDynamicList: array of tInnerRec;
	end;

	tOuterArray = array of tOuterRec;

	tGCConvoluted = class(tGCObject)
	private
	fItems: tOuterArray;
	fCount: Integer;
	fLock: TMultiReadExclusiveWriteSynchronizer;
	procedure Fill;
	protected
	function GetCount: Integer; override;
	function GetItems(aIndex: Integer): iGCObject; override;
	procedure SetItems(aIndex: Integer; const Value: iGCObject); override;
	{ iGCInternal }
	procedure Lock; override;
	procedure Unlock; override;
	procedure InitializeLock; override;
	procedure FinalizeLock; override;
	end;

	implementation

	{ tGCStringList }

	procedure tGCStringList.AfterConstruction;
	begin
	tGCManager.GetGCObject(Self).DoCreate;
	end;

	procedure tGCStringList.BeforeDestruction;
	begin
	tGCManager.GetGCObject(Self).DoDestroy;
	end;

	constructor tGCStringList.Create;
	begin
	tGCManager.GetGCObject(Self).IgnoreFirstAcquire;
	end;

	procedure tGCStringList.Delete(Index: Integer);
	var
	lOldCount, lIdx: Integer;
	begin
	fLock.BeginWrite;
	try
	lOldCount := Count;
	inherited;
	for lIdx := Index+1 to lOldCount – 1 do
	SafeAssignFieldInterface(fObjects[lIdx-1],fObjects[lIdx]);
	fObjects[lOldCount-1] := nil;
	finally
	fLock.EndWrite;
	end;
	end;

	class function tGCStringList.FieldToObject(const aField: iGCField): TObject;
	begin
	if Assigned(aField) then
	Result := aField.GetInstance
	else
	Result := nil;
	end;

	procedure tGCStringList.FinalizeLock;
	begin
	FreeAndNil(fLock);
	end;

	procedure tGCStringList.FreeInstance;
	begin
	tGCManager.GetDefault.GCFreeInstance(Self);
	end;

	function tGCStringList.GetInstance: TObject;
	begin
	Result := Self;
	end;

	function tGCStringList.GetList: tGCStringList;
	begin
	Result := Self;
	end;

	function tGCStringList.GetObject(Index: Integer): TObject;
	begin
	Lock;
	try
	Result := inherited GetObject(Index);
	Result := FieldToObject(fObjects[Index]);
	finally
	Unlock;
	end;
	end;

	procedure tGCStringList.InitializeLock;
	begin
	fLock := TMultiReadExclusiveWriteSynchronizer.Create;
	end;

	procedure tGCStringList.InsertItem(Index: Integer; const S: string;
	AObject: TObject);
	var
	lOldCount, lIdx: Integer;
	lFld: iGCField;
	begin
	fLock.BeginWrite;
	try
	lOldCount := Count;
	lFld := nil;
	if Assigned(AObject) then
	if Supports(AObject,iGCField,lFld) then
	AObject := nil;
	inherited;
	for lIdx := lOldCount – 1 downto Index do
	SafeAssignFieldInterface(fObjects[lIdx+1],fObjects[lIdx]);
	SafeAssignFieldInterface(fObjects[Index],lFld);
	finally
	fLock.EndWrite;
	end;
	end;

	procedure tGCStringList.Lock;
	begin
	fLock.BeginRead;
	end;

	class function tGCStringList.NewInstance: TObject;
	begin
	Result := tGCManager.GetDefault.GCNewInstance(Self);
	end;

	procedure tGCStringList.PutObject(Index: Integer; AObject: TObject);
	var
	lLockAlways: Boolean;
	lFld: iGCField;
	begin
	lLockAlways := not tGCManager.GetDefault.UseLocks;
	if lLockAlways then
	fLock.BeginWrite
	else
	Lock;
	try
	lFld := nil;
	if Supports(AObject,iGCField,lFld) then
	AObject := nil;
	inherited;
	SafeAssignFieldInterface(fObjects[Index],lFld);
	finally
	if lLockAlways then
	fLock.EndWrite
	else
	Unlock;
	end;
	end;

	function tGCStringList.QueryInterface(const IID: TGUID; out Obj): HRESULT;
	const
	E_NOINTERFACE = HResult($80004002);
	begin
	if GetInterface(IID, Obj) then
	Result := 0
	else
	Result := E_NOINTERFACE;
	end;

	procedure tGCStringList.SetCapacity(NewCapacity: Integer);
	var
	lOldCapacity, lIdx: Integer;
	begin
	fLock.BeginWrite;
	try
	lOldCapacity := Capacity;
	inherited SetCapacity(NewCapacity);
	for lIdx := NewCapacity to Length(fObjects) – 1 do
	SafeAssignFieldInterface(fObjects[lIdx],nil);
	SetLength(fObjects,NewCapacity);
	for lIdx := lOldCapacity to NewCapacity – 1 do
	Pointer(fObjects[lIdx]) := nil;
	finally
	fLock.EndWrite;
	end;
	end;

	procedure tGCStringList.Unlock;
	begin
	fLock.EndRead;
	end;

	function tGCStringList._AddFieldRef: Integer;
	begin
	Result := –1;
	end;

	function tGCStringList._AddRef: Integer;
	begin
	Result := tGCManager.GetGCObject(Self).Acquire;
	end;

	function tGCStringList._Release: Integer;
	begin
	Result := tGCManager.GetGCObject(Self).Release;
	end;

	function tGCStringList._ReleaseField: Integer;
	begin
	Result := –1;
	end;

	{ tGCConvoluted }

	procedure tGCConvoluted.Fill;
	var
	I, J, lIdx: Integer;

	procedure FillInnerRec(var aInnerRec: tInnerRec);
	var
	K, L: Integer;
	lList: iGCStringList;
	begin
	SetLength(aInnerRec.fObjects,16);
	aInnerRec.fCount := 16;
	for K := 0 to 15 do begin
	lList := tGCStringList.Create;
	try
	SafeAssignFieldInterface(aInnerRec.fObjects[K],lList.GetList);
	lList.GetList.SetCapacity(16);
	for L := 0 to 15 do begin
	lList.GetList.AddObject(IntToStr(lIdx),nil);
	Inc(lIdx);
	end;
	finally
	lList := nil;
	end;
	end;
	end;

	begin
	lIdx := 0;
	SetLength(fItems,16);
	for I := 0 to Length(fItems) – 1 do begin
	for J := 0 to High(fItems[I].fStaticList) do begin
	FillInnerRec(fItems[I].fStaticList[J]);
	end;
	SetLength(fItems[I].fDynamicList,8);
	for J := 0 to 7 do begin
	FillInnerRec(fItems[I].fDynamicList[J]);
	end;
	end;
	fCount := lIdx;
	end;

	procedure tGCConvoluted.FinalizeLock;
	begin
	FreeAndNil(fLock);
	end;

	function tGCConvoluted.GetCount: Integer;
	begin
	Lock;
	try
	if fCount = 0 then begin
	fLock.BeginWrite;
	try
	if fCount = 0 then Fill;
	finally
	fLock.EndWrite;
	end;
	end;
	Result := fCount;
	finally
	Unlock;
	end;
	end;

	function tGCConvoluted.GetItems(aIndex: Integer): iGCObject;
	var
	I, J, K, L: Integer;
	lObj: TObject;
	begin
	Lock;
	try
	Result := nil;
	if aIndex < GetCount then begin
	L := aIndex mod 16;
	aIndex := aIndex div 16;
	K := aIndex mod 16;
	aIndex := aIndex div 16;
	J := aIndex mod 16;
	I := aIndex div 16;
	if J < 8 then begin
	lObj := fItems[I].fStaticList[J].fObjects[K].GetInstance;
	lObj := tGCStringList(lObj).Objects[L];
	end else begin
	lObj := fItems[I].fDynamicList[J mod 8].fObjects[K].GetInstance;
	lObj := tGCStringList(lObj).Objects[L];
	end;
	Supports(lObj,iGCObject,Result);
	end;
	finally
	Unlock;
	end;
	end;

	procedure tGCConvoluted.InitializeLock;
	begin
	fLock := TMultiReadExclusiveWriteSynchronizer.Create;
	end;

	procedure tGCConvoluted.Lock;
	begin
	fLock.BeginRead;
	end;

	procedure tGCConvoluted.SetItems(aIndex: Integer; const Value: iGCObject);
	var
	I, J, K, L: Integer;
	lObj: TObject;
	lList: iGCField;
	begin
	Lock;
	try
	if aIndex < GetCount then begin
	L := aIndex mod 16;
	aIndex := aIndex div 16;
	K := aIndex mod 16;
	aIndex := aIndex div 16;
	J := aIndex mod 16;
	I := aIndex div 16;
	if J < 8 then begin
	lList := fItems[I].fStaticList[J].fObjects[K];
	end else begin
	lList := fItems[I].fDynamicList[J mod 8].fObjects[K];
	end;
	if Assigned(lList) then begin
	lObj := lList.GetInstance;
	if Assigned(Value) then
	tGCStringList(lObj).Objects[L] := Value.GetObject
	else
	tGCStringList(lObj).Objects[L] := nil;
	end;
	end;
	finally
	Unlock;
	end;
	end;

	procedure tGCConvoluted.Unlock;
	begin
	fLock.EndRead;
	end;

	end.

view raw

SampleGCObjects2.pas

hosted with ❤ by GitHub

	unit SampleGCThread;

	interface

	uses
	Classes, SysUtils, Windows,
	stGC,
	SampleGCObjects, SampleGCObjects2;

	type
	tSampleThread = class(TThread)
	private
	fRoots: array [0..15] of iGCObject;
	fDelay: Integer;
	class procedure AddRandom(aParent, aChild: iGCObject);
	procedure AddRandomAndDoSomething(aParent: iGCObject);
	procedure AddStructure(aParent: iGCObject; aLevel: Integer);
	class procedure DeleteRandom(aObj: iGCObject);
	class function Walk(aObj: iGCObject): iGCObject;
	class procedure ClearGlobalObject(aIndex: Integer);
	procedure ClearRandomGlobalObject;
	class procedure AssignGlobalObject(aIndex: Integer; aObj: iGCObject);
	class function GetGlobalObject(aIndex: Integer): iGCObject;
	function GetOrCreateRandomRoot: iGCObject;
	function GetNewGlobal: iGCObject;
	function GetGlobal: iGCObject;
	function GetNewRandomObject: iGCObject;
	procedure DoSomethingTo(aObj: iGCObject);
	procedure DoCreateThread;
	protected
	procedure Execute; override;
	public
	constructor Create(aDelay: Integer);
	end;

	tSweepThread = class(TThread)
	private
	fMaxTicks: Cardinal;
	fTotTicks: Int64;
	fSweepCount: Cardinal;
	fAvgTicks: Cardinal;
	fLastTicks: Cardinal;
	protected
	class procedure IncrementThreadCount;
	class procedure DecrementThreadCount;
	class function GetTerminateAll: Boolean;
	class function GetNoNewThreads: Boolean;
	procedure SetMaxTicks(aValue: Cardinal);
	procedure Execute; override;
	public
	constructor Create(aCreateSuspended: Boolean);
	property MaxTicks: Cardinal read fMaxTicks;
	property AvgTicks: Cardinal read fAvgTicks;
	property LastTicks: Cardinal read fLastTicks;
	class function GetThreadCount: Integer;
	class function GetActiveThreadCount: Integer;
	class procedure ClearGlobalObjects; virtual;
	class procedure NoNewThreads(aValue: Boolean);
	class procedure TerminateAll(aValue: Boolean = True);
	class procedure EnableStatic(aValue: Boolean);
	class procedure EnableDynamic(aValue: Boolean);
	class procedure EnableConvoluted(aValue: Boolean);
	class function GetSampleStepCount: Integer;
	class procedure ResetSampleStepCount;
	end;

	implementation

	type
	tGlobalObjectRecord = record
	fObj: iGCObject;
	fLock: Boolean; // used in Incremental GC mode
	end;

	var
	gGlobalObjects: array [0..$FFF] of tGlobalObjectRecord;
	gGlobalObjectCount: Integer;
	gThreadCount: Integer;
	gActiveThreadCount: Integer;
	gTerminateAll: Boolean;
	gNoNewThreads: Boolean;
	gLastSweep: Cardinal; // used in Incremental GC mode
	gEnableStatic: Boolean = True;
	gEnableDynamic: Boolean = True;
	gEnableConvoluted: Boolean = True;
	gSampleThreadStep: Integer;

	// used in Incremental GC mode
	function InterlockedExchangeBool(aExpected, aNewValue: Boolean; var aVar: Boolean): Boolean;
	asm
	LOCK CMPXCHG [ECX], DL
	end;

	// used in Incremental GC mode
	procedure LockBool(var aLock: Boolean);
	begin
	while InterlockedExchangeBool(False,True,aLock) do begin
	Sleep(0);
	if not InterlockedExchangeBool(False,True,aLock) then
	Break;
	Sleep(10);
	end;
	end;

	// used in Incremental GC mode
	procedure UnlockBool(var aLock: Boolean);
	begin
	InterlockedExchangeBool(True,False,aLock);
	end;

	procedure TerminateAll(aValue: Boolean);
	begin
	gTerminateAll := aValue;
	end;

	function GetThreadCount: Integer;
	begin
	Result := gThreadCount;
	end;

	procedure ClearGlobalObjects;
	var
	lCount, lIdx: Integer;
	begin
	lCount := High(gGlobalObjects);
	if lCount > gGlobalObjectCount then
	lCount := gGlobalObjectCount;
	gGlobalObjectCount := 0;
	for lIdx := 0 to lCount – 1 do
	SafeClearInterface(gGlobalObjects[lIdx].fObj);
	end;

	procedure NoNewThread(aValue: Boolean);
	begin
	gNoNewThreads := aValue;
	end;

	{ tSampleThread }

	class procedure tSampleThread.AddRandom(aParent, aChild: iGCObject);
	begin
	if Assigned(aParent) and Assigned(aChild) then begin
	if aParent.GetObject is tGCObjectWithStaticFields then
	aParent.GetObject.Items[Random(3)+1] := aChild
	else if aParent.GetObject is tGCObjectWithDynamicFields then
	tGCObjectWithDynamicFields(aParent.GetObject).AddItem(aChild)
	else if aParent.GetObject is tGCConvoluted then
	aParent.GetObject.Items[Random(4096)] := aChild;
	end;
	end;

	procedure tSampleThread.AddRandomAndDoSomething(aParent: iGCObject);
	var
	lObj: iGCObject;
	begin
	if Assigned(aParent) then begin
	if aParent.GetObject is tGCObjectWithDynamicFields then begin
	lObj := tGCObjectWithDynamicFields(aParent.GetObject).AddItem;
	DoSomethingTo(lObj);
	end else begin
	lObj := GetNewRandomObject;
	if Assigned(lObj) then begin
	AddRandom(aParent,lObj);
	DoSomethingTo(lObj);
	end;
	end;
	end;
	end;

	procedure tSampleThread.AddStructure(aParent: iGCObject; aLevel: Integer);
	var
	lObj: iGCObject;
	begin
	while Random(3) > 0 do begin
	if aParent.GetObject is tGCObjectWithDynamicFields then begin
	if Random(2) = 0 then
	lObj := tGCObjectWithDynamicFields(aParent.GetObject).AddItem
	else begin
	lObj := tGCObjectWithStaticFields.Create(gcamFirstAssignment);
	AddRandom(aParent,lObj);
	end;
	end else begin
	if Random(2) = 0 then
	lObj := tGCObjectWithStaticFields.Create(gcamFirstAssignment)
	else
	lObj := tGCObjectWithDynamicFields.Create(gcamFirstAssignment);
	AddRandom(aParent,lObj);
	end;
	if aLevel < 4 then
	AddStructure(lObj,aLevel+1);
	end;
	end;

	class procedure tSampleThread.AssignGlobalObject(aIndex: Integer;
	aObj: iGCObject);
	begin
	if tGCManager.GetDefault.UseLocks then
	SafeAssignInterface(gGlobalObjects[aIndex].fObj,aObj)
	else begin
	LockBool(gGlobalObjects[aIndex].fLock);
	try
	gGlobalObjects[aIndex].fObj := aObj;
	finally
	UnlockBool(gGlobalObjects[aIndex].fLock);
	end;
	end;
	end;

	class procedure tSampleThread.ClearGlobalObject(aIndex: Integer);
	begin
	if tGCManager.GetDefault.UseLocks then
	SafeClearInterface(gGlobalObjects[aIndex].fObj)
	else begin
	LockBool(gGlobalObjects[aIndex].fLock);
	try
	gGlobalObjects[aIndex].fObj := nil;
	finally
	UnlockBool(gGlobalObjects[aIndex].fLock);
	end;
	end;
	end;

	procedure tSampleThread.ClearRandomGlobalObject;
	var
	lIndex: Integer;
	begin
	lIndex := Random(gGlobalObjectCount);
	if lIndex > High(gGlobalObjects) then
	lIndex := Random(High(gGlobalObjects)+1);
	ClearGlobalObject(lIndex);
	end;

	constructor tSampleThread.Create(aDelay: Integer);
	begin
	fDelay := aDelay;
	FreeOnTerminate := True;
	inherited Create(False);
	end;

	class procedure tSampleThread.DeleteRandom(aObj: iGCObject);
	var
	lIdx: Integer;
	begin
	if aObj.GetObject is tGCObjectWithDynamicFields then begin
	lIdx := Random(aObj.GetObject.Count);
	tGCObjectWithDynamicFields(aObj.GetObject).Delete(lIdx);
	end else begin
	lIdx := Random(aObj.GetObject.Count);
	aObj.GetObject.Items[lIdx] := nil;
	end;
	end;

	procedure tSampleThread.DoCreateThread;
	begin
	repeat
	tSampleThread.Create(Random(10000));
	until (GetThreadCount >= 128) or (Random(2) = 0);
	end;

	procedure tSampleThread.DoSomethingTo(aObj: iGCObject);
	begin
	if Assigned(aObj) then
	case Random(16) of
	0: AddRandom(aObj,GetOrCreateRandomRoot);
	1: AddRandom(aObj,GetGlobal);
	2: AddRandom(GetOrCreateRandomRoot,aObj);
	3: AddRandom(GetGlobal,aObj);
	4: AddRandomAndDoSomething(aObj);
	5..8: DoSomethingTo(Walk(aObj));
	9: AddStructure(aObj,0);
	15: aObj.GetObject.RemoveOwner;
	else
	DeleteRandom(aObj);
	end;
	Sleep(1);
	end;

	procedure tSampleThread.Execute;
	var
	lSleepTime: Integer;

	procedure ClearRoots;
	var
	lIdx: Integer;
	begin
	for lIdx := 0 to High(fRoots) do
	fRoots[lIdx] := nil;
	end;
	begin
	InterlockedIncrement(gThreadCount);
	try
	try
	while not Terminated do begin
	if gTerminateAll then
	Terminate
	else if fDelay > 0 then begin
	if fDelay > 100 then begin
	Sleep(100);
	fDelay := fDelay – 100;
	end else begin
	Sleep(fDelay);
	fDelay := 0;
	end;
	end else begin
	lSleepTime := –1;
	InterlockedIncrement(gActiveThreadCount);
	tGCManager.GetDefault.SuspendSweep;
	try
	case Random(1024) of
	0:
	begin
	ClearRoots;
	Terminate;
	if GetThreadCount = 1 then
	Synchronize(DoCreateThread);
	end;
	1..64:
	DoSomethingTo(GetNewGlobal);
	65..256:
	DoSomethingTo(GetGlobal);
	257..512:
	DoSomethingTo(GetOrCreateRandomRoot);
	513..768:
	ClearRandomGlobalObject;
	1023:
	if GetThreadCount < 128 then
	if not gNoNewThreads then
	Synchronize(DoCreateThread);
	else
	lSleepTime := (Random(4) + 1)(Random(2)(Random(2)(Random(2)(Random(2) + 1) + 1) + 1) + 1);
	end;
	finally
	tGCManager.GetDefault.ResumeSweep;
	InterlockedIncrement(gSampleThreadStep);
	InterlockedDecrement(gActiveThreadCount);
	end;
	if lSleepTime >= 0 then
	Sleep(lSleepTime);
	end;
	end;
	finally
	tGCManager.GetDefault.SuspendSweep;
	try
	ClearRoots;
	finally
	tGCManager.GetDefault.ResumeSweep;
	end;
	end;
	finally
	InterlockedDecrement(gThreadCount);
	end;
	end;

	function tSampleThread.GetGlobal: iGCObject;
	var
	lIndex: Integer;
	begin
	lIndex := Random(gGlobalObjectCount) and High(gGlobalObjects);
	Result := GetGlobalObject(lIndex);
	end;

	class function tSampleThread.GetGlobalObject(aIndex: Integer): iGCObject;
	begin
	if tGCManager.GetDefault.UseLocks then
	Result := gGlobalObjects[aIndex].fObj
	else begin
	LockBool(gGlobalObjects[aIndex].fLock);
	try
	Result := gGlobalObjects[aIndex].fObj;
	finally
	UnlockBool(gGlobalObjects[aIndex].fLock);
	end;
	end;
	end;

	function tSampleThread.GetNewGlobal: iGCObject;
	var
	lIndex: Integer;
	begin
	lIndex := InterlockedIncrement(gGlobalObjectCount) and High(gGlobalObjects);
	Result := GetNewRandomObject;
	AssignGlobalObject(lIndex,Result);
	end;

	function tSampleThread.GetNewRandomObject: iGCObject;
	var
	lCount, lRandomMax, lRandom: Integer;
	begin
	// Prevent Out of Memory exceptions:
	if tGCManager.GetDefault.ObjectCount > 1000000 then begin
	lCount := 128;
	while (tGCManager.GetDefault.ObjectCount > 100000) do begin
	Sleep(10);
	if Terminated then Break;
	if gTerminateAll then Break;
	Dec(lCount);
	if lCount = 0 then begin
	ClearRandomGlobalObject;
	Terminate;
	if GetThreadCount = 1 then
	Synchronize(DoCreateThread);
	Break;
	end;
	end;
	end;
	Result := nil;
	if not Terminated then begin
	lRandomMax := 0;
	if gEnableStatic then Inc(lRandomMax,4);
	if gEnableDynamic then Inc(lRandomMax,4);
	if gEnableConvoluted then Inc(lRandomMax);
	lRandom := Random(lRandomMax);
	if gEnableStatic then begin
	if lRandom < 4 then
	Result := tGCObjectWithStaticFields.Create(gcamFirstAssignment)
	else
	Dec(lRandom,4);
	end;
	if (Result = nil) then begin
	if gEnableDynamic and (lRandom < 4) then
	Result := tGCObjectWithDynamicFields.Create(gcamFirstAssignment)
	else
	Result := tGCConvoluted.Create(gcamFirstAssignment);
	end;
	end;
	end;

	function tSampleThread.GetOrCreateRandomRoot: iGCObject;
	var
	lIndex: Integer;
	begin
	lIndex := Random(16);
	Result := fRoots[lIndex];
	if not Assigned(Result) then begin
	Result := GetNewRandomObject;
	fRoots[lIndex] := Result;
	end;
	end;

	class function tSampleThread.Walk(aObj: iGCObject): iGCObject;
	begin
	Result := aObj.GetObject.Items[Random(aObj.GetObject.Count)];
	if Assigned(Result) then
	if Random(2) = 0 then
	Result := Walk(Result);
	end;

	{ tSweepThread }

	class procedure tSweepThread.ClearGlobalObjects;
	begin
	SampleGCThread.ClearGlobalObjects;
	end;

	constructor tSweepThread.Create(aCreateSuspended: Boolean);
	begin
	inherited Create(True);
	Priority := tpHigher;
	if not aCreateSuspended then Resume;
	end;

	class procedure tSweepThread.DecrementThreadCount;
	begin
	InterlockedDecrement(gThreadCount);
	end;

	class procedure tSweepThread.EnableConvoluted(aValue: Boolean);
	begin
	gEnableConvoluted := aValue;
	end;

	class procedure tSweepThread.EnableDynamic(aValue: Boolean);
	begin
	gEnableDynamic := aValue;
	end;

	class procedure tSweepThread.EnableStatic(aValue: Boolean);
	begin
	gEnableStatic := aValue;
	end;

	procedure tSweepThread.Execute;
	var
	lTicks, lLastSweep: Cardinal;
	begin
	TerminateAll(False);
	while not Terminated do begin
	tGCManager.GetDefault.LockBeforeSweep;
	try
	lTicks := GetTickCount;
	tGCManager.GetDefault.Sweep;
	lLastSweep := GetTickCount;
	lTicks := lLastSweep – lTicks;
	finally
	tGCManager.GetDefault.UnlockAfterSweep;
	end;
	gLastSweep := lLastSweep;
	fLastTicks := lTicks;
	if lTicks > fMaxTicks then
	fMaxTicks := lTicks;
	fTotTicks := fTotTicks + lTicks;
	Inc(fSweepCount);
	fAvgTicks := fTotTicks div fSweepCount;
	Sleep(10);
	end;
	TerminateAll();
	while GetThreadCount > 0 do begin
	tGCManager.GetDefault.LockBeforeSweep;
	try
	tGCManager.GetDefault.Sweep;
	finally
	tGCManager.GetDefault.UnlockAfterSweep;
	end;
	Sleep(10);
	end;
	ClearGlobalObjects;
	tGCManager.GetDefault.Sweep;
	if tGCManager.GetDefault.ObjectCount > 0 then begin
	Finalize(gGlobalObjects);
	tGCManager.GetDefault.Sweep;
	end;
	end;

	class function tSweepThread.GetActiveThreadCount: Integer;
	begin
	Result := gActiveThreadCount;
	end;

	class function tSweepThread.GetNoNewThreads: Boolean;
	begin
	Result := gNoNewThreads;
	end;

	class function tSweepThread.GetSampleStepCount: Integer;
	begin
	Result := gSampleThreadStep;
	end;

	class function tSweepThread.GetTerminateAll: Boolean;
	begin
	Result := gTerminateAll;
	end;

	class function tSweepThread.GetThreadCount: Integer;
	begin
	Result := gThreadCount;
	end;

	class procedure tSweepThread.IncrementThreadCount;
	begin
	InterlockedIncrement(gThreadCount);
	end;

	class procedure tSweepThread.NoNewThreads(aValue: Boolean);
	begin
	gNoNewThreads := aValue;
	end;

	class procedure tSweepThread.ResetSampleStepCount;
	begin
	gSampleThreadStep := 0;
	end;

	procedure tSweepThread.SetMaxTicks(aValue: Cardinal);
	begin
	fMaxTicks := aValue;
	end;

	class procedure tSweepThread.TerminateAll(aValue: Boolean);
	begin
	gTerminateAll := aValue;
	end;

	initialization
	Randomize;
	end.

view raw

SampleGCThread.pas

hosted with ❤ by GitHub

	{*******************************************************}
	{ }
	{ StreamSec Security Library for CodeGear Delphi }
	{ Garbage Collection Base Class Unit }
	{ }
	{ Copyright (C) 2009 StreamSec Handelsbolag }
	{ Commercial use requires permission }
	{ }
	{*******************************************************}

	unit stGC;

	interface

	uses
	SysUtils;

	const
	IID_GCFieldBase: TGUID = '{ED2ED4B6-1521-42D4-853B-3F7FA316B682}';

	type
	eGCException = class(Exception);
	eGCUnsupportedClass = class(eGCException);

	tGCManager = class; // forward

	{ Managed fields of managed classes MUST be declared as iGCField. }
	iGCField = interface
	['{ED2ED4B6-1521-42D4-853B-3F7FA316B682}']
	function GetInstance: TObject;
	end;

	{ Any managed class that might hold strong references to other instances of
	any managed class MUST either implement the iGCInternal interface or
	descend from tGCAbstractObject. The tGCManager will use this interface for
	walking reference paths }
	iGCInternal = interface
	['{14D0572A-046A-4158-9F49-B975593F28AA}']
	procedure Lock;
	procedure Unlock;
	procedure InitializeLock;
	procedure FinalizeLock;
	end;

	eGCDestruction = class(eGCException);
	eGCIllegalInstruction = class(eGCException);
	eGCReference = class(eGCException);

	tGCCreateAcquiredMode = (gcamCreateAcquired,gcamFirstAssignment);
	tGCReferenceKind = (gcrkStrong,gcrkWeak);

	tGCAbstractObject = class(TObject,IUnknown,iGCField)
	protected
	procedure CheckReference(var aRef; aKind: tGCReferenceKind = gcrkStrong);
	class function GetManager: tGCManager; virtual;
	{ IUnknown }
	function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
	function _AddRef: Integer; stdcall;
	function _Release: Integer; stdcall;
	{ iGCField }
	function GetInstance: TObject;
	function _AddFieldRef: Integer; stdcall;
	function _ReleaseField: Integer; stdcall;
	function iGCField._AddRef = _AddFieldRef;
	function iGCField._Release = _ReleaseField;
	{ iGCInternal }
	procedure InitializeLock; virtual;
	procedure FinalizeLock; virtual;
	procedure Lock; virtual; abstract;
	procedure Unlock; virtual; abstract;
	public
	{ Use the Create constructor for creating an instance that is directly
	assigned to an external variable.
	* aMode = gcamCreateAcquired: If this mode is used, the Release method
	MUST be called before the variables goes out of scope, even if the
	variable is of an interface type
	* aMode = gcamFirstAssignment: If this mode is used, the first call
	to Acquire or _AddRef will not increment the reference count from the
	initial value of one. If the instance is directly assigned to e.g. an
	interface, the Release method will not have to be called an extra time }
	constructor Create(aMode: tGCCreateAcquiredMode = gcamCreateAcquired);
	procedure AfterConstruction; override;
	procedure BeforeDestruction; override;
	class function NewInstance: TObject; override;
	procedure FreeInstance; override;
	{ Call Acquire when assigning an instance to another external variable.
	Each call to Acquire must be matched by a call to Release }
	function Acquire: Integer;
	{ Each call to Release must be matched by a prior call to CreateAcquired or
	Acquire }
	function Release: Integer;
	end;

	{ The iGCProtected interface must be used internally by the methods of managed
	classes. Use the tGCManager.GetGCObject method for obtaining the iGCObject
	interface of an instance of a managed class. Managed classes SHOULD declare
	wrapper methods with public visibility for Acquire and Release, and MUST
	implement _AddRef and _Release to call Acquire and Release if they support
	interfaces for external use (i.e. except managed fields, which must be
	declared as iGCField). }
	iGCProtected = interface
	function Acquire: Integer;
	function Release: Integer;
	procedure DoCreate;
	procedure DoDestroy;
	procedure IgnoreFirstAcquire;
	end;

	pGCHeader = ^tGCHeader;
	tGCHeader = record
	fVTable: Pointer;
	fRefCount: Integer;
	fNextLive: pGCHeader;
	fNext: pGCHeader;
	end;

	IntPtr = Integer;

	tGCManager = class
	private
	fFirst: pGCHeader;
	fCache: pGCHeader;
	fCacheCapacity: Integer;
	fTempCache: pGCHeader;
	fObjectCount: Integer;
	fLiveObjectCount: Integer;
	fCacheCount: Integer;
	fBlockGranularity: Integer;
	fInSweep: Boolean; // Flag to prevent overlapping calls to Sweep
	fLock: TMultiReadExclusiveWriteSynchronizer;
	fUseLocks: Boolean;
	fNewUseLocks: Boolean;
	fLastLiveObjectCount: Integer;
	procedure GCGetMem(var aObj: pGCHeader; aSize: Integer);
	procedure GCFreeMem(aObj: pGCHeader);
	procedure AddToList(aObj: pGCHeader);
	function Collect(aObj: pGCHeader; aNoRemove: Boolean = False): pGCHeader;
	function SweepMark(aFirst : pGCHeader;
	var aPrevLast : pGCHeader;
	out aFirstUnknown: pGCHeader)
	: Boolean;
	procedure SweepCollect(aFirst,
	aFirstUnknown,
	aPrevLast : pGCHeader;
	out aFirstLive : pGCHeader);
	public
	constructor Create;
	destructor Destroy; override;
	class function GetDefault: tGCManager;
	{ To be called by NewInstance of the garbage collected class }
	function GCNewInstance(aClass: TClass): TObject;
	{ To be called by FreeInstance of the garbage collected class }
	procedure GCFreeInstance(aObject: TObject);
	{ GetGCObject returns a weak reference to a iGCProtected interface
	corresponding to aObj. The aObj instance MUST have been allocated using
	GCNewInstance. GetGCObject should only be called from within methods of
	aObj itself. }
	class function GetGCObject(aObj: TObject): iGCProtected;
	{ Call Sweep to collect unreachable objects }
	procedure Sweep;
	procedure SetCacheCapacity(aNewCapacity: Integer);
	procedure SetBlockGranularity(aNewGranularity: Integer);
	property CacheCapacity: Integer read fCacheCapacity;
	property ObjectCount: Integer read fObjectCount;
	property LiveObjectCount: Integer read fLastLiveObjectCount;
	property UseLocks: Boolean read fUseLocks;
	function SetUseLocks(aUseLocks: Boolean): Boolean;
	procedure SuspendSweep;
	procedure ResumeSweep;
	procedure LockBeforeSweep;
	procedure UnlockAfterSweep;
	end;

	function InterlockedIncrement(var Addend: Integer): Integer;
	function InterlockedDecrement(var Addend: Integer): Integer;

	procedure SafeClearInterface(var aIntf);
	procedure SafeAssignInterface(var aDest; const aSource: IUnknown);
	procedure SafeAssignFieldInterface(var aDest; const aSource: iGCField);

	implementation

	uses
	stGCFieldFinder;

	var
	gDefaultManager: tGCManager;
	gLiveEndMarker: tGCHeader;

	function InterlockedIncrement(var Addend: Integer): Integer;
	asm
	MOV EDX,1
	XCHG EAX,EDX
	LOCK XADD [EDX],EAX
	INC EAX
	end;

	function InterlockedDecrement(var Addend: Integer): Integer;
	asm
	MOV EDX,-1
	XCHG EAX,EDX
	LOCK XADD [EDX],EAX
	DEC EAX
	end;

	function InterlockedExchange(var Dest: Pointer; aSource: Pointer): Pointer;
	asm
	LOCK XCHG [EAX],EDX
	MOV EAX, EDX
	end;

	procedure SafeClearInterface(var aIntf);
	var
	lPtr: Pointer;
	begin
	lPtr := InterlockedExchange(Pointer(aIntf),nil);
	if Assigned(lPtr) then
	IUnknown(lPtr)._Release;
	end;

	procedure SafeAssignInterface(var aDest; const aSource: IUnknown);
	var
	lPtr: Pointer;
	begin
	if Assigned(aSource) then
	aSource._AddRef;
	lPtr := InterlockedExchange(Pointer(aDest),Pointer(aSource));
	if Assigned(lPtr) then
	IUnknown(lPtr)._Release;
	end;

	procedure MarkAsReachable(aInst: pGCHeader);
	asm
	LOCK OR [EAX].tGCHeader.fRefCount,80000000h
	end;

	procedure UnmarkAsReachable(aInst: pGCHeader);
	asm
	LOCK AND [EAX].tGCHeader.fRefCount,7fffffffh
	end;

	function GCHeaderToObject(aInst: pGCHeader): TObject;
	begin
	Result := Pointer(IntPtr(aInst) + SizeOf(tGCHeader));
	end;

	function ObjectToGCHeader(aObj: TObject): pGCHeader;
	begin
	Result := Pointer(IntPtr(aObj) – SizeOf(tGCHeader));
	end;

	const
	cRefCountMask = $3FFFFFFF;

	type
	tGCProtectedImpl = (gcpiConstructor,
	gcpiFieldConstructor,
	gcpiFirstAssignment,
	gcpiNormal,
	gcpiCollecting);

	procedure SwitchGCProtected(aInst: pGCHeader; aImpl: tGCProtectedImpl); forward;

	procedure MarkAsCollecting(aInst: pGCHeader);
	begin
	SwitchGCProtected(aInst,gcpiCollecting);
	end;

	function IsCollecting(aInst: pGCHeader): Boolean; forward;

	function ResetFirstAssignment(aInst: pGCHeader): Boolean; forward;

	{ iGCProtected methods }

	function GCProtected_AddRef(aInst: Pointer): Integer; stdcall;
	begin
	Result := –1;
	end;

	function GCProtected_Release(aInst: Pointer): Integer; stdcall;
	begin
	Result := –1;
	end;

	function GCProtectedAcquire(aInst: pGCHeader): Integer;
	begin
	Result := InterlockedIncrement(aInst.fRefCount) and cRefCountMask;
	if Result = 0 then
	raise eGCException.Create('Reference count overflow – unrecoverable');
	end;

	function GCProtectedFirAcquire(aInst: pGCHeader): Integer;
	begin
	if ResetFirstAssignment(aInst) then
	Result := aInst.fRefCount and cRefCountMask
	else
	Result := GCProtectedAcquire(AInst);
	end;

	function GCProtectedColAcquire(aInst: pGCHeader): Integer;
	begin
	raise eGCIllegalInstruction.Create('Object has already been collected');
	end;

	function GCProtectedRelease(aInst: pGCHeader): Integer;
	begin
	Result := InterlockedDecrement(aInst.fRefCount) and cRefCountMask;
	if Result = cRefCountMask then
	raise eGCException.Create('Reference count underflow – unrecoverable');
	{ A reference count underflow occurs if Release or _Release is called one
	time too much. When dealing with class instance references, make sure the
	number of calls to Create(gcamCreateAcquired) and Acquired match the
	number of calls to Release. When dealing with interfaces, beware that
	any assignment to interface variables that are accessible to multiple
	threads must be locked. For instance, two threads assigning to the same
	global interface variable at the same time, might cause _Release to be
	called twice on the instance that was previously assigned to the variable.
	Use the SafeClearInterface and SafeAssignInterface routines as a work
	around. }
	end;

	function GCProtectedColRelease(aInst: pGCHeader): Integer;
	begin
	raise eGCIllegalInstruction.Create('Object has already been collected');
	end;

	function GCProtectedtQueryInterface(aInst: Pointer; const IID: TGUID; out Obj): HResult; stdcall;
	const
	E_NOINTERFACE = HResult($80004002);
	begin
	Result := E_NOINTERFACE;
	end;

	procedure GCProtectedColAssignToField(aInst: pGCHeader; out aRef);
	begin
	raise eGCIllegalInstruction.Create('Object has already been collected');
	end;

	procedure GCProtectedDoCreate(aInst: pGCHeader);
	begin
	raise eGCIllegalInstruction.Create('DoCreate MUST ONLY be called in AfterConstruction');
	end;

	procedure GCProtectedFieDoCreate(aInst: pGCHeader);
	begin
	InterlockedDecrement(aInst.fRefCount); // Assigned to external field in constructor
	SwitchGCProtected(aInst,gcpiNormal);
	end;

	procedure GCProtectedFirDoCreate(aInst: pGCHeader);
	begin
	// Do nothing, switch in first Acquire
	end;

	procedure GCProtectedConDoCreate(aInst: pGCHeader);
	begin
	SwitchGCProtected(aInst,gcpiNormal); // Created acquired
	end;

	procedure GCProtectedColDoCreate(aInst: pGCHeader);
	begin
	raise eGCIllegalInstruction.Create('Object has already been collected');
	end;

	procedure GCProtectedDoDestroy(aInst: pGCHeader);
	begin
	// Allow destruction only if the constructor failed or called by Collect
	raise eGCDestruction.Create('This instance cannot be destroyed');
	end;

	procedure GCProtectedConDoDestroy(aInst: pGCHeader);
	begin
	// Allow destruction only if the constructor failed or called by Collect
	end;

	procedure GCProtectedColDoDestroy(aInst: pGCHeader);
	begin
	// Allow destruction only if the constructor failed or called by Collect
	end;

	procedure GCProtectedIgnoreFirstAcquire(aInst: pGCHeader);
	begin
	raise eGCIllegalInstruction.Create('IgnoreFirstAcquire can only be called from constructor');
	end;

	procedure GCProtectedConIgnoreFirstAcquire(aInst: pGCHeader);
	begin
	SwitchGCProtected(aInst,gcpiFirstAssignment);
	end;

	type
	tVTable = array[0..7] of Pointer;
	pVTableEx = ^tVTableEx;
	tVTableEx = record
	fVTable: tVTable;
	fUseLock: Boolean;
	end;

	const
	GCProtected_Vtable: tVTable =
	(
	@GCProtectedtQueryInterface,
	@GCProtected_AddRef,
	@GCProtected_Release,
	@GCProtectedAcquire,
	@GCProtectedRelease,
	@GCProtectedDoCreate,
	@GCProtectedDoDestroy,
	@GCProtectedIgnoreFirstAcquire
	);

	GCProtectedField_Vtable: tVTable =
	(
	@GCProtectedtQueryInterface,
	@GCProtected_AddRef,
	@GCProtected_Release,
	@GCProtectedAcquire,
	@GCProtectedRelease,
	@GCProtectedFieDoCreate, // <–
	@GCProtectedDoDestroy,
	@GCProtectedIgnoreFirstAcquire
	);

	GCProtectedFirstAssignment_Vtable: tVTable =
	(
	@GCProtectedtQueryInterface,
	@GCProtected_AddRef,
	@GCProtected_Release,
	@GCProtectedFirAcquire, // <–
	@GCProtectedRelease,
	@GCProtectedFirDoCreate, // <–
	@GCProtectedDoDestroy,
	@GCProtectedIgnoreFirstAcquire
	);

	GCProtectedConstructor_Vtable: tVTable =
	(
	@GCProtectedtQueryInterface,
	@GCProtected_AddRef,
	@GCProtected_Release,
	@GCProtectedAcquire,
	@GCProtectedRelease,
	@GCProtectedConDoCreate, // <–
	@GCProtectedConDoDestroy, // <–
	@GCProtectedConIgnoreFirstAcquire // <–
	);

	GCProtectedCollecting_Vtable: tVTable =
	(
	@GCProtectedtQueryInterface,
	@GCProtected_AddRef,
	@GCProtected_Release,
	@GCProtectedColAcquire, // <–
	@GCProtectedColRelease, // <–
	@GCProtectedColDoCreate, // <–
	@GCProtectedColDoDestroy, // <–
	@GCProtectedIgnoreFirstAcquire
	);

	procedure SwitchGCProtected(aInst: pGCHeader; aImpl: tGCProtectedImpl);
	begin
	case aImpl of
	gcpiConstructor:
	aInst.fVTable := @GCProtectedConstructor_Vtable;
	gcpiFieldConstructor:
	aInst.fVTable := @GCProtectedField_Vtable;
	gcpiFirstAssignment:
	aInst.fVTable := @GCProtectedFirstAssignment_Vtable;
	gcpiNormal:
	aInst.fVTable := @GCProtected_VTable;
	gcpiCollecting:
	aInst.fVTable := @GCProtectedCollecting_Vtable;
	end;
	end;

	procedure SafeAssignFieldInterface(var aDest; const aSource: iGCField);
	var
	lInst: pGCHeader;
	begin
	Pointer(aDest) := Pointer(aSource);
	if Assigned(aSource) then begin
	lInst := ObjectToGCHeader(aSource.GetInstance);
	if lInst.fVTable = @GCProtectedConstructor_Vtable then
	SwitchGCProtected(lInst,gcpiFieldConstructor);
	MarkAsReachable(lInst);
	end;
	end;

	function IsCollecting(aInst: pGCHeader): Boolean;
	begin
	Result := (aInst.fVTable <> @GCProtected_Vtable) and
	(aInst.fVTable <> @GCProtectedField_Vtable) and
	(aInst.fVTable <> @GCProtectedFirstAssignment_Vtable) and
	(aInst.fVTable <> @GCProtectedConstructor_Vtable);
	end;

	function IsCreating(aInst: pGCHeader): Boolean;
	begin
	Result := aInst.fVTable = @GCProtectedConstructor_Vtable;
	end;

	function IsReachable(aInst: pGCHeader): Boolean;
	begin
	Result := aInst.fRefCount <> 0;
	end;

	function Islive(aInst: pGCHeader): Boolean;
	begin
	Result := Assigned(aInst.fNextLive);
	end;

	function ResetFirstAssignment(aInst: pGCHeader): Boolean;
	asm
	MOV ECX, EAX
	LEA EAX, GCProtectedFirstAssignment_Vtable
	LEA EDX, GCProtected_Vtable
	LOCK CMPXCHG [ECX],EDX
	JE @@Equal
	XOR EAX, EAX
	RET
	@@Equal:
	MOV EAX,1
	end;

	type
	pGCInternalRec = ^tGCInternalRec;
	tGCInternalRec = record
	fVTable: Pointer;
	fInst: tGCAbstractObject;
	end;

	procedure GCInternalLock(aLock: pGCInternalRec);
	begin
	aLock.fInst.Lock;
	end;

	procedure GCInternalUnlock(aLock: pGCInternalRec);
	begin
	aLock.fInst.Unlock;
	end;

	procedure GCInternalInitializeLock(aLock: pGCInternalRec);
	begin
	aLock.fInst.InitializeLock;
	end;

	procedure GCInternalFinalizeLock(aLock: pGCInternalRec);
	begin
	aLock.fInst.FinalizeLock;
	end;

	const
	GCInternal_Vtable: array[0..6] of Pointer =
	(
	@GCProtectedtQueryInterface,
	@GCProtected_AddRef,
	@GCProtected_Release,
	@GCInternalLock,
	@GCInternalUnlock,
	@GCInternalInitializeLock,
	@GCInternalFinalizeLock
	);

	function MakeGCInternal(aObj: TObject; var aRec: tGCInternalRec): iGCInternal;
	begin
	if aObj.InheritsFrom(tGCAbstractObject) then begin
	aRec.fVTable := @GCInternal_Vtable;
	aRec.fInst := tGCAbstractObject(aObj);
	Pointer(Result) := @aRec;
	end else begin
	Result := nil;
	if not aObj.GetInterface(iGCInternal,Result) then
	Result := nil;
	end;
	end;

	procedure AddToList(aObj: pGCHeader; var aFirst: pGCHeader);
	asm
	// Thread safe
	MOV ECX, EAX
	MOV EAX, [EDX]
	@@1 :
	MOV [ECX].tGCHeader.fNext, EAX
	LOCK CMPXCHG [EDX], ECX
	JNZ @@1
	end;

	function RemoveFirstFromList(aObj: pGCHeader; var aFirst: pGCHeader): pGCHeader; overload;
	asm
	// Thread safe
	MOV ECX, [EAX].tGCHeader.fNext
	LOCK CMPXCHG [EDX], ECX
	end;

	function RemoveFirstFromList(var aFirst: pGCHeader): pGCHeader; overload;
	asm
	// Thread safe
	MOV ECX, EAX
	MOV EAX, [ECX]
	@@1:
	TEST EAX, EAX
	JZ @@Exit
	MOV EDX, [EAX].tGCHeader.fNext
	LOCK CMPXCHG [ECX], EDX
	JNZ @@1
	@@Exit:
	end;

	function ExtractList(var aFirst: pGCHeader): pGCHeader;
	asm
	// Thread safe
	XOR EDX, EDX
	LOCK XCHG [EAX],EDX
	MOV EAX, EDX
	end;

	function RemoveFromList(aObj: pGCHeader; var aFirst: pGCHeader): pGCHeader;
	var
	lNext: pGCHeader;
	begin
	Result := aObj.fNext;
	{ Called from a single thread. As long as aObj isn't gFirst, no locking is
	required. It is also assumed that aObj is in fact somewhere on the list.
	}
	lNext := RemoveFirstFromList(aObj,aFirst);
	if lNext <> aObj then begin
	while lNext.fNext <> aObj do
	lNext := lNext.fNext;
	lNext.fNext := Result;
	end;
	end;

	function MarkInSweep(aExpected, aNewValue: Boolean; var aInSweep: Boolean): Boolean;
	asm
	LOCK CMPXCHG [ECX], DL
	end;

	procedure MarkReferenced(aInst: pGCHeader);
	var
	lRec: tGCInternalRec;
	lIntf: iGCInternal;
	lNext: pGCHeader;
	lLastLive: pGCHeader;

	function MarkAsLive(aObj: pGCHeader): Boolean;
	begin
	Result := Assigned(aObj.fNextLive);
	if not Result then begin
	aObj.fNextLive := lLastLive.fNextLive;
	lLastLive.fNextLive := aObj;
	lLastLive := aObj;
	end;
	end;

	begin
	lLastLive := @gLiveEndMarker;
	gLiveEndMarker.fNextLive := lLastLive;
	if Assigned(aInst) and not MarkAsLive(aInst) then begin
	lNext := aInst;
	while lNext <> @gLiveEndMarker do begin
	if IsCollecting(lNext) then
	raise eGCException.Create('Live reference to collected object – check your code');
	lIntf := MakeGCInternal(GCHeaderToObject(lNext),lRec);
	lIntf.Lock;
	try
	tGCFieldDefinitions.GetFields(GCHeaderToObject(lNext),lLastLive);
	finally
	lIntf.Unlock;
	end;
	lNext := lNext.fNextLive;
	end;
	end;
	end;

	{ tGCManager }

	procedure tGCManager.AddToList(aObj: pGCHeader);
	begin
	stGC.AddToList(aObj,fFirst);
	end;

	function tGCManager.Collect(aObj: pGCHeader; aNoRemove: Boolean): pGCHeader;
	begin
	if aNoRemove then
	Result := aObj.fNext
	else
	// Return the value of the next item in the linked list
	// This return value is used by the Sweep procedure
	Result := RemoveFromList(aObj,fFirst);
	aObj.fNext := nil;
	aObj.fNextLive := nil;
	MarkAsCollecting(aObj);
	GCHeaderToObject(aObj).Destroy;
	end;

	constructor tGCManager.Create;
	begin
	fBlockGranularity := 32;
	fLock := TMultiReadExclusiveWriteSynchronizer.Create;
	end;

	destructor tGCManager.Destroy;
	begin
	fLock.Free;
	inherited;
	end;

	procedure tGCManager.GCFreeInstance(aObject: TObject);
	var
	lRec: tGCInternalRec;
	lInt: iGCInternal;
	begin
	{ If destroyed by constructor failure, unmark
	If destroyed by Sweep, Collect }
	if IsCreating(ObjectToGCHeader(aObject)) then begin
	UnmarkAsReachable(ObjectToGCHeader(aObject));
	SwitchGCProtected(ObjectToGCHeader(aObject),gcpiNormal);
	InterlockedDecrement(ObjectToGCHeader(aObject).fRefCount);
	end else begin
	lInt := MakeGCInternal(aObject,lRec);
	lInt.FinalizeLock;
	lInt := nil;
	tGCFieldDefinitions.Cleanup(aObject);
	aObject.CleanupInstance;
	GCFreeMem(ObjectToGCHeader(aObject));
	end;
	end;

	procedure tGCManager.GCFreeMem(aObj: pGCHeader);
	begin
	// GCFreeMem is ONLY called within the context of Sweep
	if fCacheCount < fCacheCapacity then begin
	aObj.fNext := fTempCache;
	fTempCache := aObj;
	Inc(fCacheCount);
	end else begin
	System.FreeMem(aObj);
	InterlockedDecrement(fObjectCount);
	end;
	end;

	procedure tGCManager.GCGetMem(var aObj: pGCHeader; aSize: Integer);

	function RoundUpSize(aSize: Integer): Integer;
	begin
	Result := aSize – (aSize mod fBlockGranularity);
	if Result < aSize then
	Result := Result + fBlockGranularity;
	end;

	begin
	aObj := nil;
	if fCacheCapacity >= 0 then begin
	aObj := RemoveFirstFromList(fCache);
	end;
	if Assigned(aObj) then begin
	if not IsCollecting(aObj) then
	raise eGCException.Create('Internal');
	System.ReallocMem(aObj,RoundUpSize(aSize));
	end else begin
	System.GetMem(aObj,RoundUpSize(aSize));
	InterlockedIncrement(fObjectCount);
	end;
	end;

	function tGCManager.GCNewInstance(aClass: TClass): TObject;
	var
	lObj: pGCHeader;
	lRec: tGCInternalRec;
	begin
	if aClass.InheritsFrom(tGCAbstractObject) or
	Assigned(aClass.GetInterfaceEntry(iGCInternal)) then begin
	GCGetMem(lObj,aClass.InstanceSize + SizeOf(tGCHeader));
	Assert(Assigned(lObj));
	Result := aClass.InitInstance(GCHeaderToObject(lObj));
	Assert(Assigned(Result));
	lObj.fVTable := @GCProtectedConstructor_Vtable;
	lObj.fRefCount := 1;
	lObj.fNextLive := nil;
	MakeGCInternal(Result,lRec).InitializeLock;
	AddToList(lObj);
	end else
	raise eGCUnsupportedClass.CreateFmt('Class %s is not supported',[aClass.ClassName]);
	end;

	class function tGCManager.GetDefault: tGCManager;
	begin
	Result := gDefaultManager;
	end;

	class function tGCManager.GetGCObject(aObj: TObject): iGCProtected;
	begin
	Pointer(Result) := ObjectToGCHeader(aObj);
	end;

	procedure tGCManager.LockBeforeSweep;
	begin
	if fUseLocks then
	fLock.BeginWrite;
	end;

	procedure tGCManager.ResumeSweep;
	begin
	if fUseLocks then
	fLock.EndRead;
	end;

	procedure tGCManager.SetBlockGranularity(aNewGranularity: Integer);
	begin
	if aNewGranularity > 8 then
	fBlockGranularity := aNewGranularity
	else
	fBlockGranularity := 8;
	end;

	procedure tGCManager.SetCacheCapacity(aNewCapacity: Integer);
	begin
	if aNewCapacity > 0 then
	fCacheCapacity := aNewCapacity
	else
	fCacheCapacity := 0;
	end;

	function tGCManager.SetUseLocks(aUseLocks: Boolean): Boolean;
	begin
	Result := True;
	if aUseLocks then begin
	if fObjectCount = 0 then begin
	fNewUseLocks := True;
	fUseLocks := True;
	end else
	Result := False;
	end else
	fNewUseLocks := False;
	end;

	procedure tGCManager.SuspendSweep;
	begin
	if fUseLocks then
	fLock.BeginRead;
	end;

	procedure tGCManager.Sweep;
	var
	lFirst, lNext,
	lPrevLast, lFirstUnknown, lFirstLive: pGCHeader;

	begin
	if MarkInSweep(False,True,fInSweep) then Exit;
	try
	{ Any objects added to the list will probably stay alive for the duration of
	of Sweep. Get the value of gFirst once and stick to it }
	lFirst := fFirst;
	// Mark roots and references, first attempt
	fLiveObjectCount := 0;
	lNext := lFirst;
	Assert(Assigned(GCHeaderToObject(lNext)));
	lPrevLast := nil;
	while Assigned(lNext) do begin
	Assert(not IsCollecting(lNext));
	Inc(fLiveObjectCount);
	if IsReachable(lNext) then
	MarkReferenced(lNext)
	else if not Islive(lNext) then
	lPrevLast := lNext;
	lNext := lNext.fNext;
	Assert(Assigned(GCHeaderToObject(lNext)));
	end;
	// Mark
	if SweepMark(lFirst,lPrevLast,lFirstUnknown) then begin
	// Collect
	SweepCollect(lFirst,lFirstUnknown,lPrevLast,lFirstLive);
	end else
	lFirstLive := lFirst;
	// Reset all that are left
	if fUseLocks then
	lNext := lFirstLive
	else
	lNext := fFirst;
	fLiveObjectCount := 0;
	while Assigned(lNext) do begin
	Assert(not IsCollecting(lNext));
	Inc(fLiveObjectCount);
	UnmarkAsReachable(lNext);
	lNext.fNextLive := nil;
	lNext := lNext.fNext;
	end;
	fLastLiveObjectCount := fLiveObjectCount;
	finally
	MarkInSweep(True,False,fInSweep);
	end;
	end;

	procedure tGCManager.SweepCollect(aFirst, aFirstUnknown, aPrevLast: pGCHeader;
	out aFirstLive: pGCHeader);
	var
	lNext, lLast: pGCHeader;

	procedure AcquireCache;
	var
	lNext: pGCHeader;
	begin
	fTempCache := ExtractList(fCache);
	fCacheCount := fObjectCount – fLiveObjectCount;
	while fCacheCount > fCacheCapacity do begin
	lNext := fTempCache;
	if lNext = nil then Break;
	fTempCache := lNext.fNext;
	GCFreeMem(lNext);
	Dec(fCacheCount);
	end;
	end;

	procedure ReleaseCache;
	begin
	fCache := fTempCache;
	end;

	begin
	AcquireCache;
	{ Collect unmarked and find first marked live object
	Only dead objects are unmarked and they will all be in the run
	aFirstUnknown > … > aPrevLast
	}
	if Assigned(aPrevLast) then
	lLast := aPrevLast.fNext
	else
	lLast := nil;
	if (aFirst = aFirstUnknown) then
	aFirstLive := lLast
	else
	aFirstLive := aFirst;
	// Collect lFirstUnknown, locked
	if Assigned(aFirstUnknown) then begin
	if Assigned(aFirstUnknown) then
	lNext := aFirstUnknown.fNext
	else
	lNext := nil;
	Assert(not (Assigned(lLast) and not Assigned(lNext)));
	Assert(not IsReachable(aFirstUnknown));
	Assert(not IsLive(aFirstUnknown));
	Assert(not IsCollecting(aFirstUnknown));
	aFirstUnknown.fNext := lLast;
	Collect(aFirstUnknown,False);
	// Collect all except lFirstUnknown, unlocked
	while lNext <> lLast do begin
	Assert(not IsReachable(lNext));
	Assert(not IsLive(lNext));
	Assert(not IsCollecting(lNext));
	lNext := Collect(lNext,True);
	end;
	end;
	ReleaseCache;
	end;

	function tGCManager.SweepMark(aFirst : pGCHeader;
	var aPrevLast : pGCHeader;
	out aFirstUnknown: pGCHeader)
	: Boolean;
	var
	lFound: Boolean;
	lNext, lLast, lPrev: pGCHeader;

	procedure SwapInMarkAndSweep(var aCurrent : pGCHeader;
	aPrev : pGCHeader;
	var aDestPrev: pGCHeader;
	aDestNext: pGCHeader);
	begin
	{ In: O1(aDestPrev) > O2(aDestNext) > … > O3(aPrev) > 04(aCurrent) > O5
	Out: O1 > O4(aDestPrev) > O2(aDestNext) > … > O3(aCurrent) > O5
	Live: O3, O2 – Dead?: O4, O1 }
	aPrev.fNext := aCurrent.fNext;
	aDestPrev.fNext := aCurrent;
	aCurrent.fNext := aDestNext;
	aDestPrev := aCurrent;
	aCurrent := aPrev;
	end;

	begin
	{ Mark and sweep with a nested iteration and recursion.
	The idea behind this algorithm is to make sure that we reach any reachable
	instance, even if any references to it are changed while the sweep is
	running. The only way a reachable instance might evade a single iteration
	of the Mark and Sweep, would be if the instance becomes either a root or a
	field of an already visited instance before the instance that previously
	held a reference to the instance is visited. If that happens, either
	the root flag or the field flag of the evasive instance will be modified,
	and that is what the outer iteration is meant to suck up }
	aFirstUnknown := aFirst;
	repeat
	if Assigned(aPrevLast) then
	lLast := aPrevLast.fNext
	else
	lLast := nil;
	lFound := False;
	Result := False;
	lNext := aFirstUnknown;
	aPrevLast := nil;
	lPrev := nil;
	while lNext <> lLast do begin
	if IsLive(lNext) then begin
	lPrev := lNext;
	end else begin
	if IsReachable(lNext) then begin
	lFound := True;
	MarkReferenced(lNext);
	lPrev := lNext;
	end else begin
	// lNext is a potentially dead object
	if Assigned(aPrevLast) and (aPrevLast.fNext <> lNext) then begin
	{ The trail of the first run of potentially dead objects has been
	found and lNext is beyond it. Move it back. Most objects in the
	entire list are probably live, and this can be done lock-lessly,
	so on average this is an optimization }
	Assert(Assigned(aFirstUnknown) and Assigned(lPrev) and
	(lPrev.fNext = lNext));
	SwapInMarkAndSweep(lNext,lPrev,aPrevLast,aPrevLast.fNext);
	end else begin
	{ When done, aFirstUnknown > … > aPrevLast will point to the
	head and trail of the first run of potentially dead objects }
	if not Assigned(aPrevLast) then begin
	aFirstUnknown := lNext;
	Result := True;
	end;
	aPrevLast := lNext;
	end;
	end;
	end;
	lNext := lNext.fNext;
	end;
	if not fUseLocks then
	repeat
	lLast := aFirst;
	aFirst := fFirst;
	lNext := aFirst;
	while lNext <> lLast do begin
	if not IsLive(lNext) then
	if IsReachable(lNext) then begin
	lFound := True;
	MarkReferenced(lNext);
	end;
	lNext := lNext.fNext;
	end;
	until aFirst = fFirst;
	until not lFound;
	end;

	procedure tGCManager.UnlockAfterSweep;
	begin
	if fUseLocks then begin
	if not fNewUseLocks then
	fUseLocks := False;
	fLock.EndWrite;
	end;
	end;

	{ tGCAbstractObject }

	function tGCAbstractObject.Acquire: Integer;
	begin
	Result := tGCManager.GetGCObject(Self).Acquire;
	end;

	procedure tGCAbstractObject.AfterConstruction;
	begin
	tGCManager.GetGCObject(Self).DoCreate;
	end;

	procedure tGCAbstractObject.BeforeDestruction;
	begin
	tGCManager.GetGCObject(Self).DoDestroy;
	end;

	procedure tGCAbstractObject.CheckReference(var aRef;
	aKind: tGCReferenceKind);
	var
	lObj: TObject;
	begin
	lObj := TObject(aRef);
	if Assigned(lObj) then
	if IsCollecting(ObjectToGCHeader(lObj)) then begin
	TObject(aRef) := nil;
	if aKind = gcrkStrong then begin
	if IsCollecting(ObjectToGCHeader(Self)) then
	raise eGCReference.Create('Strong reference from collected object to collected object – check your code')
	else
	raise eGCReference.Create('Strong reference to collected object – check your code');
	end;
	end;
	end;

	constructor tGCAbstractObject.Create(aMode: tGCCreateAcquiredMode);
	begin
	if aMode = gcamFirstAssignment then
	tGCManager.GetGCObject(Self).IgnoreFirstAcquire;
	end;

	procedure tGCAbstractObject.FinalizeLock;
	begin
	end;

	procedure tGCAbstractObject.FreeInstance;
	begin
	GetManager.GCFreeInstance(Self);
	end;

	function tGCAbstractObject.GetInstance: TObject;
	begin
	Result := Self;
	end;

	class function tGCAbstractObject.GetManager: tGCManager;
	begin
	// Result := tGCManager.GetDefault;
	Result := gDefaultManager;
	end;

	procedure tGCAbstractObject.InitializeLock;
	begin

	end;

	class function tGCAbstractObject.NewInstance: TObject;
	begin
	Result := GetManager.GCNewInstance(Self);
	end;

	function tGCAbstractObject.QueryInterface(const IID: TGUID; out Obj): HResult;
	const
	E_NOINTERFACE = HResult($80004002);
	begin
	if GetInterface(IID, Obj) then
	Result := 0
	else
	Result := E_NOINTERFACE;
	end;

	function tGCAbstractObject.Release: Integer;
	begin

	Mike Verhagen on geerlingguy/my-backup-plan: Ho…
	Attila Kovacs on docs.embarcadero.com unreachab…
	David Blue on MacOS: converting a man page t…
	jpluimers on How do I pretty-print JSON in…
	jpluimers on Delphi 10.2 Tokyo Godzilla ISO…

The Wiert Corner – irregular stream of stuff

Jeroen W. Pluimers on .NET, C#, Delphi, databases, and personal interests

Subscribe

Archives

Recent Comments

Recent Posts

Blog Stats

Meta title

Tag Cloud Title

Top Clicks

Top Posts

My badges

Twitter Updates

My Flickr Stream

Pages

All categories

Email Subscription

A garbage collector for C and C++ (and a wrapper for Delphi): The Boehm-Demers-Weiser conservative C/C++ Garbage Collector

Access to the path ‘\\etnaedndb02.embarcadero.com\f\webcache\cc\2004\4\19\21646.zip’ is denied.

Explore the files in this upload

File Exploration is Disabled