Skip to content

Instantly share code, notes, and snippets.

@jpluimers

jpluimers/GCTest.dpr

Created January 23, 2019 20:57
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save jpluimers/a50cef330a74922e002d3f13d3e1b1a7 to your computer and use it in GitHub Desktop.
Save jpluimers/a50cef330a74922e002d3f13d3e1b1a7 to your computer and use it in GitHub Desktop.
Download ZIP
CC#26716: Native Precise Tracking Garbage Collector: https://cc.embarcadero.com/Item/26716
Raw
GCTest.dpr
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.
Raw
Main.dfm
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
Raw
Main.pas
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.
Raw
SampleGCObjects.pas
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.
Raw
SampleGCObjects2.pas
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.
Raw
SampleGCThread.pas
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.
Raw
stGC.pas
{*******************************************************}
{ }
{ 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
// Result := _Release;
Result := tGCManager.GetGCObject(Self).Release;
end;
function tGCAbstractObject._AddFieldRef: Integer;
begin
Result := -1;
end;
function tGCAbstractObject._AddRef: Integer;
begin
Result := tGCManager.GetGCObject(Self).Acquire;
end;
function tGCAbstractObject._Release: Integer;
begin
Result := tGCManager.GetGCObject(Self).Release;
end;
function tGCAbstractObject._ReleaseField: Integer;
begin
Result := -1;
end;
initialization
gDefaultManager := tGCManager.Create;
finalization
FreeAndNil(gDefaultManager);
end.
Raw
stGCFieldFinder.pas
{*******************************************************}
{ }
{ StreamSec Security Library for CodeGear Delphi }
{ Garbage Collection Class Definition Unit }
{ }
{ Copyright (C) 2009 StreamSec Handelsbolag }
{ Commercial use requires permission }
{ }
{*******************************************************}
unit stGCFieldFinder;
interface
uses
SysUtils, TypInfo, stGC;
type
tGCStaticFieldDefinition = record
fOffset: Integer;
end;
tGCFieldDefinitions = class;
iGCFieldDefinitions = interface
procedure IterateFields(aObject: Pointer; var aLast: pGCHeader);
procedure CleanupFields(aObject: Pointer);
end;
tGCDynamicFieldDefinition = record
fOffset: Integer;
fSize: Integer;
fElement: iGCFieldDefinitions;
end;
tGCFieldDefinitions = class(TInterfacedObject,iGCFieldDefinitions)
private
fClassID: IntPtr;
fStaticFields: array of tGCStaticFieldDefinition;
fDynamicFields: array of tGCDynamicFieldDefinition;
function ParseArray(aTypeInfo: PTypeInfo; aBaseOffset, aCount: Integer): Boolean;
function ParseRecord(aTypeInfo: PTypeInfo; aBaseOffset: Integer): Boolean;
function ParseClass(aTypeInfo: PTypeInfo): Boolean;
class function GetOrCreateDefinitions(aClass: TClass): tGCFieldDefinitions;
procedure IterateFields(aObject: Pointer; var aLast: pGCHeader);
procedure CleanupFields(aObject: Pointer);
class procedure FreeAllDefinitions;
public
constructor CreateSub;
constructor Create(aClass: TClass);
class procedure GetFields(aObject: TObject; var aLast: pGCHeader);
class procedure Cleanup(aObject: TObject);
end;
implementation
type
tFieldInfo = packed record
fTypeInfo: PPTypeInfo;
fOffset: Integer;
end;
pFieldTable = ^tFieldTable;
tFieldTable = packed record
fSize: Integer;
fCount: Integer;
fFields: array [0..0] of tFieldInfo;
end;
function FieldTableFromTypeInfo(aTypeInfo: PTypeInfo): pFieldTable;
begin
Result := pFieldTable(IntPtr(aTypeInfo) + Byte(aTypeInfo.Name[0]) + 2);
end;
function CRC16(aID: IntPtr): Word;
const
cShift = 16;
cDivisor: Cardinal = $80050000;
var
lIdx: Integer;
begin
for lIdx := 1 to cShift do begin
if aId < 0 then
Cardinal(aId) := Cardinal(aID) xor cDivisor;
Cardinal(aID) := Cardinal(aID) + Cardinal(aID);
end;
Result := aID shr cShift;
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;
var
gHashTable: array [0..$FFFF] of array of tGCFieldDefinitions;
{ tGCFieldDefinitions }
class procedure tGCFieldDefinitions.Cleanup(aObject: TObject);
begin
try
GetOrCreateDefinitions(aObject.ClassType).CleanupFields(aObject);
finally
end;
end;
procedure tGCFieldDefinitions.CleanupFields(aObject: Pointer);
var
I, J, lLen, lSize: Integer;
lObj, lObj2: Pointer;
lElem: iGCFieldDefinitions;
begin
for I := 0 to Length(fStaticFields) - 1 do try
PPointer(IntPtr(aObject) + fStaticFields[I].fOffset)^ := nil;
finally
end;
for I := 0 to Length(fDynamicFields) - 1 do try
lObj := PPointer(IntPtr(aObject) + fDynamicFields[I].fOffset)^;
if Assigned(lObj) then begin
lLen := PInteger(IntPtr(lObj) - 4)^;
lSize := fDynamicFields[I].fSize;
lElem := fDynamicFields[I].fElement;
for J := 0 to lLen - 1 do begin
if Assigned(lElem) then begin
lObj2 := Pointer(IntPtr(lObj) + J*lSize);
lElem.CleanupFields(lObj2);
end else begin
PPointer(IntPtr(lObj) + J*lSize)^ := nil;
end;
end;
end;
finally
end;
end;
constructor tGCFieldDefinitions.Create(aClass: TClass);
var
lCRC: Word;
lIdx, lLen: Integer;
begin
fClassID := IntPtr(aClass);
while Assigned(aClass) do begin
ParseClass(PPointer(IntPtr(aClass) + vmtInitTable)^);
aClass := aClass.ClassParent;
end;
lCRC := CRC16(fClassID);
lLen := Length(gHashTable[lCRC]);
SetLength(gHashTable[lCRC],lLen + 1);
lIdx := lLen;
while lIdx > 0 do begin
if gHashTable[lCRC][lIdx-1].fClassID > fClassID then
gHashTable[lCRC][lIdx] := gHashTable[lCRC][lIdx-1]
else
Break;
Dec(lIdx);
end;
gHashTable[lCRC][lIdx] := Self;
end;
constructor tGCFieldDefinitions.CreateSub;
begin
end;
class procedure tGCFieldDefinitions.FreeAllDefinitions;
var
I, J: Integer;
begin
for I := 0 to High(gHashTable) do
for J := 0 to Length(gHashTable[I]) - 1 do
FreeAndNil(gHashTable[I][J]);
end;
class procedure tGCFieldDefinitions.GetFields(aObject: TObject;
var aLast: pGCHeader);
begin
GetOrCreateDefinitions(aObject.ClassType).IterateFields(aObject,aLast);
end;
class function tGCFieldDefinitions.GetOrCreateDefinitions(
aClass: TClass): tGCFieldDefinitions;
var
lCRC: Word;
lIdx: Integer;
begin
lCRC := CRC16(IntPtr(aClass));
Result := nil;
lIdx := 0;
while lIdx < Length(gHashTable[lCRC]) do begin
Result := gHashTable[lCRC][lIdx];
if Result.fClassID = IntPtr(aClass) then Break;
Result := nil;
Inc(lIdx);
end;
if Result = nil then
Result := tGCFieldDefinitions.Create(aClass);
end;
procedure tGCFieldDefinitions.IterateFields(aObject: Pointer;
var aLast: pGCHeader);
var
I, J, lLen, lSize: Integer;
lObj, lObj2: Pointer;
lInst: pGCHeader;
lElem: iGCFieldDefinitions;
begin
for I := 0 to Length(fStaticFields) - 1 do begin
lObj := PPointer(IntPtr(aObject) + fStaticFields[I].fOffset)^;
if Assigned(lObj) then begin
lInst := ObjectToGCHeader(iGCField(lObj).GetInstance);
if lInst.fNextLive = nil then begin
lInst.fNextLive := aLast.fNextLive;
aLast.fNextLive := lInst;
aLast := lInst;
end;
end;
end;
for I := 0 to Length(fDynamicFields) - 1 do begin
lObj := PPointer(IntPtr(aObject) + fDynamicFields[I].fOffset)^;
if Assigned(lObj) then begin
lLen := PInteger(IntPtr(lObj) - 4)^;
lSize := fDynamicFields[I].fSize;
lElem := fDynamicFields[I].fElement;
for J := 0 to lLen - 1 do begin
if Assigned(lElem) then begin
lObj2 := Pointer(IntPtr(lObj) + J*lSize);
lElem.IterateFields(lObj2,aLast);
end else begin
lObj2 := PPointer(IntPtr(lObj) + J*lSize)^;
if Assigned(lObj2) then begin
lInst := ObjectToGCHeader(iGCField(lObj2).GetInstance);
if lInst.fNextLive = nil then begin
lInst.fNextLive := aLast.fNextLive;
aLast.fNextLive := lInst;
aLast := lInst;
end;
end;
end;
end;
end;
end;
end;
function tGCFieldDefinitions.ParseArray(aTypeInfo : PTypeInfo;
aBaseOffset,
aCount : Integer)
: Boolean;
var
lFT: pFieldTable;
lTD: PTypeData;
lIdx: Integer;
lElem: tGCFieldDefinitions;
lSize: Cardinal;
begin
Result := False;
if (aCount = 0) or not Assigned(aTypeInfo) then Exit;
case aTypeInfo.Kind of
tkArray:
begin
lFT := FieldTableFromTypeInfo(aTypeInfo);
while aCount > 0 do begin
Result := ParseArray(lFT.fFields[0].fTypeInfo^,aBaseOffset,lFT.fCount);
Inc(aBaseOffset,lFT.fSize);
Dec(aCount);
end;
end;
tkRecord:
begin
lFT := FieldTableFromTypeInfo(aTypeInfo);
while aCount > 0 do begin
Result := ParseRecord(aTypeInfo,aBaseOffset);
Inc(aBaseOffset,lFT.fSize);
Dec(aCount);
end;
end;
tkInterface:
while Assigned(aTypeInfo) do begin
lTD := GetTypeData(aTypeInfo);
if CompareMem(@lTD.Guid,@IID_GCFieldBase,SizeOf(TGUID)) then begin
Result := True;
lIdx := Length(fStaticFields);
SetLength(fStaticFields,lIdx + aCount);
while aCount > 0 do begin
fStaticFields[lIdx].fOffset := aBaseOffset;
Inc(aBaseOffset,SizeOf(Pointer));
Inc(lIdx);
Dec(aCount);
end;
Break;
end else begin
if Assigned(lTD.IntfParent) then
aTypeInfo := lTD.IntfParent^
else
aTypeInfo := nil;
end;
end;
tkDynArray:
begin
lTD := GetTypeData(aTypeInfo);
if Assigned(lTD.elType) then begin
if lTD.elType^.Kind = tkInterface then begin
lSize := SizeOf(Pointer);
lTD := GetTypeData(lTD.elType^);
if CompareMem(@lTD.Guid,@IID_GCFieldBase,SizeOf(TGUID)) then begin
Result := True;
lIdx := Length(fDynamicFields);
SetLength(fDynamicFields,lIdx + aCount);
while aCount > 0 do begin
fDynamicFields[lIdx].fOffset := aBaseOffset;
fDynamicFields[lIdx].fSize := lSize;
fDynamicFields[lIdx].fElement := nil;
Inc(aBaseOffset,lSize);
Inc(lIdx);
Dec(aCount);
end;
end;
end else begin
lElem := tGCFieldDefinitions.CreateSub;
if lElem.ParseArray(lTD.elType^,0,1) then begin
Result := True;
lIdx := Length(fDynamicFields);
SetLength(fDynamicFields,lIdx + aCount);
while aCount > 0 do begin
fDynamicFields[lIdx].fOffset := aBaseOffset;
fDynamicFields[lIdx].fSize := lTD.elSize;
fDynamicFields[lIdx].fElement := lElem;
Inc(aBaseOffset,lTD.elSize);
Inc(lIdx);
Dec(aCount);
end;
end else
lElem.Free;
end;
end;
end;
end;
end;
function tGCFieldDefinitions.ParseClass(aTypeInfo: PTypeInfo): Boolean;
begin
Result := False;
if Assigned(aTypeInfo) then
Result := ParseRecord(aTypeInfo,0);
end;
function tGCFieldDefinitions.ParseRecord(aTypeInfo : PTypeInfo;
aBaseOffset: Integer)
: Boolean;
var
lFT: pFieldTable;
I: Cardinal;
begin
Result := False;
lFT := FieldTableFromTypeInfo(aTypeInfo);
for I := 0 to lFT.fCount-1 do
if ParseArray(lFT.fFields[I].fTypeInfo^,aBaseOffset+lFT.fFields[I].fOffset,1) then
Result := True;
end;
initialization
finalization
tGCFieldDefinitions.FreeAllDefinitions;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment